[cig-commits] r18826 - in seismo/3D/ADJOINT_TOMO/measure_adj: . scripts_tomo
carltape at geodynamics.org
carltape at geodynamics.org
Fri Aug 12 16:26:38 PDT 2011
Author: carltape
Date: 2011-08-12 16:26:38 -0700 (Fri, 12 Aug 2011)
New Revision: 18826
Added:
seismo/3D/ADJOINT_TOMO/measure_adj/ma_constants.f90
seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub.f90
seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub2.f90
seismo/3D/ADJOINT_TOMO/measure_adj/ma_variables.f90
seismo/3D/ADJOINT_TOMO/measure_adj/measure_adj.f90
seismo/3D/ADJOINT_TOMO/measure_adj/run_measure_adj.csh
seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_measure_adj.pl
seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_measure_adj.pl
Removed:
seismo/3D/ADJOINT_TOMO/measure_adj/mt_constants.f90
seismo/3D/ADJOINT_TOMO/measure_adj/mt_measure_adj.f90
seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub.f90
seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub2.f90
seismo/3D/ADJOINT_TOMO/measure_adj/mt_variables.f90
seismo/3D/ADJOINT_TOMO/measure_adj/run_mt_measure_adj.csh
seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_mt_measure_adj.pl
seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_mt_measure_adj.pl
Log:
IMPORTANT: renaming files for MEASURE_ADJ by deleting the "mt" tag originally intended to denote multitaper measurements and adjoint sources; the code is more general and handles many different measurements.
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/ma_constants.f90 (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/mt_constants.f90)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/ma_constants.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/ma_constants.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,36 @@
+module mt_constants
+
+ ! number of entries in window_chi output file
+ integer, parameter :: N_MEASUREMENT = 5
+ integer, parameter :: NCHI = 3*(N_MEASUREMENT-1) + 8
+
+ ! constants
+ double precision, parameter :: PI = 3.141592653589793d+00
+ double precision, parameter :: TWOPI = 2.0 * PI
+ complex*16, parameter :: CCI = cmplx(0.,1.)
+ double precision, parameter :: LARGE_VAL = 1.0d8
+
+ ! FFT parameters
+ integer, parameter :: LNPT = 15, NPT = 2**LNPT, NDIM = 80000
+ double precision, parameter :: FORWARD_FFT = 1.0
+ double precision, parameter :: REVERSE_FFT = -1.0
+
+ ! phase correction control parameters, set this between (PI, 2PI),
+ ! use a higher value for conservative phase wrapping
+ double precision, parameter :: PHASE_STEP = 1.5 * PI
+
+ ! filter parameters for xapiir bandpass subroutine (filter type is BP)
+ ! (These should match the filter used in pre-processing.)
+ double precision, parameter :: TRBDNDW = 0.3
+ double precision, parameter :: APARM = 30.
+ integer, parameter :: IORD = 4
+ integer, parameter :: PASSES = 2
+
+ ! takes waveform of first trace dat_dtw, without taking the difference waveform to the second trace syn_dtw
+ ! this is useful to cissor out later reflections which appear in data (no synthetics needed)
+ logical:: NO_WAVEFORM_DIFFERENCE = .false.
+
+ ! constructs adjoint sources for a "ray density" kernel, where all misfits are equal to one
+ logical:: DO_RAY_DENSITY_SOURCE = .false.
+
+end module mt_constants
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub.f90 (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub.f90)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,2082 @@
+module mt_sub
+
+ use mt_constants
+ use mt_variables
+ use mt_sub2
+ use ascii_rw
+
+ implicit none
+
+contains
+
+ ! =================================================================================================
+ ! subroutine mt_measure()
+ ! Boxcar/Cosine/Multitaper estimates of the transfer function between data and synthetics
+ !
+ ! Input:
+ ! is_mtm -- taper type: 1 for multitaper, 2 for boxcar taper, and 3 for cosine taper
+ ! datafile -- original data file in SAC format
+ ! file_prefix -- the output file prefix (usually in STA.NT.CMP.N format)
+ ! dat_dt(:), syn_dt(:) t0, dt, npts -- original data and synthetics array
+ ! tstart, tend -- start and end of the measurement window (can be from Alessia's code)
+ ! Output:
+ ! istart -- starting index of the windowed portion of original trace
+ ! dat_dtw(:), syn_dtw(:), nlen -- windowed and shifted data, windowed synthetics
+ ! tshift, dlnA, cc_max -- time shift and amplitude cross-correlation measurements
+ ! i_right -- the maximum reliable frequency estimate index
+ ! trans_w(:) -- estimates of transfer function
+ ! dtau_w(:), dlnA_w(:) -- estimates of travel-time and amplitude anomaly
+ ! err_dt(:), err_dlnA(:) -- error bar of the travel-time and amplitude estimates (MT only)
+ !
+ ! original coding in Fortran77 by Ying Zhou
+ ! upgraded to Fortran90 by Alessia Maggi
+ ! organized into package form by Qinya Liu
+ ! modifications by Carl Tape and Vala Hjorleifsdottir
+ !
+ ! =================================================================================================
+
+ subroutine mt_measure(datafile,file_prefix,dat_dt,syn_dt,t0,dt,npts,tstart,tend, &
+ istart,dat_dtw,syn_dtw,nlen,tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc, &
+ i_pmax_dat,i_pmax_syn,i_right,trans_w,dtau_w,dlnA_w,sigma_dt,sigma_dlnA,err_dt,err_dlnA)
+
+ implicit none
+ integer, intent(in) :: npts
+ double precision, dimension(:), intent(in) :: dat_dt,syn_dt
+ double precision, intent(in) :: tstart,tend,t0,dt
+ character(len=150), intent(in) :: file_prefix,datafile
+
+ double precision, intent(out) :: tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,sigma_dt,sigma_dlnA
+ complex*16, dimension(:), intent(out) :: trans_w
+ double precision, dimension(:), intent(out) :: dtau_w,dlnA_w,syn_dtw,dat_dtw,syn_dtw_cc
+ integer, intent(out) :: nlen,i_right,istart,i_pmax_dat,i_pmax_syn
+ double precision, dimension(:), intent(out), optional :: err_dt,err_dlnA
+ !double precision, intent(out), optional :: sigma_dt,sigma_dlnA
+
+ double precision, dimension(NPT) :: syn_vtw, syn_dtw_mt, syn_dtw_mt_dt, &
+ syn_dtw_cc_dt, dat_dtw_cc, syn_dtw_h, dat_dtw_h
+ double precision :: sfac1,fac,f0,df,df_new,dw, &
+ ampmax_unw,wtr_use_unw,ampmax,wtr_use,wtr_mtm,dtau_wa,dlnA_wa !omega
+ integer :: ishift,i,ictaper,j,fnum,i_amp_max_unw,i_amp_max,i_right_stop,idf_new,iom
+
+ complex*16, dimension(NPT) :: syn_dtwo, dat_dtwo, syn_dtw_ho, dat_dtw_ho, &
+ top_mtm, bot_mtm, trans_mtm, wseis_recon
+ double precision, dimension(NPT) :: wvec, ey1, ey2, dtau_mtm, dlnA_mtm, &
+ phi_w, abs_w, err_phi, err_abs, phi_mtm, abs_mtm
+ double precision :: eph_ave,edt_ave,eabs_ave,eabs2_ave,eph_iom,edt_iom,eabs_iom,eabs2_iom
+ double precision, dimension(:,:),allocatable :: tas,phi_mul,abs_mul,dtau_mul,dlnA_mul
+ character(len=150) :: filename
+ logical :: output_logical,display_logical
+
+ !-------------------------------------------------------------
+
+ if ( tstart < t0 .or. tend > t0+(npts-1)*dt .or. tstart >= tend) then
+ print *, 'tstart, t0, tend, t0+(npts-1)*dt:'
+ print *, tstart, t0, tend, t0+(npts-1)*dt
+ stop 'Check tstart and tend'
+ endif
+
+ ! initializes i_right
+ i_right = 0
+
+ ! LQY -- is this too small ???
+ wtr_mtm = 1.e-10
+
+ filename = trim(file_prefix)
+
+ if (DISPLAY_DETAILS) then
+ call dwascii(trim(file_prefix)//'_data',dat_dt,npts,t0,dt)
+ call dwascii(trim(file_prefix)//'_syn',syn_dt,npts,t0,dt)
+ !call dwsac1(trim(file_prefix)//'_data.sac',dat_dt,npts,t0,dt)
+ !call dwsac1(trim(file_prefix)//'_syn.sac',syn_dt,npts,t0,dt)
+
+!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'_data.sac',t0,npts,dat_dt)
+!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'_syn.sac',t0,npts,syn_dt)
+!!$ !call dwrite_sacfile_f(datafile,trim(file_prefix)//'_diff_dms.sac',t0,npts,dat_dt-syn_dt)
+!!$ !call dwrite_ascfile_f(trim(file_prefix)//'_data.txt',t0,dt,npts,dat_dt)
+!!$ !call dwrite_ascfile_f(trim(file_prefix)//'_syn.txt',t0,dt,npts,syn_dt)
+ endif
+
+ !--------------------------------------------------------------------------
+ ! window and interpolate data and synthetics
+ !--------------------------------------------------------------------------
+
+ ! interpolate data and synthetics, and also extract time-windowed records
+ call interpolate_dat_and_syn(dat_dt,syn_dt,tstart,tend,t0,dt,NPT,dat_dtw,syn_dtw,nlen,istart)
+
+ if (nlen <= 1) stop 'Check the length of the data and syn arrays'
+ if (nlen > NPT) stop 'Check the dimension of data and syn arrays'
+
+ ! some constants
+ sfac1 = (2./dble(nlen))**2 ! for Welch window
+ ipwr_t = 10 ! for time-domain cosine taper: 1 - [cos(t)]^(ipwr)
+
+ ! pre-processing time-domain taper
+ do i = 1,nlen
+ !fac = 1. ! boxcar window
+ !fac = 1 - sfac1*((i-1) - dble(nlen)/2.)**2 ! welch window
+ fac = 1. - cos(PI*(i-1)/(nlen-1))**ipwr_t ! cosine window
+
+ syn_dtw(i) = syn_dtw(i) * fac ! syn, windowed
+ dat_dtw(i) = dat_dtw(i) * fac ! dat, windowed
+ enddo
+
+ if (DISPLAY_DETAILS) then
+ print *, ' NPTs = ', NPT, ' new nlen = ', nlen
+ call dwsac1(trim(file_prefix)//'.obs.sac',dat_dtw,nlen,tstart,dt)
+ call dwsac1(trim(file_prefix)//'.syn.sac',syn_dtw,nlen,tstart,dt)
+!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'.obs.sac',tstart,nlen,dat_dtw)
+!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'.syn.sac',tstart,nlen,syn_dtw)
+ endif
+
+ ! save a copy of the windowed data
+ !dat_dtwc(:) = dat_dtw(:)
+
+ !------------------------------------------------------------------
+ ! cross-correlation traveltime and amplitude measurements
+ !------------------------------------------------------------------
+
+ ! compute cross-correlation time shift and also amplitude measurmement
+ ! NOTE: records have already been windowed, so no information outside windows is considered
+ ! LQY: Ying suggested to align them at relatively long periods
+ call compute_cc(syn_dtw, dat_dtw, nlen, dt, ishift, tshift, dlnA, cc_max)
+
+ ! compute velocity of synthetics
+ do i = 2, nlen-1
+ syn_vtw(i) = (syn_dtw(i+1) - syn_dtw(i-1)) / (2.0*dt)
+ enddo
+ syn_vtw(1) = (syn_dtw(2) - syn_dtw(1)) / dt
+ syn_vtw(nlen) = (syn_dtw(nlen) - syn_dtw(nlen-1)) /dt
+
+ ! acceleration
+ !do i = 2, nlen-1
+ ! syn_atw(i) = (syn_vtw(i+1) - syn_vtw(i-1)) / (2.0*dt)
+ !enddo
+ !syn_atw(1) = (syn_vtw(2) - syn_vtw(1)) / dt
+ !syn_atw(nlen) = (syn_vtw(nlen) - syn_vtw(nlen-1)) / dt
+
+ ! deconstruct data using (negative) cross-correlation measurments
+ call deconstruct_dat_cc(filename,dat_dtw,tstart,dt,nlen, &
+ ishift,tshift,dlnA,dat_dtw_cc)
+
+ ! reconstruct synthetics using cross-correlation measurments (plotting purposes only)
+ call reconstruct_syn_cc(syn_dtw,tstart,dt,nlen,ishift,tshift,dlnA,syn_dtw_cc,syn_dtw_cc_dt)
+
+ if (OUTPUT_MEASUREMENT_FILES) then
+ call dwsac1(trim(filename)//'.recon_syn_cc.sac',syn_dtw_cc,nlen,tstart,dt)
+ call dwsac1(trim(filename)//'.recon_syn_cc_dt.sac',syn_dtw_cc_dt,nlen,tstart,dt)
+!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_cc.sac',tstart,nlen,syn_dtw_cc)
+!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_cc_dt.sac',tstart,nlen,syn_dtw_cc_dt)
+!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn',tstart,dt,nlen,syn_dtw_cc)
+!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn_dt',tstart,dt,nlen,syn_dtw_dt)
+ endif
+
+ ! compute the estimated uncertainty for the cross-correlation measurment
+ sigma_dt_cc = 1.
+ sigma_dlnA_cc = 1.
+ call compute_average_error(dat_dtw,syn_dtw_cc,syn_dtw_cc_dt,nlen,dt,sigma_dt_cc,sigma_dlnA_cc)
+
+ ! write cross-correlation measurement to file
+ call write_average_meas(filename,imeas,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc)
+
+ !========================================
+
+ ! CHT: if you want a simple waveform difference, then return
+ if (is_mtm == 0) return
+
+ !-----------------------------------------------------------------------------
+ ! set up FFT for the frequency domain
+ !-----------------------------------------------------------------------------
+
+ ! calculate frequency step and number of frequencies
+ f0 = 0.
+ df = 1./(NPT*dt)
+ dw = TWOPI * df
+ fnum = NPT/2 + 1
+
+ ! calculate frequency spacing of sampling points
+ df_new = 1.0 / (tend-tstart)
+ idf_new = df_new / df
+
+ ! assemble omega vector (NPT is the FFT length)
+ wvec(:) = 0.
+ do j = 1,NPT
+ if(j > NPT/2+1) then
+ wvec(j) = dw*(j-NPT-1) ! negative frequencies in second half
+ else
+ wvec(j) = dw*(j-1) ! positive frequencies in first half
+ endif
+ enddo
+
+ ! create complex synthetic seismogram and CC-deconstructed data seismogram
+ syn_dtwo = cmplx(0.,0.)
+ dat_dtwo = cmplx(0.,0.)
+ !syn_dtwo(1:nlen) = syn_dtw(1:nlen)
+ !dat_dtwo(1:nlen) = dat_dtw_cc(1:nlen)
+ syn_dtwo(1:nlen) = cmplx(syn_dtw(1:nlen))
+ dat_dtwo(1:nlen) = cmplx(dat_dtw_cc(1:nlen))
+
+ call fft(LNPT,syn_dtwo,FORWARD_FFT,dt)
+ call fft(LNPT,dat_dtwo,FORWARD_FFT,dt)
+
+ ! index of the freq of the max power in the windowed data
+ ampmax_unw = 0.
+ i_pmax_dat = 1
+ do i = 1, fnum ! loop over frequencies
+ if( abs(dat_dtwo(i)) > ampmax_unw) then
+ ampmax_unw = abs(dat_dtwo(i))
+ i_pmax_dat = i
+ endif
+ enddo
+
+ ! water level based untapered synthetics
+ ! used to determine the i_right values (maximum frequency for measurement)
+ ampmax_unw = 0.
+ do i = 1, fnum ! loop over frequencies
+ if( abs(syn_dtwo(i)) > ampmax_unw) then
+ ampmax_unw = abs(syn_dtwo(i))
+ i_amp_max_unw = i
+ endif
+ enddo
+ wtr_use_unw = cmplx(ampmax_unw * WTR, 0.)
+
+ ! index of the freq of the max power in the windowed synthetics
+ i_pmax_syn = i_amp_max_unw
+
+ i_right = fnum
+ i_right_stop = 0
+ do i = 1,fnum
+ if( abs(syn_dtwo(i)) <= abs(wtr_use_unw) .and. i_right_stop==0 .and. i > i_amp_max_unw ) then
+ i_right_stop = 1
+ i_right = i
+ endif
+ if( abs(syn_dtwo(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop==1 .and. i > i_amp_max_unw) then
+ i_right_stop = 0
+ i_right = i
+ endif
+ enddo
+
+ if (DISPLAY_DETAILS) then
+ print *, 'Frequency of max power in windowed synthetic (Hz):'
+ print *, ' i_pmax_syn = ', i_pmax_syn, ', f_pmax = ', sngl(i_pmax_syn * df), ', T_pmax = ', sngl(1./(i_pmax_syn*df))
+ print *, 'FFT freq spacing df = ', sngl(df)
+ print *, 'measurement spacing df_new = ', sngl(df_new)
+ print *, ' i_right = ', i_right, ', stopping freq = ', sngl(i_right * df)
+
+ ! write out power for each signal
+ call dwascii(trim(file_prefix)//'.obs.power',abs(dat_dtwo(1:i_right)),i_right,df,df)
+ call dwascii(trim(file_prefix)//'.syn.power',abs(syn_dtwo(1:i_right)),i_right,df,df)
+ !call dwsac1(trim(file_prefix)//'.obs.power.sac',abs(dat_dtwo(1:i_right)),i_right,df,df)
+ !call dwsac1(trim(file_prefix)//'.syn.power.sac',abs(syn_dtwo(1:i_right)),i_right,df,df)
+!!$ call dwrite_ascfile_f(trim(file_prefix)//'.obs.power',df,df,i_right,abs(dat_dtwo(1:i_right)) )
+!!$ call dwrite_ascfile_f(trim(file_prefix)//'.syn.power',df,df,i_right,abs(syn_dtwo(1:i_right)) )
+
+ endif
+
+ !-------------------------------------------------------------------------------
+ ! single-taper estimation of transfer function
+ !-------------------------------------------------------------------------------
+
+ ! assign number of tapers
+ if (is_mtm == 1) then
+ ntaper = int(NPI * 2.0)
+ else
+ ntaper = 1
+ endif
+ allocate(tas(NPT,ntaper))
+
+ ! calculate the tapers
+ if (is_mtm == 1) then
+ call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
+ elseif (is_mtm == 2) then
+ call costaper(nlen, NPT, tas)
+ elseif (is_mtm == 3) then
+ call boxcar(nlen, NPT, tas)
+ endif
+!!$ if (is_mtm == 1) then
+!!$ call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
+!!$ elseif (is_mtm == 2) then
+!!$ call costaper(nlen, NPT, tas)
+!!$ elseif (is_mtm == 3) then
+!!$ call boxcar(nlen, NPT, tas)
+!!$ endif
+
+ ! initialize transfer function terms
+ top_mtm(:) = cmplx(0.,0.)
+ bot_mtm(:) = cmplx(0.,0.)
+ trans_mtm(:) = cmplx(0.,0.)
+
+ do ictaper = 1, ntaper
+
+ syn_dtw_ho(:) = cmplx(0.,0.) ! note: this has to be initialized inside the loop
+ dat_dtw_ho(:) = cmplx(0.,0.)
+
+ ! apply time-domain taper
+ do i = 1, nlen
+ syn_dtw_h(i) = syn_dtw(i) * tas(i,ictaper) ! single-tapered, windowed syn
+ dat_dtw_h(i) = dat_dtw_cc(i) * tas(i,ictaper) ! single-tapered, windowed, shifted data
+ enddo
+
+ syn_dtw_ho(1:nlen) = cmplx(syn_dtw_h(1:nlen),0.)
+ dat_dtw_ho(1:nlen) = cmplx(dat_dtw_h(1:nlen),0.)
+
+ ! apply FFT to get complex spectra
+ call fft(LNPT,syn_dtw_ho,FORWARD_FFT,dt)
+ call fft(LNPT,dat_dtw_ho,FORWARD_FFT,dt)
+
+ ! compute water level for single taper measurement by finding max spectral power
+ ! in the tapered synthetics record
+ ampmax = 0.
+ do i = 1, fnum ! loop over frequencies
+ if( abs(syn_dtw_ho(i)) > ampmax) then ! syn, single_tapered
+ ampmax = abs(syn_dtw_ho(i))
+ i_amp_max = i
+ endif
+ enddo
+ wtr_use = cmplx(ampmax * WTR, 0.)
+ !print *, ' wtr_use :', wtr_use
+
+ ! calculate top and bottom of MT transfer function
+ do i = 1, fnum
+ top_mtm(i) = top_mtm(i) + dat_dtw_ho(i) * conjg(syn_dtw_ho(i)) ! uses data and syn
+ bot_mtm(i) = bot_mtm(i) + syn_dtw_ho(i) * conjg(syn_dtw_ho(i)) ! uses syn only
+
+ ! calculate transfer function for single taper measurement using water level
+ if (is_mtm /= 1) then
+ if(abs(syn_dtw_ho(i)) > abs(wtr_use)) trans_w(i) = dat_dtw_ho(i) / syn_dtw_ho(i)
+ if(abs(syn_dtw_ho(i)) <= abs(wtr_use)) trans_w(i) = dat_dtw_ho(i) / (syn_dtw_ho(i)+wtr_use)
+ endif
+ enddo
+
+ ! for cosine or boxcar tapers only -- SEE COMMENTS BELOW for the multitaper case
+ ! NOTE 1: here we are using trans_w, not trans_mtm
+ ! NOTE 2: The single-taper transfer function should give you a perfect fit,
+ ! but it is not relevant from the perspective of obtaining a measurement.
+ if (is_mtm /= 1) then
+ ! phase, abs(trans), travel-time and amplitude as a func of freq for single-tapered measurements
+ call write_trans(filename,trans_w,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
+ phi_w,abs_w,dtau_w,dlnA_w,dtau_wa,dlnA_wa)
+ call reconstruct_syn(filename,syn_dtwo,wvec,dtau_w,dlnA_w, &
+ i_right,tstart,dt,nlen,syn_dtw_mt, syn_dtw_mt_dt)
+ !call check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift,tshift_f1f2,cc_max_f1f2,cc_max)
+ !call compute_average_error(dat_dtw,syn_dtw_mt,syn_dtw_mt_dt,nlen,dt,sigma_dt,sigma_dlnA)
+ !call write_average_meas(filename, imeas, dtau_wa, dlnA_wa, sigma_dt, sigma_dlnA)
+ endif
+
+ enddo ! ictapers
+
+ ! for single taper, pass back the transfer function
+ if (is_mtm /= 1) return
+
+ !-------------------------------------------------------------------------------
+ ! multitaper estimation of transfer function
+ !-------------------------------------------------------------------------------
+
+ ! water level for multitaper measurements
+ ampmax = 0.
+ do i = 1, fnum
+ if( abs(bot_mtm(i)) > ampmax) then
+ ampmax = abs(bot_mtm(i))
+ i_amp_max = i
+ endif
+ enddo
+ wtr_use = cmplx(ampmax * wtr_mtm**2, 0.)
+ !wtr_use = cmplx(ampmax * WTR, 0.)
+
+ ! calculate MT transfer function using water level
+ do i = 1, fnum
+ if(abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i)
+ if(abs(bot_mtm(i)) < abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use)
+ enddo
+
+ ! multitaper phase, abs, tt, and amp (freq)
+ call write_trans(filename,trans_mtm,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
+ phi_mtm,abs_mtm,dtau_mtm,dlnA_mtm,dtau_wa,dlnA_wa)
+
+ ! apply transfer function to the syn
+ call reconstruct_syn(filename,syn_dtwo,wvec,dtau_mtm,dlnA_mtm, &
+ i_right,tstart,dt,nlen,syn_dtw_mt,syn_dtw_mt_dt)
+
+ ! check quality
+ !call check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift, tshift_f1f2, cc_max_f1f2,cc_max)
+
+ ! CHT: estimate error using the same procedure as for the cross-correlation error estimate
+ !sigma_dt = 1. ; sigma_dlnA = 1.
+ !call compute_average_error(dat_dtw,syn_dtw_mt,syn_dtw_mt_dt,nlen,dt,sigma_dt,sigma_dlnA)
+ sigma_dt = sigma_dt_cc ; sigma_dlnA = sigma_dlnA_cc
+
+ ! write average multitaper measurement to file
+ call write_average_meas(file_prefix, imeas, dtau_wa, dlnA_wa, sigma_dt, sigma_dlnA)
+
+ !-------------------------------------------------------------------------------
+ ! multitaper error estimation
+ !-------------------------------------------------------------------------------
+
+ if (ntaper > 1) then
+
+ ! save a copy of the control logicals
+ output_logical = OUTPUT_MEASUREMENT_FILES
+ display_logical = DISPLAY_DETAILS
+ ! avoid I/O output for MT error estimates
+ OUTPUT_MEASUREMENT_FILES = .false.
+ DISPLAY_DETAILS = .false.
+
+ ! allocate Jacknife MT estimates
+ allocate(phi_mul(NPT,ntaper))
+ allocate(abs_mul(NPT,ntaper))
+ allocate(dtau_mul(NPT,ntaper))
+ allocate(dlnA_mul(NPT,ntaper))
+
+ do iom = 1, ntaper
+
+ top_mtm(:) = cmplx(0.,0.)
+ bot_mtm(:) = cmplx(0.,0.)
+
+ do ictaper = 1, ntaper
+ if(ictaper.eq.iom) cycle
+
+ ! apply ictaper-th taper
+ syn_dtw_h(1:nlen) = syn_dtw(1:nlen) * tas(1:nlen,ictaper)
+ dat_dtw_h(1:nlen) = dat_dtw_cc(1:nlen) * tas(1:nlen,ictaper)
+
+ ! complex tapered series
+ syn_dtw_ho(:) = cmplx(0.,0.)
+ dat_dtw_ho(:) = cmplx(0.,0.)
+ syn_dtw_ho(1:nlen) = cmplx(syn_dtw_h(1:nlen),0.)
+ dat_dtw_ho(1:nlen) = cmplx(dat_dtw_h(1:nlen),0.)
+
+ ! apply f.t. to get complex spectra
+ call fft(LNPT,syn_dtw_ho,FORWARD_FFT,dt)
+ call fft(LNPT,dat_dtw_ho,FORWARD_FFT,dt)
+
+ ! calculate top and bottom of Jacknife transfer function
+ do i = 1, fnum
+ top_mtm(i) = top_mtm(i) + dat_dtw_ho(i) * conjg(syn_dtw_ho(i))
+ bot_mtm(i) = bot_mtm(i) + syn_dtw_ho(i) * conjg(syn_dtw_ho(i))
+ enddo
+ enddo ! ictaper
+
+ ! water level
+ ampmax = 0.
+ do i = 1, fnum
+ if( abs(bot_mtm(i)).gt.ampmax) then
+ ampmax = abs(bot_mtm(i))
+ i_amp_max = i
+ endif
+ enddo
+ wtr_use = cmplx(ampmax * wtr_mtm ** 2, 0.)
+
+ ! calculate transfer function using water level
+ do i = 1, fnum
+ if(abs(bot_mtm(i)).gt.abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i)
+ if(abs(bot_mtm(i)).le.abs(wtr_use)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_use)
+ enddo
+
+ call write_trans(filename,trans_mtm,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
+ phi_mul(:,iom),abs_mul(:,iom),dtau_mul(:,iom),dlnA_mul(:,iom))
+
+ enddo ! iom
+
+ !----------------------
+
+ open(10,file=trim(filename)//'.err_ph')
+ open(20,file=trim(filename)//'.err_dt')
+ open(30,file=trim(filename)//'.err_abs')
+ open(40,file=trim(filename)//'.err_dlnA')
+
+ ! CHT: Since all freq. domain points are used in constructing the
+ ! adjoint source, we also want to show the entire sigma(f) functions,
+ ! not just the sub-sampled version.
+ open(50,file=trim(filename)//'.err_dt_full')
+ open(60,file=trim(filename)//'.err_dlnA_full')
+
+ err_phi = 0.
+ err_dt = 0.
+ err_abs = 0.
+ err_dlnA = 0.
+
+ do i = 1, i_right
+
+ eph_ave = 0.
+ edt_ave = 0.
+ eabs_ave = 0.
+ eabs2_ave = 0.
+
+ do iom = 1, ntaper
+ eph_iom = ntaper*phi_mtm(i) - (ntaper-1)*phi_mul(i,iom)
+ eph_ave = eph_ave + eph_iom
+
+ edt_iom = ntaper*dtau_mtm(i) - (ntaper-1)*dtau_mul(i,iom)
+ edt_ave = edt_ave + edt_iom
+
+ eabs_iom = ntaper*abs_mtm(i) - (ntaper-1)*abs_mul(i,iom)
+ eabs_ave = eabs_ave + eabs_iom
+
+ eabs2_iom = ntaper*dlnA_mtm(i) - (ntaper-1)*dlnA_mul(i,iom)
+ eabs2_ave = eabs2_ave + eabs2_iom
+ enddo
+
+ eph_ave = eph_ave / (ntaper)
+ edt_ave = edt_ave / (ntaper)
+ eabs_ave = eabs_ave / (ntaper)
+ eabs2_ave = eabs2_ave / (ntaper)
+
+ do iom = 1, ntaper
+ err_phi(i) = err_phi(i) + ( phi_mul(i,iom) - eph_ave)**2
+ err_dt(i) = err_dt(i) + (dtau_mul(i,iom) - edt_ave)**2
+ err_abs(i) = err_abs(i) + ( abs_mul(i,iom) - eabs_ave)**2
+ err_dlnA(i) = err_dlnA(i)+ (dlnA_mul(i,iom) - eabs2_ave)**2
+ enddo
+
+ err_phi(i) = sqrt( err_phi(i) / (ntaper * (ntaper-1) ) )
+ err_dt(i) = sqrt( err_dt(i) / (ntaper * (ntaper-1) ) )
+ ! set the error bar for the first point corresponding to
+ ! static offset to be large, which makes no contribution to
+ ! the adjoint source
+ if (i == 1) err_dt(i) = LARGE_VAL
+ err_abs(i) = sqrt( err_abs(i) / (ntaper * (ntaper-1) ) )
+ err_dlnA(i) = sqrt( err_dlnA(i) / (ntaper * (ntaper-1) ) )
+
+ ! only write out the errors for the 'independent' freq-domain sampling points
+ if (mod(i,idf_new) == 0) then
+ write(10,*) df*(i-1), phi_mtm(i), err_phi(i)
+ if (i > 1) write(20,*) df*(i-1), dtau_mtm(i), err_dt(i)
+ write(30,*) df*(i-1), abs_mtm(i), err_abs(i)
+ write(40,*) df*(i-1), dlnA_mtm(i), err_dlnA(i)
+ endif
+
+ ! CHT: write out the entire dt(f) and dlnA(f) for adjoint sources
+ write(50,*) df*(i-1), dtau_mtm(i), err_dt(i)
+ write(60,*) df*(i-1), dlnA_mtm(i), err_dlnA(i)
+
+ enddo ! i_right
+
+ close(10)
+ close(20)
+ close(30)
+ close(40)
+ close(50)
+ close(60)
+
+ ! pass the MT transfer funnction
+ trans_w = trans_mtm
+ dtau_w = dtau_mtm
+ dlnA_w = dlnA_mtm
+
+ ! reset the control parameters
+ OUTPUT_MEASUREMENT_FILES = output_logical
+ DISPLAY_DETAILS = display_logical
+
+ endif
+
+ ! ------------------------------------------------------------------
+ ! End error calculation loop
+ ! ------------------------------------------------------------------
+
+ end subroutine mt_measure
+
+
+ ! =====================================================================================================
+ ! subroutine mt_adj()
+ ! Compute cross-correlation travel-time/amplitude/banana-donut travel-time/banana-donut amplitude
+ ! adjoint sources by assimulate the measurements passed from mt_measure()
+ !
+ ! Input:
+ ! imeas -- adjoint source type: 0 for waveform, 1 for multitaper, 2 for cc, 3 for cc banana-doughnut
+ ! istart -- starting index of the windowed portion of original trace, used to generate adjoint
+ ! source that correspond to the original synthetics
+ ! dat_dtw(:), syn_dtw(:), nlen, dt -- windowed data and synthetics
+ ! with length nlen and sampling rate dt
+ ! tshift, dlnA -- cross-correlation traveltime and amplitude measurements
+ ! dtau_w(:), dlnA_w(:), err_dtau(:), err_dlnA(:), i_right -- traveltime and amplitude measurements
+ ! and corresponding error bars as a function of frequency (1: i_right)
+ !
+ ! Output:
+ ! tr_adj_src(:), tr_chi -- travel-time adjoint source and chi value
+ ! am_adj_src(:), am_chi -- amplitude adjoint source and chi value
+ ! window_chi(:) -- all available scalar measurement values and chi values
+ !
+ ! original coding by Carl Tape, finalized by Qinya Liu
+ ! ======================================================================================================
+
+ subroutine mt_adj(istart,dat_dtw,syn_dtw,nlen,dt,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc, &
+ dtau_w,dlnA_w,err_dtau,err_dlnA,sigma_dt,sigma_dlnA,i_left,i_right, &
+ window_chi,tr_adj_src,tr_chi,am_adj_src,am_chi)
+
+ implicit none
+ integer, intent(in) :: istart, nlen, i_left, i_right
+ double precision, dimension(:), intent(in) :: dat_dtw, syn_dtw
+ double precision, intent(in) :: dt, tshift, dlnA, sigma_dt_cc, sigma_dlnA_cc, sigma_dt, sigma_dlnA
+ double precision, dimension(:), intent(in) :: dtau_w, dlnA_w, err_dtau, err_dlnA
+
+ double precision, dimension(:), intent(out) :: tr_adj_src, am_adj_src
+ double precision, intent(out) :: tr_chi, am_chi
+ double precision, dimension(NCHI), intent(inout) :: window_chi
+ !double precision, dimension(:), intent(out), optional :: am_adj_src
+ !double precision, intent(out), optional :: am_chi
+
+ double precision, dimension(NPT) :: syn_vtw, syn_vtw_h, syn_dtw_h, ey1, ey2
+ double precision, dimension(NPT) :: ft_bar_t, fa_bar_t, fp, fq, wp_taper, wq_taper
+ complex*16, dimension(NPT) :: d_bot_mtm, v_bot_mtm
+ integer :: i, i1, ictaper, ntaper
+ double precision :: df,Nnorm,Mnorm,fac,ffac,w_taper(NPT), time_window(NPT)
+ double precision, dimension(:,:), allocatable :: tas
+ complex*16, dimension(:,:),allocatable :: syn_dtw_ho_all, syn_vtw_ho_all
+ complex*16, dimension(NPT) :: pwc_adj,qwc_adj
+ double precision, dimension(NPT) :: dtau_pj_t, dlnA_qj_t
+ double precision :: dtau_wtr, dlnA_wtr, err_t, err_A
+ double precision :: waveform_chi, waveform_d2, waveform_s2, waveform_temp1, waveform_temp2, waveform_temp3
+
+ ! waveform adjoint source is passed by tr_adj_src and tr_chi
+ !if (imeas == 0 .and. (present(am_adj_src) .or. present(am_chi))) stop &
+ ! 'am_adj_src and am_chi are not needed for imeas = 0 (waveform adjoint source case)'
+
+ ! check the window length
+ if (istart + nlen > NDIM) stop 'Check istart + nlen and NPT'
+
+ ! waveform
+ if(imeas==1 .or. imeas==2) then
+ print *, 'computing waveform adjoint source'
+ elseif(imeas==3 .or. imeas==4) then
+ print *, 'computing banana-doughtnut adjoint source'
+ elseif(imeas==5 .or. imeas==6) then
+ print *, 'computing cross-correlation adjoint source'
+ elseif(imeas==7 .or. imeas==8) then
+ print *, 'computing multitaper adjoint source'
+ endif
+
+ ! ----------------------
+ ! TAPERS
+ ! ----------------------
+ if( is_mtm == 1 ) then
+ ! frequency-domain tapers
+ ! THIS CHOICE WILL HAVE AN EFFECT ON THE ADJOINT SOURCES
+ ipwr_w = 10
+ w_taper(:) = 0.
+ do i = i_left, i_right ! CHT: 1 --> i_left
+ ! type of filter in the freq domain
+ !w_taper(i) = 1. ! boxcar
+ !w_taper(i) = 1. - (2.0/nw)**2 * ((i-1) - nw/2.0)**2 ! welch
+ w_taper(i) = 1. - cos(PI*(i-i_left)/(i_right-i_left))**ipwr_w ! cosine
+ enddo
+
+ ! compute normalization factor for w_taper
+ ! note: 2 is needed for the integration from -inf to inf
+ df = 1. /(NPT*dt)
+ ffac = 2.0 * df * sum(w_taper(i_left:i_right) ) ! CHT: 1 --> i_left
+ if (DISPLAY_DETAILS) print *, 'Taper normalization factor, ffac = ', ffac
+
+ ! wp_taper and wq_taper are modified frequency-domain tapers
+ ! Notice the option to include the frequency-dependent error.
+ wp_taper(:) = 0.
+ wq_taper(:) = 0.
+ dtau_wtr = WTR * sum(abs(dtau_w(i_left:i_right)))/(i_right-i_left) ! CHT i_left
+ dlnA_wtr = WTR * sum(abs(dlnA_w(i_left:i_right)))/(i_right-i_left) ! CHT i_left
+
+ do i = i_left, i_right ! CHT: 1 --> i_left
+
+ if (ERROR_TYPE == 0 .or. DO_RAY_DENSITY_SOURCE ) then
+ ! no error estimate
+ ! only adds normalization factor
+ wp_taper(i) = w_taper(i) / ffac
+ wq_taper(i) = w_taper(i) / ffac
+
+ elseif (ERROR_TYPE == 1) then
+ ! MT error estimate is assigned the CC error estimate
+ wp_taper(i) = w_taper(i) / ffac / (sigma_dt ** 2)
+ wq_taper(i) = w_taper(i) / ffac / (sigma_dlnA ** 2)
+
+ elseif (ERROR_TYPE == 2) then
+ ! MT jack-knife error estimate
+ err_t = err_dtau(i)
+ if (err_dtau(i) < dtau_wtr) err_t = err_t + dtau_wtr
+ err_A = err_dlnA(i)
+ if (err_dlnA(i) < dlnA_wtr) err_A = err_A + dlnA_wtr
+ wp_taper(i) = w_taper(i) / ffac / (err_t ** 2)
+ wq_taper(i) = w_taper(i) / ffac / (err_A ** 2)
+ endif
+ enddo
+
+!!$ open(88,file='ftaper.dat')
+!!$ do i = 1,i_right
+!!$ write(88,'(5e18.6)') df*i, w_taper(i), dtau_w(i), dtau_w(i)*w_taper(i), dtau_w(i)*wp_taper(i)
+!!$ enddo
+!!$ close(88)
+
+ endif ! is_mtm == 1
+
+
+ ! post-processing time-domain taper
+ ! NOTE: If the adjoint sources will be band-pass filtered at the end,
+ ! then perhaps time_window is not necessary (i.e., use boxcar).
+ ! However, if you are using a waveform difference, then you want
+ ! to make sure that the endpoints of the windows are at zero, since
+ ! you would NOT apply the post-processing band-pass filter.
+ time_window(:) = 0.
+ ipwr_t = 10
+ do i = 1,nlen
+ fac = 1. ! boxcar window
+ !fac = 1 - sfac2*((i-1) - dble(nlen1)/2.0)**2 ! welch window
+ !fac = 1. - cos(PI*(i-1)/(nlen-1))**ipwr_t ! cosine window
+ time_window(i) = fac
+ enddo
+
+ ! ----------------------------------
+ ! CROSS CORRELATION ADJOINT SOURCES
+ ! ----------------------------------
+ if( (imeas >= 3).and.(imeas <= 6) ) then
+
+ ! compute synthetic velocity
+ do i = 2, nlen-1
+ syn_vtw(i) = (syn_dtw(i+1) - syn_dtw(i-1)) / (2.0*dt)
+ enddo
+ syn_vtw(1) = (syn_dtw(2) - syn_dtw(1)) / dt
+ syn_vtw(nlen) = (syn_dtw(nlen) - syn_dtw(nlen-1)) / dt
+
+ ! compute CC traveltime and amplitude banana-dougnut kernels
+ ft_bar_t = 0.
+ Nnorm = dt * sum( syn_vtw(1:nlen) * syn_vtw(1:nlen) )
+ ft_bar_t(1:nlen) = -syn_vtw(1:nlen) / Nnorm
+
+ fa_bar_t = 0.
+ Mnorm = dt * sum( syn_dtw(1:nlen) * syn_dtw(1:nlen) )
+ fa_bar_t(1:nlen) = syn_dtw(1:nlen) / Mnorm
+ endif
+
+ ! -------------------------------
+ ! MULTITAPER ADJOINT SOURCES
+ ! -------------------------------
+
+ if ( (is_mtm == 1).and.COMPUTE_ADJOINT_SOURCE ) then
+
+ ! allocate MT variables
+ ntaper = int(NPI * 2.0)
+ allocate(tas(NPT,ntaper))
+ allocate(syn_dtw_ho_all(NPT,ntaper))
+ allocate(syn_vtw_ho_all(NPT,ntaper))
+
+ ! get the MT tapers
+ call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
+
+ d_bot_mtm = 0.
+ v_bot_mtm = 0.
+
+ ! compute the bot required to compute p_j's and q_j's
+ do ictaper = 1,ntaper
+
+ ! tapered synthetic displacement
+ syn_dtw_h(1:nlen) = syn_dtw(1:nlen) * tas(1:nlen,ictaper)
+
+ ! compute velocity of tapered syn
+ do i = 2, nlen-1
+ syn_vtw_h(i) = (syn_dtw_h(i+1) - syn_dtw_h(i-1)) / (2.0*dt)
+ enddo
+ syn_vtw_h(1) = (syn_dtw_h(2) - syn_dtw_h(1)) / dt
+ syn_vtw_h(nlen) = (syn_dtw_h(nlen) - syn_dtw_h(nlen-1)) /dt
+
+ ! single-tapered complex synthetic displacement and velocity
+ syn_dtw_ho_all(:,ictaper) = 0.
+ syn_vtw_ho_all(:,ictaper) = 0.
+ syn_dtw_ho_all(1:nlen,ictaper) = cmplx(syn_dtw_h(1:nlen),0.)
+ syn_vtw_ho_all(1:nlen,ictaper) = cmplx(syn_vtw_h(1:nlen),0.)
+
+ ! apply FFT get complex spectra
+ call fft(LNPT,syn_dtw_ho_all(:,ictaper),FORWARD_FFT,DT)
+ call fft(LNPT,syn_vtw_ho_all(:,ictaper),FORWARD_FFT,DT)
+
+ d_bot_mtm(:) = d_bot_mtm(:) + syn_dtw_ho_all(:,ictaper) * conjg(syn_dtw_ho_all(:,ictaper))
+ v_bot_mtm(:) = v_bot_mtm(:) + syn_vtw_ho_all(:,ictaper) * conjg(syn_vtw_ho_all(:,ictaper))
+
+ enddo ! ictaper
+
+ ! compute p_j, q_j, P_j, Q_j and adjoint source fp, fq
+ fp = 0.
+ fq = 0.
+ do ictaper = 1,ntaper
+
+ ! compute p_j(w) and q_j(w)
+ pwc_adj(:) = cmplx(0.,0.)
+ qwc_adj(:) = cmplx(0.,0.)
+
+ do i = 1, i_right
+ pwc_adj(i) = syn_vtw_ho_all(i,ictaper) / v_bot_mtm(i)
+ qwc_adj(i) = -syn_dtw_ho_all(i,ictaper) / d_bot_mtm(i)
+ enddo
+
+ ! compute P_j(w) and Q_j(w)
+ ! NOTE: the MT measurement is incorporated here
+ ! also note that wp_taper and wq_taper can contain uncertainty estimations
+ if( DO_RAY_DENSITY_SOURCE ) then
+ ! uses a misfit measurement dtau, dlnA = 1
+ pwc_adj(:) = pwc_adj(:) * cmplx(1.0,0.) * cmplx(wp_taper(:),0.)
+ qwc_adj(:) = qwc_adj(:) * cmplx(1.0,0.) * cmplx(wq_taper(:),0.)
+ else
+ ! adds misfit measurement dtau, dlnA
+ pwc_adj(:) = pwc_adj(:) * cmplx(dtau_w(:),0.) * cmplx(wp_taper(:),0.)
+ qwc_adj(:) = qwc_adj(:) * cmplx(dlnA_w(:),0.) * cmplx(wq_taper(:),0.)
+ endif
+
+ ! IFFT into the time domain
+ call fftinv(LNPT,pwc_adj,REVERSE_FFT,dt,dtau_pj_t)
+ call fftinv(LNPT,qwc_adj,REVERSE_FFT,dt,dlnA_qj_t)
+
+ ! create adjoint source
+ ! applies taper to time signal
+ fp(:) = fp(:) + tas(:,ictaper) * dtau_pj_t(:)
+ fq(:) = fq(:) + tas(:,ictaper) * dlnA_qj_t(:)
+
+ enddo
+
+ endif ! MT adjoint source
+
+ ! -------------------------------------
+ ! COMPUTE ADJOINT SOURCE
+ ! -------------------------------------
+
+ tr_adj_src = 0.
+ am_adj_src = 0.
+
+ ! integrated waveform difference squared
+ waveform_temp1 = 0. ; waveform_temp2 = 0. ; waveform_temp3 = 0.
+ do i = 1,nlen
+ waveform_temp1 = waveform_temp1 + ( dat_dtw(i) * time_window(i) )**2
+ waveform_temp2 = waveform_temp2 + ( syn_dtw(i) * time_window(i) )**2
+ waveform_temp3 = waveform_temp3 + (( dat_dtw(i) - syn_dtw(i) ) * time_window(i) )**2
+ enddo
+ ! NOTE: does not include DT factor or normalization by duration of window
+ waveform_d2 = waveform_temp1
+ waveform_s2 = waveform_temp2
+ waveform_chi = waveform_temp3
+
+ ! compute traveltime and amplitude adjoint sources
+ if (COMPUTE_ADJOINT_SOURCE) then
+
+ do i = 1,nlen
+ i1 = istart + i
+
+ ! waveform
+ if(imeas==1 .or. imeas==2) then
+ tr_adj_src(i1) = -dat_dtw(i)/waveform_d2 * time_window(i)
+ am_adj_src(i1) = ( syn_dtw(i) - dat_dtw(i) ) * time_window(i)
+ ! consider normalizing this by waveform_d2
+
+ ! use pure data waveform in time window
+ if( NO_WAVEFORM_DIFFERENCE ) then
+ tr_adj_src(i1) = dat_dtw(i) * time_window(i) ! waveform misfit
+ endif
+
+ ! banana-doughnut kernel adjoint source (no measurement)
+ elseif(imeas==3 .or. imeas==4) then
+ tr_adj_src(i1) = ft_bar_t(i) * time_window(i)
+ am_adj_src(i1) = fa_bar_t(i) * time_window(i)
+
+ ! cross-correlation
+ elseif(imeas==5 .or. imeas==6) then
+ tr_adj_src(i1) = -(tshift / sigma_dt_cc**2 ) * ft_bar_t(i) * time_window(i)
+ am_adj_src(i1) = -(dlnA / sigma_dlnA_cc**2 ) * fa_bar_t(i) * time_window(i)
+
+ ! ray density
+ if( DO_RAY_DENSITY_SOURCE ) then
+ ! uses a misfit measurement of 1
+ tr_adj_src(i1) = - (1.0) * ft_bar_t(i) * time_window(i)
+ am_adj_src(i1) = - (1.0) * fa_bar_t(i) * time_window(i)
+ endif
+
+ ! multitaper
+ elseif(imeas==7 .or. imeas==8) then
+ tr_adj_src(i1) = fp(i) * time_window(i)
+ am_adj_src(i1) = fq(i) * time_window(i)
+ endif
+ enddo
+
+ endif
+
+ ! -------------------------------------
+ ! COMPUTE MISFIT FUNCTION VALUE
+ ! -------------------------------------
+
+ ! CHT: compute misfit function value and measurement value
+ ! Note: The taper functions for MT may include error estimates.
+ ! 1: multitaper, TT
+ ! 2: multitaper, dlnA
+ ! 3: cross-correlation, TT
+ ! 4: cross-correlation, dlnA
+ !window_chi(:) = 0.
+
+
+ ! misfit function value
+ if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (dtau_w(1:i_right))**2 * wp_taper(1:i_right) )
+ if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (dlnA_w(1:i_right))**2 * wq_taper(1:i_right) )
+ window_chi(3) = 0.5 * (tshift/sigma_dt_cc)**2
+ window_chi(4) = 0.5 * (dlnA/sigma_dlnA_cc)**2
+
+ ! measurement (no uncertainty estimates)
+ if(is_mtm==1) window_chi(5) = sum( dtau_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
+ if(is_mtm==1) window_chi(6) = sum( dlnA_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
+ window_chi(7) = tshift
+ window_chi(8) = dlnA
+
+ ! replaces misfit function values
+ if( DO_RAY_DENSITY_SOURCE ) then
+ ! uses misfit measurements equal to 1
+ ! misfit function value
+ if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (1.0)**2 * wp_taper(1:i_right) )
+ if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (1.0)**2 * wq_taper(1:i_right) )
+ window_chi(3) = 0.5 * (1.0)**2
+ window_chi(4) = 0.5 * (1.0)**2
+
+ ! measurement (no uncertainty estimates)
+ if(is_mtm==1) window_chi(5) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
+ if(is_mtm==1) window_chi(6) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
+ window_chi(7) = 1.0
+ window_chi(8) = 1.0
+ endif
+
+ ! estimated mesurement uncertainties
+ if(is_mtm==1) window_chi(9) = sigma_dt
+ if(is_mtm==1) window_chi(10) = sigma_dlnA
+ window_chi(11) = sigma_dt_cc
+ window_chi(12) = sigma_dlnA_cc
+
+ ! for normalization, divide by duration of window
+ window_chi(13) = 0.5 * waveform_d2
+ window_chi(14) = 0.5 * waveform_s2
+ window_chi(15) = 0.5 * waveform_chi
+ window_chi(16) = nlen*dt
+
+!!$ open(88,file='testing.dat')
+!!$ do i = 1,i_right
+!!$ write(88,'(5e18.6)') df*i, dtau_w(i), dlnA_w(i), wp_taper(i), wq_taper(i)
+!!$ enddo
+!!$ close(88)
+
+ if(imeas <= 2) then ! waveform
+ tr_chi = 0.5 * waveform_chi
+ am_chi = 0.5 * waveform_chi
+
+ elseif( (imeas >= 3).and.(imeas <= 6) ) then ! cross_correlation
+ tr_chi = window_chi(3)
+ am_chi = window_chi(4)
+
+ elseif( (imeas==7).or.(imeas==8) ) then ! multitaper
+ tr_chi = window_chi(1)
+ am_chi = window_chi(2)
+
+ endif
+
+ end subroutine mt_adj
+
+ !==============================================================================
+ !==============================================================================
+
+ !----------------------------------------------------------------------
+
+ subroutine bandpass(x,n,delta_t,f1,f2)
+ ! modified from FLEXWIN subroutines on 26-July-2009
+
+ implicit none
+ integer, intent(in) :: n
+ double precision, intent(inout), dimension(*) :: x
+ double precision, intent(in) :: delta_t,f1,f2
+ real, dimension(:), allocatable :: x_sngl
+
+ allocate(x_sngl(n))
+
+ x_sngl(1:n) = sngl(x(1:n))
+ ! delta_t_sngl = sngl(delta_t)
+
+ ! old version - uses old SacLib
+ ! does band-pass filter
+ !call xapiir(x_sngl,n,'BU',sngl(TRBDNDW),sngl(APARM),IORD,'BP',sngl(FSTART),sngl(FEND),delta_t_sngl,PASSES)
+
+ ! new version, uses subroutines in libsac.a
+ ! does band-pass filter
+ ! BU - butterworth
+ ! BP - bandpass
+ call xapiir(x_sngl,n,'BU',TRBDNDW,APARM,IORD,'BP',f1,f2,delta_t,PASSES)
+
+ x(1:n) = dble(x_sngl(1:n))
+
+ deallocate(x_sngl)
+
+ end subroutine bandpass
+
+ !-----------------------------------------------------------------------------
+
+ subroutine drsac1(datafile,data,npt1,b1,dt1)
+ ! read sac file and convert to double precision
+
+ implicit none
+ character(len=*),intent(in) :: datafile
+ real, dimension(NDIM) :: dat_sngl
+ double precision, dimension(NDIM), intent(out) :: data
+ integer :: npt1, nerr
+ real :: b1_sngl,dt1_sngl
+ double precision :: b1,dt1
+
+ ! read file as single precision
+ call rsac1(datafile,dat_sngl,npt1,b1_sngl,dt1_sngl,NDIM,nerr)
+ if (nerr > 0) then
+ print *, 'Error reading sac file', trim(datafile)
+ stop
+ endif
+
+ ! return double precision quantities
+ b1 = dble(b1_sngl)
+ dt1 = dble(dt1_sngl)
+ data = dble(dat_sngl)
+
+ end subroutine drsac1
+
+ !-----------------------------------------------------------------------------
+
+ subroutine dwsac1(datafile,data,npt1,b1,dt1)
+ ! convert to single precision, then write sac file
+ ! --> includes an option to add minmax values to sac file,
+ ! which are used in the plotting scripts
+
+ implicit none
+ character(len=*),intent(in) :: datafile
+ integer, intent(in) :: npt1
+ double precision, dimension(npt1), intent(in) :: data
+ double precision, intent(in) :: b1,dt1
+ logical, parameter :: minmax_header = .true.
+
+ real, dimension(npt1) :: dat_sngl,ti_sngl
+ real :: b1_sngl,dt1_sngl,xmin_sngl,xmax_sngl
+ integer :: nerr,i
+
+ ! convert to single precision
+ b1_sngl = real(b1)
+ dt1_sngl = real(dt1)
+ dat_sngl = real(data)
+
+ if (minmax_header) then
+ ! get time vector
+ ti_sngl = 0.
+ do i = 1,npt1
+ ti_sngl(i) = b1_sngl + (i-1)*dt1_sngl
+ enddo
+
+ !call newhdr() ! create a new header
+
+ ! set minmax values in sac file
+ xmin_sngl = minval(dat_sngl)
+ xmax_sngl = maxval(dat_sngl)
+ call setfhv('depmin',xmin_sngl,nerr)
+ call setfhv('depmax',xmax_sngl,nerr)
+
+ call setnhv('npts',npt1,nerr) ! sets number of points
+ !call setfhv('b',ti_sngl(1),nerr) ! sets begin
+ !call setfhv('e',ti_sngl(npt1),nerr) ! sets end
+ !call setlhv('leven',.false.,nerr) ! sets un-even sampling
+ !call setihv('iftype','itime',nerr) ! sets file type: time file
+
+ ! write file with headers
+ call wsac0(datafile,ti_sngl,dat_sngl,nerr)
+
+ else
+ call wsac1(datafile,dat_sngl,npt1,b1_sngl,dt1_sngl,nerr)
+ endif
+ if (nerr > 0) then
+ print *, 'Error writing sac file', trim(datafile)
+ stop
+ endif
+
+ end subroutine dwsac1
+
+ !-----------------------------------------------------------------------------
+
+ subroutine cc_measure_select(tshift,dlnA,cc_max)
+
+ ! CHT: If the CC timeshift is for some reason larger than the allowable max,
+ ! then effectively eliminate the window by zeroing the
+ ! cross-correlation traveltime and amplitude measurements.
+ ! See subroutine compute_cc in mt_sub.f90.
+
+ implicit none
+ double precision, intent(inout) :: tshift, dlnA, cc_max
+
+ if( (cc_max < CC_MIN) .or. (tshift < TSHIFT_MIN) .or. (tshift > TSHIFT_MAX) &
+ .or. (dlnA < DLNA_MIN) .or. (dlnA > DLNA_MAX) ) then
+ ! zero the CC measurments
+ if (DISPLAY_DETAILS) then
+ print *, 'Fail if ANY of these is true :'
+ print *, ' cc_max : ', cc_max, CC_MIN, cc_max < CC_MIN
+ print *, ' tshift : ', tshift, TSHIFT_MIN, tshift < TSHIFT_MIN
+ print *, ' tshift : ', tshift, TSHIFT_MAX, tshift > TSHIFT_MAX
+ print *, ' dlnA : ', dlnA, DLNA_MIN, dlnA < DLNA_MIN
+ print *, ' dlnA : ', dlnA, DLNA_MAX, dlnA > DLNA_MAX
+ endif
+
+ ! zero the CC measurments
+ tshift = 0.0
+ dlnA = 0.0
+ endif
+
+ end subroutine cc_measure_select
+
+ !-----------------------------------------------------------------------------
+
+ subroutine mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, &
+ dt,i_left,i_right,fstart,fend,use_trace)
+
+ ! an important subroutine to determine whether an MT measurement should be rejected,
+ ! in which case a CC measurement is used -- several choices are made here
+
+ implicit none
+ integer, intent(in) :: nlen, i_pmax_syn
+ double precision, intent(in) :: tshift, dt
+ double precision, dimension(:), intent(inout) :: dtau_w, err_dt
+ double precision, intent(inout) :: fstart, fend
+ integer,intent(inout) :: i_left, i_right
+ logical,intent(out) :: use_trace
+
+ double precision :: df, fvec(NPT), f_pmax, T_pmax, Wlen
+ integer :: i_right_old, i_left_old
+ integer :: j,ntaper
+ !logical :: stop_freq
+
+ use_trace = .true.
+ df = 1./(dt*NPT)
+ f_pmax = df * i_pmax_syn
+ T_pmax = 1./ f_pmax
+ Wlen = dt*nlen
+
+ if( NCYCLE_IN_WINDOW * T_pmax > Wlen ) then
+ print *, 'rejecting trace for too few cycles within time window:'
+ print *, ' T_pmax : ', T_pmax
+ print *, ' Wlen : ', Wlen
+ print *, ' NCYCLE_IN_WINDOW : ', NCYCLE_IN_WINDOW
+ print *, ' REJECTION: ', NCYCLE_IN_WINDOW*T_pmax, Wlen, NCYCLE_IN_WINDOW * T_pmax < Wlen
+ use_trace = .false.
+ endif
+
+ !write(*,'(a8,4f12.6)') 'fstart :', fstart, NCYCLE_IN_WINDOW/(Wlen), NCYCLE_IN_WINDOW, Wlen
+ !write(*,'(a8,4f12.6)') 'fend :', fend, 1./(2.0*dt), dt
+
+ ! DECREASE the frequency range of the measurement (and adjoint source)
+ ! --> note NCYCLE_IN_WINDOW and window length
+ ! We subjectively state that we want at least 10 frequency points for the multitaper measurement.
+ fstart = max(fstart, NCYCLE_IN_WINDOW/Wlen)
+ fend = min(fend, 1./(2.0*dt))
+
+ ! number of tapers (slepian tapers, type = 1)
+ ntaper = int(NPI * 2.0)
+ if( ntaper > 10 ) ntaper = 10
+ if( ntaper < 1 ) ntaper = 10
+ if( use_trace .and. fstart >= fend - ntaper*df ) then
+ print *, 'rejecting trace for frequency range (NCYCLE_IN_WINDOW/Wlen):'
+ print *, ' fstart, fend, df, ntaper : ', fstart,fend,df,ntaper
+ print *, ' NCYCLE_IN_WINDOW, Wlen : ', NCYCLE_IN_WINDOW,Wlen,NCYCLE_IN_WINDOW/Wlen
+ print *, ' REJECTION fstart >= fend - ntaper*df : ', fstart, fend - ntaper*df, fstart >= fend - ntaper*df
+ use_trace = .false.
+ !stop 'testing rejection criteria'
+ endif
+
+ ! assemble frequency vector (NPT is the FFT length)
+ fvec(:) = 0.
+ do j = 1,NPT
+ if(j > NPT/2+1) then
+ fvec(j) = df*(j-NPT-1) ! negative frequencies in second half
+ else
+ fvec(j) = df*(j-1) ! positive frequencies in first half
+ endif
+ enddo
+
+!!$ stop_freq = .false.
+!!$ do j = 1, i_right
+!!$ if (stop_freq) exit
+!!$ print *, j, dtau_w(j),stop_freq
+!!$ if (abs(dtau_w(j)) > 3 * abs(tshift)) then
+!!$ dtau_w(j) = 0
+!!$ else if (j /= 1) then
+!!$ stop_freq = .true.
+!!$ endif
+!!$ enddo
+
+ ! determine the indices that denote the new frequency range (CHT)
+ ! IT SEEMS LIKE THERE SHOULD BE NO NEED FOR THIS, SINCE THE SIGNAL HAS ALREADY
+ ! BEEN BAND-PASSED PRIOR TO MAKING THE MULTITAPER MEASUREMENT.
+ if (1==1) then
+ i_left_old = i_left
+ i_right_old = i_right
+ do j = i_left_old, i_right_old
+ if (fvec(j) > fstart) then
+ i_left = j-1
+ exit
+ endif
+ enddo
+ do j = i_left_old, i_right_old
+ if (fvec(j) > fend) then
+ i_right = j-1
+ exit
+ endif
+ enddo
+ if (DISPLAY_DETAILS) then
+ write(*,'(a24,2i6,2f14.8)') 'Old frequency bounds :', i_left_old, i_right_old, df*i_left_old, df*i_right_old
+ write(*,'(a24,2i6,2f14.8)') 'New frequency bounds :', i_left, i_right, df*i_left, df*i_right
+ endif
+ endif
+
+ ! update the frequency limits
+ fstart = (i_left-1)*df
+ fend = (i_right-1)*df
+
+ ! if the cross-correlation time-shift is <= a time-step, set dtau(w) to zero
+ ! NOTE: this should probably be a user parameter
+ if ( abs(tshift) <= 1.01*dt ) then
+ dtau_w(:) = 0.
+ use_trace = .false.
+ if (DISPLAY_DETAILS) then
+ print *, 'rejecting trace for too small a time shift:'
+ print *, ' dt = ', dt
+ print *, ' tshift = ', tshift
+ endif
+ endif
+
+ ! within the frequency range of interest, check various criteria
+ ! CHT: dtau_w(j) --> abs(dtau_w(j)) for the first criterion
+ do j = i_left, i_right
+ if (use_trace .and. (abs(dtau_w(j)) > 1./(DT_FAC*fvec(j)) .or. err_dt(j) > 1./(ERR_FAC*fvec(j)) &
+ .or. abs(dtau_w(j)) > DT_MAX_SCALE*abs(tshift))) then
+ use_trace = .false.
+ if (DISPLAY_DETAILS) then
+ print *, 'rejecting trace (T leads to rejection):'
+ print *, ' f = ', fvec(j), j
+ print *, 'DT_FAC (lower) : ', abs(dtau_w(j)), 1./(DT_FAC * fvec(j)), abs(dtau_w(j)) > 1./(DT_FAC * fvec(j))
+ print *, 'ERR_FAC (lower) : ', err_dt(j), 1./(ERR_FAC * fvec(j)), err_dt(j) > 1./(ERR_FAC * fvec(j))
+ print *, 'DT_MAX_SCALE (lower) : ', abs(dtau_w(j)), DT_MAX_SCALE*abs(tshift), &
+ abs(dtau_w(j)) > DT_MAX_SCALE*abs(tshift)
+ !stop 'testing MT trace rejection'
+ endif
+ endif
+ enddo
+
+ end subroutine mt_measure_select
+
+ !==============================================================================
+ ! subroutines used in mtm_measure() and mtm_adj()
+ !==============================================================================
+
+ subroutine interpolate_dat_and_syn(data, syn, tstart, tend, t0, dt, NPT, dat_win, syn_win, nlen, istart)
+
+ implicit none
+ double precision, dimension(NPT), intent(in) :: data, syn
+ double precision, dimension(NPT), intent(out) :: dat_win, syn_win
+ double precision, intent(in) :: tstart, tend, t0, dt
+ integer, intent(in) :: NPT
+ integer, intent(out) :: nlen, istart
+
+ integer :: ii, i
+ double precision :: time, t1
+
+ nlen = floor((tend-tstart)/dt) + 1
+ istart = floor((tstart-t0)/dt)
+
+ ! limits array bounds
+ if( nlen > NPT ) nlen = NPT
+
+ do i = 1, nlen
+ time = tstart + (i-1) * dt
+ ii = floor((time-t0)/dt) + 1
+
+ ! checks out-of-bounds
+ if( ii >= NPT ) cycle
+
+ t1 = floor((time-t0)/dt) * dt + t0
+
+ dat_win(i) = data(ii) + (data(ii+1)-data(ii)) * (time-t1) / dt ! data
+ syn_win(i) = syn(ii) + (syn(ii+1)-syn(ii)) * (time-t1) /dt ! syn
+
+ enddo
+
+ end subroutine interpolate_dat_and_syn
+
+ !-----------------------------------------------------------------------------
+
+ subroutine compute_cc(syn, data, nlen, dt, ishift, tshift, dlnA, cc_max)
+
+ ! time shift MEASUREMENT between data (data) and synthetics (syn)
+ ! CHT: modified the subroutine to resemble the one used in FLEXWIN
+
+ implicit none
+ double precision, dimension(*), intent(in) :: syn, data
+ integer, intent(in) :: nlen
+ double precision, intent(in) :: dt
+ double precision, intent(out) :: tshift, dlnA, cc_max
+ integer, intent(out) :: ishift
+
+ double precision :: cc, norm_s, norm ! cr_shift
+ integer i1, i2, i, j, i_left, i_right, id_left, id_right
+
+!!$ ! these choices will slide the entire windowed record past the other
+!!$ cr_shift = nlen*dt
+!!$ i_left = ceiling( -1.0 * cr_shift / dt )
+!!$ i_right = floor( cr_shift / dt )
+!!$
+!!$ ! cross-correlation
+!!$ ishift = 0
+!!$ do i = i_left, i_right, 1
+!!$
+!!$ cc = 0.
+!!$ do j = 1, nlen
+!!$ if((j+i) > 1 .and. (j+i) < nlen) cc = cc + syn(j) * data(j+i)
+!!$ enddo
+!!$
+!!$ !if(cc > cc_max) then
+!!$ ! CHT, 07-Sept-2008: Do not allow time shifts larger than the specified input
+!!$ if(cc > cc_max .and. abs(i*dt) <= BEFORE_TSHIFT ) then
+!!$ cc_max = cc
+!!$ ishift = i
+!!$ endif
+!!$
+!!$ enddo
+!!$ tshift = ishift*dt
+
+ ! initialise shift and cross correlation to zero
+ ishift = 0
+ cc_max = 0.0
+
+ ! index of window limits
+ i1 = 1
+ i2 = nlen
+
+ ! length of window (number of points, including ends)
+ !nlen = i2 - i1 + 1
+
+ ! power of synthetic signal in window
+ norm_s = sqrt(sum(syn(i1:i2)*syn(i1:i2)))
+
+ ! left and right limits of index (time) shift search
+ ! NOTE: This looks OUTSIDE the time window of interest to compute TSHIFT and CC.
+ ! How far to look outside, in theory, should be another parameter.
+ ! However, it does not matter as much if the data and synthetics are
+ ! zeroed outside the windows.
+ i_left = -1*int(nlen/2.0)
+ i_right = int(nlen/2.0)
+
+ ! i is the index to shift to be applied to DATA (data)
+ do i = i_left, i_right
+
+ ! normalization factor varies as you take different windows of data
+ id_left = max(1,i1+i) ! left index for data window
+ id_right = min(nlen,i2+i) ! right index for data window
+ norm = norm_s * sqrt(sum(data(id_left:id_right)*(data(id_left:id_right))))
+
+ ! cc as a function of i
+ cc = 0.
+ do j = i1, i2 ! loop over full window length
+ if((j+i).ge.1 .and. (j+i).le.nlen) cc = cc + syn(j)*data(j+i) ! d is shifted by i
+ enddo
+ cc = cc/norm
+
+ if (cc > cc_max) then
+ ! CHT: do not allow time shifts larger than the specified input range
+ ! This is an important criterion, since it may pick TSHIFT_MIN or TSHIFT_MAX
+ ! if cc_max within the interval occurs on the boundary.
+ if( (i*dt >= TSHIFT_MIN).and.(i*dt <= TSHIFT_MAX) ) then
+ cc_max = cc
+ ishift = i
+ endif
+ endif
+
+ enddo
+ tshift = ishift*dt
+
+ ! The previously used expression for dlnA of Dahlen and Baig (2002),
+ ! is a first-order perturbation of ln(A1/A2) = (A1-A2)/A2 .
+ ! The new expression is better suited to getting Gaussian-distributed
+ ! values between -1 and 1, with dlnA = 0 indicating perfect fit, as before.
+ dlnA = 0.5 * log( sum(data(i1:i2) * data(i1:i2)) / sum(syn(i1:i2) * syn(i1:i2)) )
+
+ end subroutine compute_cc
+
+ ! ---------------------------------------------------------------------------
+
+ subroutine compute_average_error(data_dtw,syn_dtw_cc,syn_dtw_cc_dt,nlen,dt,sigma_dt,sigma_dlnA)
+
+ ! CHT: Estimate the uncertainty in the CC measurement
+ ! based on the integrated waveform difference between the data
+ ! and the reconstructed synthetics.
+ ! NOTE: We implement the exact equations that are in the Latex notes.
+
+ implicit none
+ double precision, dimension(*), intent(in) :: data_dtw, syn_dtw_cc, syn_dtw_cc_dt
+ integer, intent(in) :: nlen
+ double precision, intent(in) :: dt
+ double precision, intent(inout) :: sigma_dt, sigma_dlnA
+
+ double precision, dimension(nlen) :: syn_vtw_cc
+ double precision :: sigma_dt_top, sigma_dlnA_top, sigma_dt_bot, sigma_dlnA_bot
+ integer i
+
+ ! compute synthetic velocity (shifted and stretched)
+ do i = 2, nlen-1
+ syn_vtw_cc(i) = (syn_dtw_cc(i+1) - syn_dtw_cc(i-1)) / (2.0*dt)
+ enddo
+ syn_vtw_cc(1) = (syn_dtw_cc(2) - syn_dtw_cc(1)) / dt
+ syn_vtw_cc(nlen) = (syn_dtw_cc(nlen) - syn_dtw_cc(nlen-1)) / dt
+
+ ! estimated uncertainty in cross-correlation travltime and amplitude
+ sigma_dt_top = sum( (data_dtw(1:nlen) - syn_dtw_cc(1:nlen) )**2 )
+ sigma_dlnA_top = sigma_dt_top
+ sigma_dt_bot = sum( syn_vtw_cc(1:nlen)**2 )
+ sigma_dlnA_bot = sum( (syn_dtw_cc_dt(1:nlen))**2 )
+ sigma_dt = sqrt( sigma_dt_top / sigma_dt_bot )
+ sigma_dlnA = sqrt( sigma_dlnA_top / sigma_dlnA_bot )
+
+ if(0==1) then
+ print *, ' sigma_dt : ', sigma_dt
+ print *, ' sigma_dlnA : ', sigma_dlnA
+ open(88,file='tshift.dat')
+ do i = 1,nlen
+ write(88,'(5e18.6)') (i-1)*dt, data_dtw(i), syn_dtw_cc(i), syn_dtw_cc_dt(i), syn_vtw_cc(i)
+ enddo
+ close(88)
+ stop 'testing'
+ endif
+
+ ! make final adjustments to uncertainty estimate
+ if (ERROR_TYPE == 0) then
+ ! set uncertainty factors to 1 if you do not want to incorporate them
+ ! into the adjoint sources and the misfit function values
+ sigma_dt = 1.0
+ sigma_dlnA = 1.0
+
+ else
+ ! make sure that the uncertainty estimates are not below the water level;
+ ! otherwise, the adjoint sources will blow up unreasonably
+ if( sigma_dt < DT_SIGMA_MIN) sigma_dt = DT_SIGMA_MIN
+ if( sigma_dlnA < DLNA_SIGMA_MIN) sigma_dlnA = DLNA_SIGMA_MIN
+
+ endif
+
+ end subroutine compute_average_error
+
+ ! ---------------------------------------------------------------------------
+
+ subroutine write_average_meas(filename, imeas, dtau_meas, dlnA_meas, dtau_sigma, dlnA_sigma)
+
+ implicit none
+ character(len=*), intent(in) :: filename
+ double precision, intent(in) :: dtau_meas, dlnA_meas, dtau_sigma, dlnA_sigma
+ integer, intent(in) :: imeas
+ character(len=40) :: stlab, suffix
+
+ if ( imeas == 7 .or. imeas == 8 ) then
+ stlab = 'Multitaper' ; suffix = 'average'
+ else
+ stlab = 'Cross-correlation' ; suffix = 'cc'
+ endif
+
+ if ( imeas .ge. 3 ) then
+ if (DISPLAY_DETAILS) then
+ print *, trim(stlab)//' average measurements:'
+ print *, ' traveltime :', sngl(dtau_meas), ' +/- ', sngl(dtau_sigma)
+ print *, ' amplitude :', sngl(dlnA_meas), ' +/- ', sngl(dlnA_sigma)
+ endif
+
+ ! write average error estimates to file
+ if (OUTPUT_MEASUREMENT_FILES) then
+ open(71,file=trim(filename)//'.dt_'//trim(suffix))
+ write(71,*) dtau_meas, dtau_sigma
+ close(71)
+ open(72,file=trim(filename)//'.dlnA_'//trim(suffix))
+ write(72,*) dlnA_meas, dlnA_sigma
+ close(72)
+ endif
+ endif
+
+ end subroutine write_average_meas
+
+ ! ---------------------------------------------------------------------------
+
+ subroutine write_trans(filename, trans, wvec, fnum, i_right, idf_new, df, tshift, dlnA, &
+ phi_wt, abs_wt, dtau_wt, dlnA_wt, dtau_wa, dlnA_wa)
+
+ ! The transfer function maps the synthetics to the CC-deconstructed data;
+ ! the CC measurements then need to be applied to match the original data.
+
+ implicit none
+ character(len=*), intent(in) :: filename
+ complex*16, intent(in) :: trans(:)
+ double precision, intent(in) :: wvec(:), df, tshift, dlnA
+ integer, intent(in) :: fnum, i_right, idf_new
+ double precision, dimension(:), intent(out) :: phi_wt, abs_wt, dtau_wt, dlnA_wt
+ double precision, intent(out), optional :: dtau_wa, dlnA_wa
+
+ integer :: i, j
+ double precision, dimension(NPT) :: fr
+ double precision :: smth, smth1, smth2 ! f0
+
+ abs_wt(:) = 0.
+ phi_wt(:) = 0.
+
+ ! note that with the idf_new value, these files are SUB-SAMPLED
+ if (OUTPUT_MEASUREMENT_FILES) then
+ open(10,file=trim(filename)//'.ph')
+ open(20,file=trim(filename)//'.abs')
+ open(30,file=trim(filename)//'.dlnA')
+ open(40,file=trim(filename)//'.ph_cor')
+ open(50,file=trim(filename)//'.dt')
+ endif
+
+ ! loop to calculate phase and amplitude
+ do i = 1, i_right
+ phi_wt(i) = atan2( aimag(trans(i)) , real(trans(i)) )
+ abs_wt(i) = abs(trans(i))
+ fr(i) = df*(i-1)
+ if (mod(i,idf_new).eq.0 .and. OUTPUT_MEASUREMENT_FILES) then
+ write(10,*) fr(i), phi_wt(i)
+ write(20,*) fr(i), abs_wt(i)
+ write(30,*) fr(i), log(abs_wt(i))
+ endif
+ enddo
+
+ ! NOTE: the CC measurements dT (tshift) and dlnA are BOTH included
+ dtau_wt(1) = tshift
+ do i = 1, i_right
+
+ if (i > 1 .and. i < i_right) then
+ ! check the smoothness (2nd-order derivative) by 2*pi changes
+ smth = phi_wt(i+1) + phi_wt(i-1) - 2.0 * phi_wt(i)
+ smth1 = (phi_wt(i+1) + TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i)
+ smth2 = (phi_wt(i+1) - TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i)
+ if(abs(smth1).lt.abs(smth).and.abs(smth1).lt.abs(smth2).and. abs(phi_wt(i) - phi_wt(i+1)) > PHASE_STEP)then
+ if (DISPLAY_DETAILS) print *, 'phase correction : 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1))
+ do j = i+1, i_right
+ phi_wt(j) = phi_wt(j) + TWOPI
+ enddo
+ endif
+ if(abs(smth2).lt.abs(smth).and.abs(smth2).lt.abs(smth1).and. abs(phi_wt(i) - phi_wt(i+1)) > PHASE_STEP)then
+ if (DISPLAY_DETAILS) print *, 'phase correction : - 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1))
+ do j = i+1, i_right
+ phi_wt(j) = phi_wt(j) - TWOPI
+ enddo
+ endif
+ endif
+
+ ! add the CC measurements to the transfer function
+ if (i > 1) dtau_wt(i) = (-1./wvec(i)) * phi_wt(i) + tshift
+ dlnA_wt(i) = log(abs_wt(i)) + dlnA
+ !dlnA_wt(i) = log(abs_wt(i))
+ !!dlnA_wt(i) = abs_wt(i) - 1.
+
+ if(mod(i,idf_new).eq.0 .and. OUTPUT_MEASUREMENT_FILES) then
+ write(40,*) fr(i), phi_wt(i)
+ write(50,*) fr(i), dtau_wt(i)
+ endif
+
+ enddo
+
+ if (OUTPUT_MEASUREMENT_FILES) then
+ close(10)
+ close(20)
+ close(30)
+ close(40)
+ close(50)
+ endif
+
+ ! average values of the transfer functions (optional output argument)
+ if (present(dtau_wa) .and. present(dlnA_wa)) then
+ dtau_wa = sum( dtau_wt(1:i_right) ) / i_right
+ dlnA_wa = sum( dlnA_wt(1:i_right) ) / i_right
+ endif
+
+!!$ if (DISPLAY_DETAILS) then
+!!$ print *, ' Taper traveltime measurement average : ', sngl(dtau_wa)
+!!$ print *, ' Taper amplitude measurement average : ', sngl(dlnA_wa)
+!!$ print *, ' i_right : ', i_right
+!!$ !f0 = 0.
+!!$ !call dwrite_ascfile_f(trim(filename)//'.dt_full',f0,df,i_right,dtau_wt(1:i_right))
+!!$ !call dwrite_ascfile_f(trim(filename)//'.dlnA_full',f0,df,i_right,dlnA_wt(1:i_right))
+!!$ !call dwrite_ascfile_f(trim(filename)//'.transfer_full',f0,df,i_right,abs(trans(1:i_right)))
+!!$ endif
+
+ end subroutine write_trans
+
+ ! --------------------------------------------------------------------
+
+ subroutine deconstruct_dat_cc(filename,dat_dtw,tstart,dt,nlen,&
+ ishift,tshift,dlnA,dat_dtw_cc)
+
+ ! Using CC measurements, map the data to the synthetics;
+ ! because the windows are picked based on the synthetics,
+ ! we apply the transfer function from the synthetics to the
+ ! CC-deconstructed data.
+ implicit none
+ character(len=*), intent(in) :: filename
+ double precision, dimension(NPT), intent(in) :: dat_dtw
+ integer, intent(in) :: ishift, nlen
+ double precision, intent(in) :: tshift, dlnA, tstart, dt
+ double precision, dimension(NPT), intent(out) :: dat_dtw_cc
+ integer i
+
+ ! apply time shift (-dT) to OBSERVED seismogram
+ dat_dtw_cc(:) = dat_dtw(:)
+ do i = 1, nlen
+ if ((ishift+i) > 1 .and. (ishift+i) < nlen ) dat_dtw_cc(i) = dat_dtw(i+ishift)
+ enddo
+ ! fill the missing time window with the endpoint value
+ if (ishift < 0) dat_dtw_cc(1:-ishift+1) = dat_dtw_cc(-ishift+2)
+ if (ishift > 0) dat_dtw_cc(nlen-ishift:nlen) = dat_dtw_cc(nlen-ishift-1)
+
+ ! apply cross-correlation amplitude measurement (-DlnA) to OBSERVED seismogram
+ dat_dtw_cc(:) = dat_dtw_cc(:) * exp( -dlnA )
+
+ !if (DISPLAY_DETAILS) then
+ ! call dwrite_sacfile_f(datafile,'windowed_shifted_data.sac',tstart,nlen,dat_dtw0)
+ !endif
+
+ end subroutine deconstruct_dat_cc
+
+ ! --------------------------------------------------------------------
+
+ subroutine reconstruct_syn_cc(syn_dtw,tstart,dt,nlen,ishift,tshift,dlnA,syn_dtw_cc,syn_dtw_cc_dt)
+
+ ! reconstruct the synthetics using cross-correlation measurements:
+ ! (1) apply dT to get syn_dtw_cc_dt
+ ! (2) apply dT and dlnA to get syn_dtw_cc
+ implicit none
+ double precision, dimension(NPT), intent(in) :: syn_dtw
+ integer, intent(in) :: ishift, nlen
+ double precision, intent(in) :: tshift, dlnA, tstart, dt
+ double precision, dimension(NPT), intent(out) :: syn_dtw_cc, syn_dtw_cc_dt
+ integer i
+
+ ! shift synthetics by tshift (in the main program, we shift the data instead)
+ ! ishift = tshift * dt
+ syn_dtw_cc_dt(:) = syn_dtw(:)
+ do i = 1, nlen
+ if ((i-ishift) > 1 .and. (i-ishift) < nlen ) syn_dtw_cc_dt(i) = syn_dtw(i-ishift)
+ enddo
+ ! fill the missing time window with the endpoint value
+ if (ishift > 0) syn_dtw_cc_dt(1:ishift+1) = syn_dtw_cc_dt(ishift+2)
+ if (ishift < 0) syn_dtw_cc_dt(nlen+ishift:nlen) = syn_dtw_cc_dt(nlen+ishift-1)
+
+ ! apply cross-correlation amplitude measurement
+ syn_dtw_cc(:) = 0.
+ syn_dtw_cc(:) = syn_dtw_cc_dt * exp( dlnA ) ! based on dlnA = ln(Aobs/Asyn)
+ !syn_dtw_cc(:) = syn_dtw_cc_dt * (1. + dlnA) ! based on first-order approximation of dlnA
+
+ end subroutine reconstruct_syn_cc
+
+ ! -----------------------------------------------------------------------
+
+ subroutine reconstruct_syn(filename, syn_dtwo, wvec, dtau_wt, dlnA_wt, &
+ i_right, tstart, dt, nlen, syn_dtw_mt, syn_dtw_mt_dt)
+
+ ! reconstruct the synthetics using multitaper measurements:
+ ! (1) apply dtau(w) and dlnA(w) to get syn_dtw_mt0
+ implicit none
+ character(len=*), intent(in) :: filename
+ complex*16, dimension(:), intent(in) :: syn_dtwo
+ double precision, dimension(:), intent(in) :: wvec, dtau_wt, dlnA_wt
+ integer, intent(in) :: i_right, nlen
+ double precision, intent(in) :: tstart, dt
+ double precision, dimension(:), intent(out) :: syn_dtw_mt, syn_dtw_mt_dt
+
+ complex*16, dimension(NPT) :: wseis_recon
+ integer i
+ double precision omega
+
+ ! apply transfer function to synthetics (phase and amplitude)
+ syn_dtw_mt(:) = 0.
+ wseis_recon(:) = cmplx(0.,0.)
+ do i = 1,i_right
+ omega = wvec(i)
+ wseis_recon(i) = syn_dtwo(i) * exp(dlnA_wt(i)) * exp(-CCI*omega*dtau_wt(i))
+ !wseis_recon(i) = syn_dtwo(i) * (1.+ dlnA_wt(i)) * exp(-CCI*omega*dtau_wt(i))
+ !wseis_recon(i) = syn_dtwo(i) * trans_mtm(i) * exp(-CCI*omega*tshift)
+ enddo
+ call fftinv(LNPT,wseis_recon,REVERSE_FFT,dt,syn_dtw_mt)
+
+ ! apply phase shifts only
+ syn_dtw_mt_dt(:) = 0.
+ wseis_recon(:) = cmplx(0.,0.)
+ do i = 1,i_right
+ omega = wvec(i)
+ wseis_recon(i) = syn_dtwo(i) * exp(-CCI*omega*dtau_wt(i))
+ enddo
+ call fftinv(LNPT,wseis_recon,REVERSE_FFT,dt,syn_dtw_mt_dt)
+
+ if (OUTPUT_MEASUREMENT_FILES) then
+ call dwsac1(trim(filename)//'.recon_syn.sac',syn_dtw_mt,nlen,tstart,dt)
+ call dwsac1(trim(filename)//'.recon_syn_dt.sac',syn_dtw_mt_dt,nlen,tstart,dt)
+!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn.sac',tstart,nlen,syn_dtw_mt)
+!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_dt.sac',tstart,nlen,syn_dtw_mt_dt)
+!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn',tstart,dt,nlen,syn_dtw_mt)
+!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn_dt',tstart,dt,nlen,syn_dtw_mt_dt)
+ endif
+
+ end subroutine reconstruct_syn
+
+ ! -----------------------------------------------------------------------
+
+!!$ subroutine check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift,tshift_f1f2,cc_max_f1f2,cc_max)
+!!$
+!!$ character(len=*), intent(in) :: filename
+!!$ double precision, dimension(:), intent(in) :: dat_dtw_cc, syn_dtw, dat_dtw, syn_dtw_mt
+!!$ double precision, intent(in) :: dt, tshift
+!!$ integer, intent(in) :: nlen
+!!$ double precision, intent(out) :: tshift_f1f2, cc_max_f1f2, cc_max
+!!$
+!!$ double precision :: f1,f2, dlnA_f1f2
+!!$
+!!$ ! Using Alessia's subroutine
+!!$ ! First the shifted_obs_win vs the synthetic
+!!$ call f1f2_calc(dat_dtw_cc,syn_dtw,nlen,1,nlen,dt, f1,f2,tshift_f1f2,cc_max_f1f2,dlnA_f1f2)
+!!$
+!!$ cc_max = cc_max_f1f2
+!!$ if (OUTPUT_MEASUREMENT_FILES) then
+!!$ open(10,file=trim(filename)//'.quality')
+!!$ write(10,*) '<--------- F1 ------ F2 ---- tshift -- cc_max --- dlnA -->'
+!!$ write(10,"(a,5F10.5)") 'Before',sngl(F1),sngl(F2),sngl(tshift),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
+!!$ endif
+!!$ if (DISPLAY_DETAILS) then
+!!$ write(*,*) '<--------- F1 ------ F2 ---- tshift -- cc_max --- dlnA -->'
+!!$ write(*,"(a,5F10.5)") 'Before',sngl(F1),sngl(F2),sngl(tshift),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
+!!$ endif
+!!$
+!!$ ! Then the obs_win vs the reconstructed obs
+!!$ call f1f2_calc(dat_dtw,syn_dtw_mt,nlen,1,nlen,dt, f1,f2,tshift_f1f2,cc_max_f1f2,dlnA_f1f2)
+!!$
+!!$ if (OUTPUT_MEASUREMENT_FILES) then
+!!$ write(10,"(a,5F10.5)") 'After ',sngl(F1),sngl(F2),sngl(tshift_f1f2),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
+!!$ close(10)
+!!$ endif
+!!$
+!!$ if (DISPLAY_DETAILS) write(*,"(a,5F10.5)") 'After ',sngl(F1),sngl(F2),sngl(tshift_f1f2),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
+!!$
+!!$ end subroutine check_recon_quality
+
+!-------------------------------------------------------------------
+
+ subroutine interpolate_syn(syn,t1,dt1,npt1,t2,dt2,npt2)
+
+ implicit none
+ double precision, dimension(:),intent(inout) :: syn
+ integer,intent(in) :: npt1,npt2
+ double precision,intent(in) :: t1,dt1,t2,dt2
+
+ double precision :: syn1(NDIM), time, tt
+ integer i, ii
+
+ ! initializes trace holding interpolated values
+ syn1(1:npt2) = 0.
+
+ ! loops over number of time steps in complete trace
+ do i = 1, npt2
+
+ ! sets time (in s) at this time step:
+ ! t2 : start time of trace
+ ! dt2: delta_t of a single time step
+ time = t2 + (i-1) * dt2
+
+ ! checks if time is within measurement window
+ ! t1: start time of measurement window
+ ! npt1: number of time steps in measurement window
+ ! dt1: delta_t of a single time step in measurement window
+ if (time > t1 .and. time < t1 + (npt1-1)*dt1) then
+
+ ! sets index of time steps within this window: is 1 at the beginning of window
+ ii = floor((time-t1)/dt1) + 1
+
+ ! time increment within this single time step to match the exact value of time
+ tt = time - ((ii-1)*dt1 + t1)
+
+ ! interpolates value of trace for the exact time
+ syn1(i) = (syn(ii+1)-syn(ii)) * tt/dt1 + syn(ii)
+ endif
+ enddo
+
+ ! saves interpolated values to output trace
+ syn(1:npt2) = syn1(1:npt2)
+
+ end subroutine interpolate_syn
+
+!-------------------------------------------------------------------
+
+ subroutine taper_start(syn,npt,itmax)
+
+ implicit none
+ double precision, dimension(:),intent(inout) :: syn
+ integer,intent(in) :: npt, itmax
+ double precision :: Wt
+ integer :: i !,imax
+
+ !imax = maxloc(abs(syn),dim=1) ! index of the max value
+ !Wt = TWOPI / (2.0*(imax-1)) ! period of the taper
+ Wt = TWOPI / (2.0*(itmax-1)) ! period of the taper
+
+ if(DISPLAY_DETAILS) print *, 'tapering start of record from index 1 to index ', itmax
+
+ ! apply a cosine taper from the start to the max value,
+ ! such that the starting point is exactly zero
+ do i = 1, itmax
+ syn(i) = syn(i) * ( 0.5*(1 - cos(Wt*(i-1))) )
+ enddo
+
+ end subroutine taper_start
+
+!-------------------------------------------------------------------
+
+
+ subroutine read_par_file(fstart0,fend0,tt,dtt,nn,chan)
+
+ implicit none
+ double precision, intent(out) :: fstart0,fend0,tt,dtt
+ integer, intent(out) :: nn
+ character(len=10), intent(out) :: chan
+ integer :: ios
+
+ ! input file MEASUREMENT.PAR -- see write_par_file.pl for details
+
+ OUT_DIR = 'OUTPUT_FILES' ! default
+
+ open(10,file='MEASUREMENT.PAR',status='old',iostat=ios)
+ read(10,*) tt,dtt,nn
+ read(10,*) imeas0
+ read(10,*) chan
+ read(10,*) TLONG, TSHORT
+ read(10,*) RUN_BANDPASS
+ read(10,*) DISPLAY_DETAILS
+ read(10,*) OUTPUT_MEASUREMENT_FILES
+ read(10,*) COMPUTE_ADJOINT_SOURCE
+ read(10,*) TSHIFT_MIN, TSHIFT_MAX
+ read(10,*) DLNA_MIN, DLNA_MAX
+ read(10,*) CC_MIN
+ read(10,*) ERROR_TYPE
+ read(10,*) DT_SIGMA_MIN
+ read(10,*) DLNA_SIGMA_MIN
+ read(10,*) ITAPER
+ read(10,*) WTR,NPI
+ read(10,*) DT_FAC
+ read(10,*) ERR_FAC
+ read(10,*) DT_MAX_SCALE
+ read(10,*) NCYCLE_IN_WINDOW
+ close(10)
+
+ imeas = imeas0
+
+ ! check the read-in values
+ print *, 'INPUTS FROM MEASUREMENT.PAR :'
+ print *, ' tt, dtt, nn : ',tt,dtt,nn
+ print *, ' imeas : ',imeas
+ print *, ' chan : ',chan
+ print *, ' TLONG, TSHORT : ',TLONG, TSHORT
+ fstart0 = 1./TLONG ; fend0 = 1./TSHORT
+ print *, ' fstart, fend : ', fstart0, fend0
+ print *, ' RUN_BANDPASS : ',RUN_BANDPASS
+ print *, ' DISPLAY_DETAILS : ',DISPLAY_DETAILS
+ print *, ' OUTPUT_MEASUREMENT_FILES : ',OUTPUT_MEASUREMENT_FILES
+ print *, ' COMPUTE_ADJOINT_SOURCE : ',COMPUTE_ADJOINT_SOURCE
+ print *, ' TSHIFT_MIN, TSHIFT_MAX : ',TSHIFT_MIN, TSHIFT_MAX
+ print *, ' DLNA_MIN, DLNA_MAX : ',DLNA_MIN, DLNA_MAX
+ print *, ' CC_MIN : ',CC_MIN
+ print *, ' ERROR_TYPE : ',ERROR_TYPE
+ print *, ' DT_SIGMA_MIN : ',DT_SIGMA_MIN
+ print *, ' DLNA_SIGMA_MIN : ',DLNA_SIGMA_MIN
+ print *, ' ITAPER : ',ITAPER
+ print *, ' WTR, NPI : ',WTR,NPI
+ print *, ' DT_FAC : ',DT_FAC
+ print *, ' ERR_FAC : ',ERR_FAC
+ print *, ' DT_MAX_SCALE : ',DT_MAX_SCALE
+ print *, ' NCYCLE_IN_WINDOW : ',NCYCLE_IN_WINDOW
+ !stop 'checking PAR file input'
+
+ ! old format way..
+ ! open(10,file='MEASUREMENT.PAR',status='old',iostat=ios)
+ ! read(10,'(a)') out_dir
+ ! read(10,*) is_mtm0
+ ! read(10,*) wtr,npi
+ ! read(10,*) iker0
+ ! read(10,*) RUN_BANDPASS
+ ! read(10,*) TLONG, TSHORT
+ ! read(10,*) tt,dtt,nn
+ ! read(10,*) DISPLAY_DETAILS
+ ! read(10,*) OUTPUT_MEASUREMENT_FILES
+ ! read(10,*) INCLUDE_ERROR
+ ! read(10,*) DT_FAC
+ ! read(10,*) ERR_FAC
+ ! read(10,*) DT_MAX_SCALE
+ ! read(10,*) NCYCLE_IN_WINDOW
+ ! read(10,*) BEFORE_QUALITY, AFTER_QUALITY
+ ! read(10,*) BEFORE_TSHIFT, AFTER_TSHIFT
+ ! read(10,*) DT_SIGMA_MIN, DLNA_SIGMA_MIN
+ ! close(10)
+ !
+ ! out_dir = adjustl(out_dir)
+ ! iker = iker0
+ ! is_mtm = is_mtm0
+ !
+ ! ! check the read-in values
+ ! print *, 'INPUTS FROM MEASUREMENT.PAR :'
+ ! print *, ' is_mtm : ',is_mtm
+ ! print *, ' wtr, npi : ',wtr,npi
+ ! print *, ' iker : ',iker
+ ! print *, ' RUN_BANDPASS :',RUN_BANDPASS
+ ! print *, ' TLONG, TSHORT : ',TLONG, TSHORT
+ ! fstart0 = 1./TLONG ; fend0 = 1./TSHORT
+ ! print *, ' fstart, fend :', fstart0, fend0
+ ! print *, ' tt, dtt, nn : ',tt,dtt,nn
+ ! print *, ' out_dir : ',trim(out_dir)
+ ! print *, ' DISPLAY_DETAILS :',DISPLAY_DETAILS
+ ! print *, ' OUTPUT_MEASUREMENT_FILES :',OUTPUT_MEASUREMENT_FILES
+ ! print *, ' INCLUDE_ERROR :',INCLUDE_ERROR
+ ! print *, ' DT_FAC :',DT_FAC
+ ! print *, ' ERR_FAC :',ERR_FAC
+ ! print *, ' DT_MAX_SCALE :',DT_MAX_SCALE
+ ! print *, ' NCYCLE_IN_WINDOW :',NCYCLE_IN_WINDOW
+ ! print *, ' BEFORE_QUALITY, AFTER_QUALITY :',BEFORE_QUALITY, AFTER_QUALITY
+ ! print *, ' BEFORE_TSHIFT, AFTER_TSHIFT :',BEFORE_TSHIFT, AFTER_TSHIFT
+ ! print *, ' DT_SIGMA_MIN, DLNA_SIGMA_MIN :',DT_SIGMA_MIN, DLNA_SIGMA_MIN
+ ! !stop 'checking PAR file input'
+ ! apply filter (this should EXACTLY match the filter used in the windowing code)
+ !trbdndw = 0.3
+ !a = 30.
+ !iord = 4
+ !passes = 2
+
+ ! ray density
+ if( DO_RAY_DENSITY_SOURCE ) ERROR_TYPE = 0
+
+ ! assign additional parameters and stop for certain inconsistencies
+ if (fstart0.ge.fend0) then
+ print *, 'Check input frequency range of the signal'
+ stop
+ endif
+
+ if (nn > NDIM) then
+ print *, 'Error: Change interpolation nn or NDIM'
+ stop
+ endif
+
+ ! for CC kernels, ITAPER must be a single taper (2 or 3)
+ if ( (ITAPER==1) .and. ((imeas.ge.3).and.(imeas.le.6)) ) then
+ print *, 'Error: Change ITAPER to 2 or 3'
+ stop
+ endif
+
+ if ( (imeas==1).or.(imeas==2) ) then
+ is_mtm0 = 0
+ elseif ( (imeas.ge.3).and.(imeas.le.6) ) then
+ is_mtm0 = ITAPER ! 2 or 3
+ elseif ( (imeas==7).or.(imeas==8) ) then
+ is_mtm0 = 1 ! multitaper required for MT adjoint source
+ else
+ print *, 'Error: imeas must by 1-8'
+ stop
+ endif
+
+ is_mtm = is_mtm0
+ print *, ' is_mtm :',is_mtm
+
+ end subroutine read_par_file
+
+!-------------------------------------------------------------------
+
+ subroutine get_sacfile_header(data_file,yr,jda,ho,mi,sec,ntw,sta, &
+ comp,dist,az,baz,slat,slon)
+
+ implicit none
+ character(len=*),intent(in) :: data_file
+
+ integer,intent(out):: yr,jda,ho,mi
+ double precision,intent(out):: sec,dist,az,baz,slat,slon
+ !real*8,intent(out):: sec,dist,az,baz,slat,slon
+ character(len=*),intent(out) :: ntw,sta,comp
+ !real*8 :: tmp
+ real :: tmp
+
+ integer :: nsec,msec !,i,klen
+ integer :: nerr
+
+ ! integer header variables
+ call getnhv('nzyear',yr,nerr)
+ call getnhv('nzjday',jda,nerr)
+ call getnhv('nzhour',ho,nerr)
+ call getnhv('nzhour',mi,nerr)
+ call getnhv('nzmin',nsec,nerr)
+ call getnhv('nzmsec',msec,nerr)
+
+ sec=nsec+msec/1000.0
+
+ ! string headers
+ call getkhv('knetwk',ntw,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: knetwk'
+ call exit(-1)
+ endif
+
+ call getkhv('kstnm',sta,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: kstnm'
+ call exit(-1)
+ endif
+
+ call getkhv('kcmpnm',comp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: kcmpnm'
+ call exit(-1)
+ endif
+
+ ! decimal headers
+ call getfhv('dist',tmp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: dist'
+ call exit(-1)
+ endif
+ dist = tmp
+
+ call getfhv('az',tmp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: az'
+ call exit(-1)
+ endif
+ az = tmp
+
+ call getfhv('baz',tmp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: baz'
+ call exit(-1)
+ endif
+ baz = tmp
+
+ call getfhv('stlo',tmp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: stlo'
+ call exit(-1)
+ endif
+ slon = tmp
+
+ call getfhv('stla',tmp,nerr)
+ if(nerr .ne. 0) then
+ write(*,*)'Error reading variable: stla'
+ call exit(-1)
+ endif
+ slat = tmp
+
+!!$ ! integer header variables
+!!$ call saclst_iheader_f(data_file,'nzyear', yr)
+!!$ call saclst_iheader_f(data_file,'nzjday', jda)
+!!$ call saclst_iheader_f(data_file,'nzhour', ho)
+!!$ call saclst_iheader_f(data_file,'nzmin', mi)
+!!$ call saclst_iheader_f(data_file,'nzsec', nsec)
+!!$ call saclst_iheader_f(data_file,'nzmsec', msec)
+!!$
+!!$ sec=nsec+msec/1000.0
+!!$
+!!$ call saclst_kheader_f(data_file,'knetwk',ntw,klen)
+!!$ call saclst_kheader_f(data_file,'kstnm', sta,klen)
+!!$ call saclst_kheader_f(data_file,'kcmpnm',comp,klen)
+!!$
+!!$ call dsaclst_fheader_f(data_file,'dist',dist)
+!!$ call dsaclst_fheader_f(data_file,'az', az)
+!!$ call dsaclst_fheader_f(data_file,'baz', baz)
+!!$ call dsaclst_fheader_f(data_file,'stlo',slon)
+!!$ call dsaclst_fheader_f(data_file,'stla',slat)
+
+ end subroutine get_sacfile_header
+
+end module mt_sub
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub2.f90 (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub2.f90)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub2.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/ma_sub2.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,657 @@
+module mt_sub2
+
+
+ use mt_constants
+
+ implicit none
+
+! TOLERRANCE CONTROL
+ double precision, parameter :: TOL=1e-7
+
+contains
+
+!------------------------------------------------------------------
+ subroutine fft(n,xi,zzign,dt)
+! Fourier transform
+! This inputs AND outputs a complex function.
+! The convention is FFT --> e^(-iwt)
+! numerical factor for Plancherel theorem: planch_fac = dble(NPT * dt * dt)
+!------------------------------------------------------------------
+ complex*16, dimension(*) :: xi
+ integer :: n
+ double precision :: dt
+
+ double precision, parameter :: PI = 3.141592653589793d+00
+ complex*16 :: wk, hold, q
+ double precision :: m(25)
+ double precision :: zzign,zign,flx,v
+ integer :: lblock,k,fk,jh,ii,istart
+ integer :: l,iblock,nblock,i,lbhalf,j,lx
+
+ ! sign must be +1. or -1.
+ if(zzign >= 0.) then
+ zign = 1.
+ else
+ zign = -1.
+ endif
+
+ lx = 2**n
+
+ ! checks bounds
+ if( lx > NPT ) stop 'error fft increase NPT, or decrease n'
+
+
+
+ do 1 i=1,n
+ 1 m(i) = 2**(n-i)
+ do 4 l=1,n
+ nblock = 2**(l-1)
+ lblock = lx/nblock
+ lbhalf = lblock/2
+ k = 0
+ do 4 iblock=1,nblock
+ fk = k
+ flx = lx
+
+ v = zign*2.*PI*fk/flx ! Fourier convention
+
+ wk = cmplx(cos(v),-sin(v)) ! sign change to -sin(v) 17-Nov-2006
+ istart = lblock*(iblock-1)
+
+ do 2 i=1,lbhalf
+ j = istart+i
+ jh = j+lbhalf
+ ! checks bounds
+ if( jh < 1 .or. jh > NPT ) stop 'error fft bounds'
+
+ q = xi(jh)*wk
+ xi(jh) = xi(j)-q
+ xi(j) = xi(j)+q
+ 2 continue
+
+ do 3 i=2,n
+ ii = i
+ if(k < m(i)) go to 4
+ 3 k = k-m(i)
+ 4 k = k+m(ii)
+ k = 0
+ do 7 j=1,lx
+ if(k < j) go to 5
+ hold = xi(j)
+ ! checks bounds
+ if( k+1 < 1 .or. k+1 > NPT ) stop 'error fft k bounds'
+ xi(j) = xi(k+1)
+ xi(k+1) = hold
+ 5 do 6 i=1,n
+ ii = i
+ if(k < m(i)) go to 7
+ 6 k = k-m(i)
+ 7 k = k+m(ii)
+
+ ! final steps deal with dt factors
+ if(zign > 0.) then ! FORWARD FFT
+ do i = 1,lx
+ xi(i) = xi(i)*dt ! multiplication by dt
+ enddo
+
+ else ! REVERSE FFT
+ flx = flx*dt
+ do i = 1,lx
+ xi(i) = xi(i)/flx ! division by dt
+ enddo
+ endif
+
+ end subroutine fft
+
+!------------------------------------------------------------------
+ subroutine fftinv(npow,s,zzign,dt,r)
+! inverse Fourier transform -- calls fft
+!------------------------------------------------------------------
+
+ !implicit real*8(a-h,o-z)
+ !dimension r(4096*4)
+ !complex s(4096*4)
+
+ complex*16, intent(in) :: s(*)
+ double precision, intent(out) :: r(*) ! note this is REAL
+
+ double precision :: dt,zzign,zign
+ integer :: npow, nsmp, nhalf, i
+
+ nsmp = 2**npow
+ nhalf = nsmp/2
+ call rspec(s,nhalf) ! re-structuring
+
+ zign=zzign
+ call fft(npow,s,zign,dt) ! Fourier transform
+
+ do i = 1,nsmp
+ r(i) = real(s(i)) ! REAL part
+ enddo
+
+ end subroutine fftinv
+
+!------------------------------------------------------------------
+ subroutine rspec(s,np2)
+!------------------------------------------------------------------
+
+ !implicit real*8(a-h,o-z)
+ !complex s(4096*4)
+
+ complex*16 :: s(*)
+ integer :: np2,n,n1,i
+
+ n = 2*np2
+ n1 = np2+1
+
+ s(n1) = 0.
+! s(1) = 0.
+ s(1) = cmplx( real(s(1)),0.)
+
+ do i = 1,np2
+ s(np2+i) = conjg(s(np2+2-i))
+ enddo
+
+ end subroutine rspec
+
+!------------------------------------------------------------------
+ subroutine staper(nt, fw, nev, v, ndim, a, w)
+!------------------------------------------------------------------
+!$$$$ calls tsturm, root
+! Slepian - Thomson multi-taper procedure
+! Slepian, D. 1978 Bell Sys Tech J v57 n5 1371-1430
+! Thomson, D. J. 1982 Proc IEEE v70 n9 1055-1096
+! nt the number of points in the series
+! fw the time-bandwidth product (number of Rayleigh bins)
+! nev the desired number of tapers
+! v the eigenvectors (tapers) are returned in v(.,nev)
+! a, w work arrays dimensioned at least nt long (nt+1, nt odd)
+! a(1..nev) contains bandwidth retention factors on output.
+! The tapers are the eigenvectors of the tridiagonal matrix sigma(i,j)
+! [see Slepian(1978) eq 14 and 25.] They are also the eigenvectors of
+! the Toeplitz matrix eq. 18. We solve the tridiagonal system in
+! tsturm for the tapers and use them in Slepians eq 18 to get the
+! bandwidth retention factors (i.e. the eigenvalues) Thomson's
+! normalisation is used with no attention to sign.
+ !implicit real*8(a-h,o-z)
+ !dimension a(*),w(*),v(ndim,*)
+ !parameter (pi=3.14159265358979d0,r2=1.414213562373095d0)
+
+ integer :: nt, nev, ndim
+ double precision :: fw
+ double precision :: v(ndim,*), a(*), w(*)
+
+ double precision, parameter :: PI = 3.141592653589793d+00
+ integer :: i,j,k,m
+ integer :: nxi, lh, lp1, neven, nodd, ntot, kk, kmax, nlow, nup
+ double precision :: r2,om,com,hn,asav,rbd,dc,sm,s,sn,vmax
+
+ !-------------------------
+
+ r2 = sqrt(2.)
+
+ if(nt < 2) return
+ nxi=mod(nt,2)
+ lh=(nt/2)+nxi
+ lp1=nt+1
+ om=2.*PI*fw/nt
+ com=cos(om)
+ hn=0.5*dble(lp1)
+ do 10 i=1,lh
+ a(i)=com*(i-hn)**2
+ 10 w(i)=0.5*dble(i*(nt-i))
+ if(nxi == 0) then
+ asav=a(lh)-w(lh)
+ a(lh)=a(lh)+w(lh)
+ rbd=1./(a(lh)+w(lh-1))
+ else
+ asav=w(lh-1)
+ rbd=1./(w(lh)+w(lh-1))
+ w(lh-1)=r2*w(lh-1)
+ endif
+ do 15 i=1,lh
+ a(i+lh)=w(i)*rbd
+ w(i)=a(i+lh)**2
+ 15 a(i)=a(i)*rbd
+ neven=max0((nev+1)/2,1)
+ nodd=nev-neven
+! Do the even tapers
+ call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0)
+ do 20 i=1,neven
+ k=2*i-1
+ if(nxi == 1) v(lh,k)=r2*v(lh,k)
+ do 20 j=1,lh
+ 20 v(lp1-j,k)=v(j,k)
+ if(nodd <= 0) goto 34
+! Do the odd tapers
+ if(nxi == 0) then
+ a(lh)=asav*rbd
+ else
+ a(nt)=asav*rbd
+ w(lh-1)=asav*asav
+ endif
+ call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1)
+ do 30 i=1,nodd
+ k=2*i
+ if(nxi == 1) v(lh,k)=0.
+ do 30 j=1,lh
+ 30 v(lp1-j,k)=-v(j,k)
+ 34 ntot=neven+nodd
+! Calculate bandwidth retention parameters
+ dc=2.*com
+ sm=0.
+ s=sin(om)
+ w(1)=om/PI
+ w(2)=s/PI
+ do 35 j=3,nt
+ sn=dc*s-sm
+ sm=s
+ s=sn
+ 35 w(j)=s/(PI*(j-1))
+ do 55 m=1,ntot
+ vmax=abs(v(1,m))
+ kmax=1
+ do 40 kk=2,lh
+ if(abs(v(kk,m)) <= vmax) goto 40
+ kmax=kk
+ vmax=abs(v(kk,m))
+ 40 continue
+ a(m)=0.
+ nlow=kmax-1
+ do 45 j=1,nlow
+ 45 a(m)=a(m)+w(j+1)*v(nlow+1-j,m)
+ nup=nt-nlow
+ do 50 j=1,nup
+ 50 a(m)=a(m)+w(j)*v(nlow+j,m)
+ 55 a(m)=a(m)/v(kmax,m)
+ return
+
+ end subroutine staper
+
+!------------------------------------------------------------------
+ subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar)
+!------------------------------------------------------------------
+!$$$$ calls root
+! Uses bisection and Sturm counting to isolate the eigenvalues of the
+! symmetric tridiagonal matrix with main diagonal a(.) and sub/super
+! diagonal b(.). Newton's method is used to refine the eigenvalue in
+! subroutine root then direct recursion is used to get the eigenvector
+! as this is always stable. Note ipar=0 for even tapers =1 for odd
+! tapers
+ !implicit real*8(a-h,o-z)
+ !parameter (epsi=1.d-15,epsi1=5.d-15)
+ !dimension a(*),b(*),ev(*),w(*),r(ndim,*)
+
+ double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15
+
+ double precision, dimension(ndim) :: a, b, w, ev
+ double precision, dimension(ndim,*) :: r
+ integer :: nt,n,ndim,nev,ipar
+
+ !double precision, dimension(ndim) :: bb
+ double precision :: q,el,elam,u,umeps,x,ddot,rnorm
+ integer :: i,j,ik,iag,m,jk,jm1
+
+ !-------------------------
+
+ if(n <= 0.or.nev <= 0) return
+ umeps=1.-epsi
+ do 5 i=1,nev
+ 5 ev(i)=-1.
+ u=1.
+ do 1000 ik=1,nev
+ if(ik > 1) u=ev(ik-1)*umeps
+ el=min(ev(ik),u)
+ 10 elam=0.5*(u+el)
+ if(abs(u-el) <= epsi1) goto 35
+ iag=0
+ q=a(1)-elam
+ if(q >= 0.) iag=iag+1
+ do 15 i=2,n
+ if(q == 0.) x=abs(b(i-1))/epsi
+ if(q /= 0.) x=w(i-1)/q
+ q=a(i)-elam-x
+ if(q >= 0.) iag=iag+1
+ if(iag > nev) goto 20
+ 15 continue
+ if(iag >= ik) go to 20
+ u=elam
+ go to 10
+ 20 if(iag == ik) go to 30
+ m=ik+1
+ do 25 i=m,iag
+ 25 ev(i)=elam
+ el=elam
+ go to 10
+ 30 el=elam
+ call root(u,el,elam,a,b,w,n,ik)
+ 35 ev(ik)=elam
+ jk=2*ik+ipar-1
+ r(1,jk)=1.
+ r(2,jk)=-(a(1)-ev(ik))/b(1)
+ ddot=1.+r(2,jk)*r(2,jk)
+ jm1=2
+ do 45 j=3,n
+ r(j,jk)=-((a(jm1)-ev(ik))*r(jm1,jk)+b(j-2)*r(j-2,jk))/b(jm1)
+ ddot=ddot+r(j,jk)*r(j,jk)
+ 45 jm1=j
+ rnorm=sqrt(nt/(2.*ddot))
+ do 50 j=1,n
+ 50 r(j,jk)=r(j,jk)*rnorm
+ 1000 continue
+ return
+
+ end subroutine tsturm
+
+!------------------------------------------------------------------
+ subroutine root(u,el,elam,a,bb,w,n,ik)
+!------------------------------------------------------------------
+
+ !implicit real*8(a-h,o-z)
+ !parameter (epsi = 1.d-15, epsi1 = 5.d-15)
+ !dimension a(*),bb(*),w(*)
+
+ double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15
+ double precision :: u,el,elam
+ double precision, dimension(*) :: a,bb,w
+ integer :: n,ik
+
+ double precision :: an,b,bm,bn,del,x
+ integer :: i,iag
+
+ !----------------------
+
+ 5 elam=0.5*(u+el)
+ 10 if(abs(u-el) <= 1.5*epsi1) return
+ an=a(1)-elam
+ b=0.
+ bn=-1./an
+ iag=0
+ if(an >= 0.) iag=iag+1
+ do 20 i=2,n
+ if(an == 0.) x=abs(bb(i-1))/epsi
+ if(an /= 0.) x=w(i-1)/an
+ an=a(i)-elam-x
+ if(an == 0.) an=epsi
+ bm=b
+ b=bn
+ bn=((a(i)-elam)*b-bm*x-1.)/an
+ if(an >= 0.) iag=iag+1
+ 20 continue
+ if(iag == ik) goto 25
+ u=elam
+ goto 30
+ 25 el=elam
+ 30 del=1./bn
+ if(abs(del) <= epsi1) del=sign(epsi1,del)
+ elam=elam-del
+ if(elam >= u.or.elam <= el) goto 5
+ goto 10
+
+ end subroutine root
+!-------------------------------------------
+
+! -----------------------------------------------------------------
+!
+! Alessia Maggi, May 2005
+!
+! -----------------------------------------------------------------
+! $Id:$
+! -----------------------------------------------------------------
+!
+! Implementation of the Ritsema & van Heijst 2002 quality checking
+! technique.
+! Calculation of two quantities:
+!
+! F1 = sum_t [ d(t) - s(t)]^2 / sum_t [d(t)]^2
+!
+! F2 = min[A1,A2] / max [A1,A2]
+!
+! A1 minimizes : sum_t [ d(t) - A1*s(t)]^2
+! A2 minimizes : sum_t [ (1/A2)*d(t) - s(t)]^2
+!
+! Inputs:
+! -------
+! d : data timeseries array
+! s : synthetic timeseries array
+! npts : number of points in the two timeseries
+
+! Outputs:
+! --------
+! F1, F2,dlnA,cc_max : defined above
+!
+! Calls numerical recipies routines :
+! mnbrak, golden
+!
+! -----------------------------------------------------------------
+
+!!$ subroutine F1F2_calc(d,s,npts,i1,i2,dt,F1,F2,tshift,cc_max,dlnA)
+!!$
+!!$
+!!$ double precision, dimension(*), intent(in) :: d, s
+!!$ integer, intent(in) :: npts,i1,i2
+!!$ double precision, intent (in) :: dt
+!!$ double precision, intent(out) :: F1,F2,tshift,cc_max,dlnA
+!!$
+!!$ double precision, dimension(:), allocatable :: s_cor,d_loc
+!!$
+!!$ double precision :: cr_shift, cc
+!!$ integer :: n_left,n_right,ishift,npts_win, i, j
+!!$
+!!$ real ax,bx,cx,fa,fb,fc,f1_min,f2_min,f1_top,f1_bot,A1,A2
+!!$ real golden !f1,f2
+!!$
+!!$ npts_win=i2-i1+1
+!!$
+!!$! allocate memory for s_cor (the corrected synthetic)
+!!$ allocate(s_cor(npts_win))
+!!$ allocate(d_loc(npts_win))
+!!$
+!!$ d_loc(1:npts_win)=d(i1:i2)
+!!$
+!!$! do cross-correlation:
+!!$ call xcorr_calc(d,s,npts,i1,i2,ishift,cc_max)
+!!$! n_left = int((-1.0) * cr_shift / dt)
+!!$! n_right = int(cr_shift / dt)
+!!$! ishift=0
+!!$! cc_max=0.
+!!$! do i = n_left, n_right
+!!$! cc = 0
+!!$! do j = 1, npts
+!!$! if((j+i).gt.1.and.(j+i).lt.npts) cc = cc + s(j) * d(j+i)
+!!$! enddo
+!!$! if( cc .gt. cc_max) then
+!!$! cc_max = cc
+!!$! ishift = i
+!!$! endif
+!!$! enddo
+!!$ tshift=ishift*dt
+!!$
+!!$! apply time shift to synthetic seismogram
+!!$! write(*,*)'shift synth seismogram by ', tshift, 'seconds'
+!!$ do i = 1, npts_win
+!!$ s_cor(i) = 0
+!!$ if( (i1-1+i-ishift) .gt. 1 .and. (i1-1+i-ishift) .lt.npts ) s_cor(i) = s(i1-1+i-ishift)
+!!$ enddo
+!!$
+!!$! DEBUG: output
+!!$! open(unit=11, file='DEBUG_calcF1F2.dat')
+!!$! do i = 1, npts_win
+!!$! write(11,'(4(e12.4,1x))') b+(i-1)*dt, s_cor(i), s(i1-1+i), d(i1-1+i)
+!!$! enddo
+!!$! close(11)
+!!$
+!!$! calculate dlnA
+!!$ dlnA = sqrt( ( sum( d(i1:i2) * d(i1:i2) )) / (sum( s_cor(1:npts_win) * s_cor(1:npts_win) )) ) - 1
+!!$
+!!$
+!!$! calculate F1, the least squares misfit
+!!$ f1_top=0.0
+!!$ f1_bot=0.0
+!!$ do i = 1,npts_win
+!!$ f1_top=f1_top+(sngl(d_loc(i))-sngl(s_cor(i)))**2
+!!$! f1_bot=f1_bot+sqrt(sngl(d_loc(i))**2*sngl(s_cor(i))**2)
+!!$ f1_bot=f1_bot+sngl(d_loc(i))**2
+!!$ enddo
+!!$ if ( f1_bot .gt. 0.0 ) then
+!!$ F1 = dble(f1_top / f1_bot)
+!!$ else
+!!$ write(*,*) 'Sum d(t)**2 = 0 : empty observed seismogram.'
+!!$ F1=0
+!!$ F2=0
+!!$ return
+!!$ endif
+!!$
+!!$! do fa1 minimization to find A1
+!!$ ax=1e-3
+!!$ bx=1e3
+!!$ call mnbrak(ax,bx,cx,fa,fb,fc,fa1)
+!!$ f1_min=golden(ax,bx,cx,fa1,sngl(tol),A1)
+!!$
+!!$! do fa2 minimization to find A2
+!!$ ax=1e-3
+!!$ bx=1e3
+!!$ call mnbrak(ax,bx,cx,fa,fb,fc,fa2)
+!!$ f2_min=golden(ax,bx,cx,fa2,sngl(TOL),A2)
+!!$
+!!$! calculate F2
+!!$ F2=dble(min(A1,A2)/max(A1,A2))
+!!$
+!!$! Turn F1 around
+!!$ F1=1-F1
+!!$
+!!$ deallocate(s_cor)
+!!$ deallocate(d_loc)
+!!$
+!!$ contains
+!!$
+!!$! -----------------------------------------------------------------
+!!$
+!!$ real function fa1(a1)
+!!$ real a1
+!!$
+!!$ if (abs(a1).lt.TOL) then
+!!$ write(*,*) 'value of a1 close to zero : ', a1
+!!$ stop
+!!$ endif
+!!$
+!!$ fa1=0.0
+!!$ do i = 1,npts_win
+!!$ fa1=fa1+(sngl(d_loc(i))-a1*sngl(s_cor(i)))**2
+!!$ enddo
+!!$
+!!$ end function
+!!$
+!!$! -----------------------------------------------------------------
+!!$
+!!$ real function fa2(a2)
+!!$ real a2
+!!$
+!!$ if (abs(a2).lt.TOL) then
+!!$ write(*,*) 'value of a2 close to zero : ', a2
+!!$ stop
+!!$ endif
+!!$
+!!$ fa2=0.0
+!!$ do i = 1,npts_win
+!!$ fa2=fa2+((1/a2)*sngl(d_loc(i))-sngl(s_cor(i)))**2
+!!$ enddo
+!!$
+!!$ end function
+!!$
+!!$ end subroutine F1F2_calc
+!!$
+!!$! --------------------------------------------------------------------
+!!$
+!!$ subroutine xcorr_calc(d,s,npts,i1,i2,ishift,cc_max)
+!!$
+!!$ ! inputs:
+!!$ ! s(npts) = synthetic
+!!$ ! d(npts) = data (or observed)
+!!$ ! i1, i2 = start and stop indexes of window within s and d
+!!$
+!!$ double precision, dimension(*), intent(in) :: s,d
+!!$ integer, intent(in) :: npts, i1, i2
+!!$
+!!$ ! outputs:
+!!$ ! ishift = index lag (d-s) for max cross correlation
+!!$ ! cc_max = maximum of cross correlation (normalised by sqrt(synthetic*data))
+!!$ integer, intent(out) :: ishift
+!!$ double precision, intent(out) :: cc_max
+!!$
+!!$ ! local variables
+!!$ integer :: nlen
+!!$ integer :: i_left, i_right, i, j
+!!$ double precision :: cc
+!!$
+!!$ ! initialise shift and cross correlation to zero
+!!$ ishift=0
+!!$ cc_max=0
+!!$
+!!$ if (i1.gt.i2 .or. i2.gt.npts) then
+!!$ write(*,*) 'Error with window limits: i1, i2, npts ', i1, i2, npts
+!!$ return
+!!$ endif
+!!$
+!!$ ! length of window (number of points including ends)
+!!$ nlen = i2 - i1 + 1
+!!$
+!!$ ! left and right limits of index (time) shift search
+!!$ i_left=-1*int(nlen/2)
+!!$ i_right=int(nlen/2)
+!!$
+!!$
+!!$ ! i -> shift (to be applied to d in cc search)
+!!$ do i = i_left, i_right
+!!$ cc=0
+!!$ do j = i1, i2
+!!$ if((j+i).ge.1 .and. (j+i).le.npts) cc = cc + s(j)*d(j+i)
+!!$ enddo
+!!$ if (cc .gt. cc_max) then
+!!$ cc_max=cc
+!!$ ishift=i
+!!$ endif
+!!$ enddo
+!!$
+!!$ cc_max=cc_max / sqrt(sum(s(i1:i2)*s(i1:i2)) * sum(d(i1:i2)*(d(i1:i2))))
+!!$
+!!$end subroutine xcorr_calc
+
+
+! ------------------------------------------------------------------
+! subroutine costaper(ipoint, ndata, tas)
+! ------------------------------------------------------------------
+ subroutine costaper(ipoint, ndata, tas)
+ implicit none
+
+ integer ipoint, ndata
+ double precision tas(ndata,*)
+ double precision sum, pi
+ integer i
+
+ pi = asin(1.0d0)*2
+ sum = 0.
+ do i =1,ipoint
+ tas(i,1) = 1 - cos( 2*pi*i/ipoint)
+ tas(i,1) = tas(i,1) / sqrt(1.5)
+ enddo
+ return
+ end subroutine costaper
+
+! ------------------------------------------------------------------
+! subroutine boxcar(ipoint, ndata, tas)
+! ------------------------------------------------------------------
+ subroutine boxcar(ipoint, ndata, tas)
+
+ integer ipoint, ndata
+ double precision tas(ndata,*)
+ integer i
+
+ do i =1,ipoint
+ tas(i,1) = 1.0
+ enddo
+ return
+ end subroutine boxcar
+
+
+end module mt_sub2
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/ma_variables.f90 (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/mt_variables.f90)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/ma_variables.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/ma_variables.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,56 @@
+module mt_variables
+
+ use mt_constants
+!
+! multi-taper measurements
+!
+! Ying Zhou: The fit between the recovered data and the data can be improved
+! by either increasing the window width (HWIN above) or by decreasing NPI.
+! In her experience, NPI = 2.5 is good for noisy data.
+! For synthetic data, we can use a lower NPI.
+! number of tapers should be fixed as twice NPI -- see Latex notes
+!
+! See write_par_file.pl and mt_measure_adj.f90
+
+ character(len=150) :: OUT_DIR
+
+ double precision :: TLONG, TSHORT
+ double precision :: WTR, NPI, DT_FAC, ERR_FAC, DT_MAX_SCALE, NCYCLE_IN_WINDOW
+ !double precision :: BEFORE_QUALITY, AFTER_QUALITY, BEFORE_TSHIFT, AFTER_TSHIFT
+ double precision :: TSHIFT_MIN, TSHIFT_MAX, DLNA_MIN, DLNA_MAX, CC_MIN
+ double precision :: DT_SIGMA_MIN, DLNA_SIGMA_MIN
+
+ integer :: ntaper, ipwr_t, ipwr_w, ERROR_TYPE
+ integer :: imeas0, imeas, itaper, is_mtm0, is_mtm
+
+ logical :: DISPLAY_DETAILS,OUTPUT_MEASUREMENT_FILES,RUN_BANDPASS,COMPUTE_ADJOINT_SOURCE
+
+end module mt_variables
+
+
+module mt_weighting
+
+! module for weighting/normalizing measurements
+
+ logical,parameter :: DO_WEIGHTING = .false.
+
+ ! transverse, radial and vertical weights
+ double precision :: weight_T, weight_R, weight_Z
+ ! body waves: number of picks on vertical, radial and transverse component
+ double precision :: num_P_SV_V,num_P_SV_R,num_SH_T
+ ! surface waves: number of pick on vertical, radial and transverse
+ double precision :: num_Rayleigh_V,num_Rayleigh_R,num_Love_T
+
+ ! typical surface wave speed in km/s, to calculate surface wave arrival times
+ ! Love waves faster than Rayleigh
+ double precision, parameter :: surface_vel = 4.0
+
+ ! wave type pick
+ integer, parameter :: P_SV_V = 1
+ integer, parameter :: P_SV_R = 2
+ integer, parameter :: SH_T = 3
+ integer, parameter :: Rayleigh_V = 4
+ integer, parameter :: Rayleigh_R = 5
+ integer, parameter :: Love_T = 6
+
+end module mt_weighting
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/measure_adj.f90 (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/mt_measure_adj.f90)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/measure_adj.f90 (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/measure_adj.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,665 @@
+program mt_measure_adj
+
+ ! main program that calls the subroutines to make the MT measurements
+ ! and compute the corresponding adjoint sources
+
+ ! input parameter:
+ ! 1. imeas = 1, normalized waveform difference. Adjoint source is constructed from the data
+ ! only, with the form −d(t)/ || d(t) || 2
+ ! 2. imeas = 2, waveform difference, s(t) − d(t).
+ ! 3. imeas = 3, cross-correlation traveltime difference for a (banana-doughtnut) sensitivity ker-
+ ! nel. The measurement between data and synthetics is not used in constructing the adjoint
+ ! source.
+ ! 4. imeas = 4, amplitude difference for a (banana-doughtnut) sensitivity kernel. The measure-
+ ! ment between data and synthetics is not used in constructing the adjoint source.
+ ! 5. imeas = 5, cross-correlation traveltime difference for an event kernel. The measurement
+ ! between data and synthetics is used in constructing the adjoint source.
+ ! 6. imeas = 6, amplitude difference for an event kernel. The measurement between data and
+ ! synthetics is used in constructing the adjoint source.
+ ! 7. imeas = 7, multitaper traveltime difference for an event kernel. The measurement between
+ ! data and synthetics is used in constructing the adjoint source. See multitaper_notes.pdf.
+ ! 8. imeas = 8, multitaper ampltidue difference for an event kernel. The measurement between
+ ! data and synthetics is used in constructing the adjoint source. See multitaper_notes.pdf.
+
+ use mt_variables
+ use mt_constants
+ use ascii_rw ! dwascii()
+ use mt_sub2 ! fft(), fftinv()
+ use mt_sub ! mt_measure(), mt_adj()
+ use mt_weighting
+
+ implicit none
+
+ character(len=150) :: datafile,synfile,file_prefix,file_prefix0,file_prefix2,measure_file_prefix,adj_file_prefix
+ integer :: num_meas, j, ios, npt1, npt2, npts, nn
+ double precision, dimension(NDIM) :: data, syn, adj_syn_all, tr_adj_src, am_adj_src, recon_cc_all, syn_dtw_cc
+ double precision :: t01, dt1, t02, dt2, t0, dt, tstart, tend, tt, dtt, df
+ double precision, dimension(NCHI) :: window_chi
+ double precision :: fend0, fstart0, fend, fstart
+ !double precision :: TSHORT, TLONG ! mtm_variables.f90
+
+ ! sac header information
+ integer :: yr,jda,ho,mi
+ double precision :: sec,dist,az,baz,slat,slon
+ character(len=10) :: net,sta,chan_dat,chan,cmp,chan_syn
+ double precision :: tshift, sigma_dt_cc, dlnA, sigma_dlnA_cc, sigma_dt, sigma_dlnA
+ double precision :: tr_chi, am_chi, cc_max, T_pmax_dat, T_pmax_syn
+ !double precision :: tshift_f1f2, cc_max_f1f2
+ double precision, dimension(NPT) :: dtau_w, dlnA_w, err_dt, err_dlnA, syn_dtw, data_dtw
+ complex*16, dimension(NPT) :: trans_mtm
+ integer :: nlen, i_left, i_pmax_dat, i_pmax_syn, i_right, i_right0, istart, &
+ ipair, npairs, nwin, itmax
+ logical :: use_trace
+ !double precision :: trbdndw, a
+ !integer :: iord, passes
+
+ integer :: ipick_type
+ double precision :: T_surfacewaves
+
+ !********* PROGRAM STARTS HERE *********************
+
+ ! read in MEASUREMENT.PAR (see mt_sub.f90 and write_par_file.pl)
+ ! most variables are global (see mt_variables.f90)
+ call read_par_file(fstart0,fend0,tt,dtt,nn,chan)
+
+ ! uses weights to balance love and rayleigh measurements
+ ! we do a normalization of P_SV, P_SH, Love, Rayleigh with the number of measurement picks
+ if( DO_WEIGHTING ) then
+ call setup_weighting(chan)
+ endif
+
+ ! input file: MEASUREMENT.WINDOWS
+ open(11,file='MEASUREMENT.WINDOWS',status='old',iostat=ios)
+ if (ios /= 0) then ; print *, 'Error opening input file: MEASUREMENT WINDOWS' ; stop ; endif
+ read(11,*,iostat=ios) npairs
+ if (ios /= 0) then ; print *, 'Error reading number of pairs of data/syn' ; stop ; endif
+
+ print *, 'reading in the data and synthetics...'
+
+ ! output files
+ open(12,file='window_index',status='unknown',iostat=ios)
+ open(13,file='window_chi',status='unknown',iostat=ios)
+
+ nwin = 0
+ do ipair = 1, npairs
+
+ data(:) = 0.0
+ syn(:) = 0.0
+
+ adj_syn_all(:) = 0.0
+ recon_cc_all(:) = 0.0
+
+ ! reads in file names for data and synthetics
+ read(11,'(a)',iostat=ios) datafile
+ if (ios /= 0) then ; print *, 'Error reading windows file' ; stop ; endif
+ read(11,'(a)',iostat=ios) synfile
+ if (ios /= 0) then ; print *, 'Error reading windows file' ; stop ; endif
+
+ ! read data and syn
+ call drsac1(datafile,data,npt1,t01,dt1)
+ call drsac1(synfile,syn,npt2,t02,dt2)
+ !print *, npt1,t01,dt1,NDIM ! check: double precision
+
+ ! user output
+ print *
+ print *, 'data: ',trim(datafile)
+ print *, ' min/max: ',minval(data(:)),maxval(data(:))
+ !print *, ' ',data(1:5)
+
+ print *, 'syn: ',trim(synfile)
+ print *, ' min/max: ',minval(syn(:)),maxval(syn(:))
+ !print *, ' ',syn(1:5)
+
+ if (max(npt1,npt2) > NDIM) then
+ print *, 'Error: Too many number of points in data or syn'
+ stop
+ endif
+
+ ! check if t0 and dt match
+ if (abs(dt1-dt2) > TOL) then ; print *, 'Error: check if dt match' ; stop ; endif
+ dt = dt1
+ npts = min(npt1,npt2)
+
+ ! check
+ if (abs(t01-t02) > dt) then
+ print*,'data t0: ',t01
+ print*,'syn t0: ',t02
+ stop 'Check if t0 match'
+ else
+ print*,' time:',t01
+ print*,' dt:',dt
+ print*,' npts: ',npts
+ endif
+
+ ! apply bandpass filter to data and synthetics, if desired
+ ! http://www.iris.washington.edu/pipermail/sac-help/2008-March/000376.html
+ ! Access to the kidate, xapiir, and getfil is not simple and not
+ ! supported under the current state of the SAC code base.
+
+ t0 = t01
+ if(.not. RUN_BANDPASS) then
+ t0 = t01
+ else
+ !call interpolate_syn(syn,t02,dt,npt2,t01,dt,npts)
+ t0 = t01
+ call bandpass(data,npts,dt,fstart0,fend0)
+ endif
+
+ ! figure out station name, network name, component name, etc
+ call get_sacfile_header(trim(datafile),yr,jda,ho,mi,sec,net,sta, &
+ chan_dat,dist,az,baz,slat,slon)
+
+ ! theoretical surface wave arrival time
+ T_surfacewaves = dist / surface_vel
+
+ ! synthetics always have the form BH_ or LH_, but the data may not (HH_, LH_, BL_, etc).
+ cmp = chan_dat(3:3)
+ chan_syn = trim(chan)//trim(cmp)
+
+ file_prefix0 = trim(sta)//'.'//trim(net)//'.'//trim(chan_syn)
+ file_prefix2 = trim(OUT_DIR)//'/'//trim(file_prefix0)
+ print *
+ print *, trim(file_prefix2), ' --- '
+
+ ! note: MT measurement could revert to CC, but still keep the MT suffix
+ write(adj_file_prefix,'(a,i2.2)') trim(file_prefix2)//'.iker', imeas0
+!!$ if (imeas == 0) then
+!!$ adj_file_prefix = trim(file_prefix2) // '.ik'
+!!$ else if (imeas == 1) then
+!!$ adj_file_prefix = trim(file_prefix2) // '.mtm'
+!!$ else if (imeas == 2) then
+!!$ adj_file_prefix = trim(file_prefix2) // '.cc'
+!!$ else if (imeas == 3) then
+!!$ adj_file_prefix = trim(file_prefix2) // '.bdcc'
+!!$ else
+!!$ print *, 'imeas = ', imeas
+!!$ print *, 'Error: imeas must be 0, 1, 2, or 3'
+!!$ stop
+!!$ endif
+
+ ! reads number of measurement windows
+ read(11,*,iostat=ios) num_meas
+ if (ios /= 0) then ; print *, 'Error reading num_meas' ; stop ; endif
+
+ do j = 1, num_meas
+ ! reads in start and end time of measurement window
+ read(11,*,iostat=ios) tstart, tend
+ if (ios /= 0) then ; print *, 'Error reading tstart and tend' ; stop ; endif
+
+ ! checks start and end times of window compared to trace lengths
+ tstart = max(tstart,t0)
+ tend = min(tend, t0+(npts-1)*dt)
+ nlen = floor((tend-tstart)/dt) + 1 ! see subroutine interpolate_data_and_syn
+
+ ! body wave picks
+ ipick_type = 0
+ if( tend <= T_surfacewaves ) then
+ if( cmp(1:1) == "Z" ) ipick_type = P_SV_V
+ if( cmp(1:1) == "R" ) ipick_type = P_SV_R
+ if( cmp(1:1) == "T" ) ipick_type = SH_T
+ else
+ ! surface wave picks
+ if( cmp(1:1) == "Z" ) ipick_type = Rayleigh_V
+ if( cmp(1:1) == "R" ) ipick_type = Rayleigh_R
+ if( cmp(1:1) == "T" ) ipick_type = Love_T
+ endif
+
+ ! write values to output file
+ nwin = nwin + 1 ! overall window counter
+ write(12,'(a3,a8,a5,a5,3i5,2f12.3)') net,sta,chan_syn,chan_dat,nwin,ipair,j,tstart,tend
+
+ ! add taper type to file prefix
+ write(file_prefix,'(a,i2.2)') trim(file_prefix2)//'.', j
+ if (is_mtm == 1) then
+ measure_file_prefix = trim(file_prefix) // '.mtm' ! multitaper taper
+ elseif (is_mtm == 2) then
+ measure_file_prefix = trim(file_prefix) // '.ctp' ! cosine taper
+ else
+ measure_file_prefix = trim(file_prefix) // '.btp' ! boxcar taper
+ endif
+
+ print *
+ print *, ' Measurements No.', j, ' ... '
+
+ ! initialize the measurements
+ window_chi(:) = 0.
+
+ ! compute integrated waveform difference, normalized by duration of the record
+ ! NOTE: (1) this is for the FULL record, not the windowed record
+ ! (2) for comparison with waveform_chi, we include the 0.5 factor
+ ! (3) we might want to include dt as an integration factor (also for waveform_chi),
+ ! but the ratio (d-s)^2 / d^2 avoids the need for dt, nstep, or length of record
+ window_chi(17) = 0.5 * sum( data**2 )
+ window_chi(18) = 0.5 * sum( syn**2 )
+ window_chi(19) = 0.5 * sum( (data-syn)**2 )
+ window_chi(20) = npts*dt
+
+ ! get the starting frequency to avoid measuring long periods not present
+ !fstart = fstart0 ; fend = fend0
+ !call mt_measure_select_0(nlen,dt,i_left,i_right,fstart,fend,use_trace)
+
+ ! make measurements
+ ! also compute reconstructed synthetics for CC (and MT, if specified) measurements
+ call mt_measure(datafile,measure_file_prefix,data,syn,t0,dt,npts,tstart,tend,&
+ istart,data_dtw,syn_dtw,nlen,tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc,&
+ i_pmax_dat,i_pmax_syn,i_right0,trans_mtm,dtau_w,dlnA_w,sigma_dt,sigma_dlnA,err_dt,err_dlnA)
+ i_right = i_right0
+ i_left = 1
+
+ ! period of the max power of the synthetic record
+ T_pmax_dat = (dt*NPT) / dble(i_pmax_dat)
+ T_pmax_syn = (dt*NPT) / dble(i_pmax_syn)
+
+ ! adjust measurements for MT adjoint source
+ if (is_mtm == 1) then
+ fstart = fstart0 ; fend = fend0
+ call mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, &
+ dt,i_left,i_right,fstart,fend,use_trace)
+ print *, 'fstart0/fend0 :', fstart0, fend0
+ print *, 'fstart/fend :', fstart, fend
+ print *, 'Tpmax :', T_pmax_dat, T_pmax_syn
+
+ ! if MT measurement window is rejected by mt_measure_select, then use a CC measurement
+ if(.not. use_trace) then
+ !stop 'Check why this MT measurement was rejected'
+ print *, 'Reverting from multitaper measurement to cross-correlation measurement'
+ imeas = imeas0 - 2
+ is_mtm = 3
+ call mt_measure(datafile,measure_file_prefix,data,syn,t0,dt,npts,tstart,tend,istart,data_dtw,syn_dtw,nlen,&
+ tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc,&
+ i_pmax_dat,i_pmax_syn,i_right,trans_mtm,dtau_w,dlnA_w,sigma_dt,sigma_dlnA)
+ use_trace = .true.
+ endif
+
+ else
+ use_trace = .true.
+ endif
+
+ ! check that the CC measurements are within the specified input range
+ if (imeas >= 5) call cc_measure_select(tshift,dlnA,cc_max)
+
+ ! write frequency limits to file
+ if (OUTPUT_MEASUREMENT_FILES) then
+ df = 1./(dt*NPT)
+ open(71,file=trim(measure_file_prefix)//'.freq_limits')
+ write(71,'(6f18.8)') fstart0, fend0, df, i_right0*df, fstart, fend
+ close(71)
+ endif
+
+ ! compute adjoint sources and misfit function values and also the CC-reconstructed records
+ if (use_trace) then
+
+ ! banana-doughnut kernel (needs only synthetic trace)
+ if(imeas == 5 .and. trim(datafile) == trim(synfile) ) then
+ print*,'cross-correlation measurement:'
+ print*,' only synthetic file: ',trim(synfile)
+ print*,' without traveltime difference/uncertainty'
+ print*
+ ! uses imeas == 3 for adjoint sources without time shift and uncertainty scaling
+ ! (pure cross-correlation adjoint source for banana-doughnuts)
+ imeas = 3
+ endif
+
+ tr_chi = 0.0 ; am_chi = 0.0 ! must be initialized
+ call mt_adj(istart,data_dtw,syn_dtw,nlen,dt,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc,&
+ dtau_w,dlnA_w,err_dt,err_dlnA,sigma_dt,sigma_dlnA,i_left,i_right,&
+ window_chi,tr_adj_src,tr_chi,am_adj_src,am_chi)
+
+ ! KEY: write misfit function values to file (two for each window)
+ ! Here are the 20 columns of the vector window_chi
+ ! 1: MT-TT chi, 2: MT-dlnA chi, 3: XC-TT chi, 4: XC-dlnA chi
+ ! 5: MT-TT meas, 6: MT-dlnA meas, 7: XC-TT meas, 8: XC-dlnA meas
+ ! 9: MT-TT error, 10: MT-dlnA error, 11: XC-TT error, 12: XC-dlnA error
+ ! WINDOW : 13: data power, 14: syn power, 15: (data-syn) power, 16: window duration
+ ! FULL RECORD: 17: data power, 18: syn power, 19: (data-syn) power, 20: record duration
+ ! Example of a reduced file: awk '{print $2,$3,$4,$5,$6,$31,$32}' window_chi > window_chi_sub
+ write(13,'(a14,a8,a3,a5,i4,i4,2e14.6,20e14.6,2e14.6,2f14.6)') &
+ file_prefix0,sta,net,chan_syn,j,imeas,&
+ tstart,tend,window_chi(:),tr_chi,am_chi,T_pmax_dat,T_pmax_syn
+ print *, ' tr_chi = ', sngl(tr_chi), ' am_chi = ', sngl(am_chi)
+
+ ! uses weighting to balance love / rayleigh measurements
+ if( DO_WEIGHTING ) then
+ ! weights by transverse/radial/vertical
+ !if( cmp(1:1) == "T") then
+ ! tr_adj_src(:) = tr_adj_src(:) * weight_T
+ !else
+ ! if( cmp(1:1) == "R") then
+ ! tr_adj_src(:) = tr_adj_src(:) * weight_R
+ ! else
+ ! if( cmp(1:1) == "Z") then
+ ! tr_adj_src(:) = tr_adj_src(:) * weight_Z
+ ! endif
+ ! endif
+ !endif
+ ! weights by phase types
+ select case(ipick_type)
+ case( P_SV_V )
+ tr_adj_src(:) = tr_adj_src(:) * num_P_SV_V
+ case( P_SV_R )
+ tr_adj_src(:) = tr_adj_src(:) * num_P_SV_R
+ case( SH_T )
+ tr_adj_src(:) = tr_adj_src(:) * num_SH_T
+ case( Rayleigh_V )
+ tr_adj_src(:) = tr_adj_src(:) * num_Rayleigh_V
+ case( Rayleigh_R )
+ tr_adj_src(:) = tr_adj_src(:) * num_Rayleigh_R
+ case( Love_T )
+ tr_adj_src(:) = tr_adj_src(:) * num_Love_T
+ case default
+ stop 'error ipick_type unknown'
+ end select
+ endif
+
+ ! combine adjoint sources from different measurement windows
+ if (COMPUTE_ADJOINT_SOURCE) then
+ if (mod(imeas,2)==1) then
+ adj_syn_all(:) = adj_syn_all(:) + tr_adj_src(:) ! imeas = 1,3,5,7
+ else
+ adj_syn_all(:) = adj_syn_all(:) + am_adj_src(:) ! imeas = 2,4,6,8
+ endif
+ endif
+
+ ! combine CC-reconstructed records
+ recon_cc_all(istart:istart+nlen-1) = recon_cc_all(istart:istart+nlen-1) + syn_dtw_cc(1:nlen)
+
+ endif
+
+ ! CHT: (re-)set to multitaper parameters, if originally specified
+ if (is_mtm0 == 1) then
+ imeas = imeas0
+ is_mtm = is_mtm0
+ endif
+
+ enddo ! nmeas
+
+ !----------------------------
+ ! write out the adjoint source
+
+ if (COMPUTE_ADJOINT_SOURCE) then
+
+ ! OPTIONAL: A conservative choice is to filter the adjoint source,
+ ! since higher frequencies could enter from the tapering operations.
+ ! Note: time_window in mt_adj.f90 tapers the windows.
+
+ ! note also:
+ ! measurements are done on filtered synthetics F(s) and filtered data F(d), such that DeltaT
+ ! is given for filtered data & synthetics.
+ ! then kernels,
+ ! i.e. for a traveltime measurement: DeltaT = 1/N * int F(d/dt s) F(ds)
+ ! should contain this filter as well.
+ !
+ ! when we construct the adjoint source here,it is initially a filtered version
+ ! as well F(s_adj) since we use/depend on filtered synthetics F(s).
+ ! however, for kernel simulations, we do run with a reconstructed forward wavefield,
+ ! which is unfiltered (only filter there is by source half-time), but we want to convolve
+ ! K = int F*(s_adj) F(s)
+ ! using the same (bandpass) filter F() as used for filtereing data & synthetics in the meausurements
+ ! We can write the kernel expression as K = int F*{F* (s_adj)} s
+ ! thus we should apply the filter F() twice on the adjoint source
+ !
+ ! why is this important? the filter, like bandpassing, is usually acausal, that is, it can
+ ! introduce a slight phase-shift to the data. but, phase-shifts is what we are interested in
+ ! and invert for. so, filtering might affect our inversions...
+
+ ! we do use a bandpass filter here again on the adjoint source. this is slightly different
+ ! to the transfer function filter in SAC used initially to filter data & synthetics.
+ ! but this seems to be the best and fairly easy what we can do here...
+ call bandpass(adj_syn_all,npts,dt,fstart0,fend0)
+
+ ! cut and interpolate to match time-stepping for SEM
+ ! NOTE: This can leave a non-zero value to start the record,
+ ! which is NOT GOOD for the SEM simulation.
+ call interpolate_syn(adj_syn_all,t0,dt,npts,tt,dtt,nn)
+
+ ! Taper the start of the adjoint source, since cutting the record
+ ! may have left a non-zero value to start the record,
+ ! which is not good for the SEM simulation.
+ itmax = int(TSHORT/dtt)
+ call taper_start(adj_syn_all,nn,itmax)
+
+ ! output the adjoint source (or ray density) as ASCII or SAC format
+ print *, 'writing adjoint source to file for the full seismogram'
+ if( DO_RAY_DENSITY_SOURCE ) then
+ call dwascii(trim(adj_file_prefix)//'.density.adj',adj_syn_all,nn,tt,dtt)
+ else
+ call dwascii(trim(adj_file_prefix)//'.adj',adj_syn_all,nn,tt,dtt)
+ endif
+ !call dwsac1(trim(adj_file_prefix)//'.adj.sac',adj_syn_all,nn,tt,dtt)
+!!$ call dwrite_ascfile_f(trim(adj_file_prefix)//'.adj',tt,dtt,nn,adj_syn_all)
+!!$ !call dwrite_sacfile_f(trim(datafile),trim(adj_file_prefix)//'.adj',tt,nn,adj_syn_all)
+
+ endif
+
+ !----------------------------
+ ! write out the CC-reconstructed data from synthetics
+
+ ! cut and interpolate, then write ASCII file
+ !call interpolate_syn(recon_cc_all,t0,dt,npts,tt,dtt,nn)
+ !call dwrite_ascfile_f(trim(file_prefix2)//'.recon.cc',tt,dtt,nn,recon_cc_all)
+
+ ! write SAC file
+ call dwsac1(trim(file_prefix2)//'.recon.cc.sac',recon_cc_all,npts,t0,dt)
+
+ !if (nerr > 0) then ; print *, 'Error writing reconstructed CC file' ; stop ; endif
+ !call dwrite_sacfile_f(trim(datafile),trim(file_prefix2)//'.recon.cc',t0,npts,recon_cc_all)
+
+ enddo ! npairs
+
+ close(11) ! read: MEASUREMENT.WINDOWS
+ close(12) ! write: window_index
+ close(13) ! write: window_chi
+
+end program mt_measure_adj
+
+subroutine setup_weighting(chan_syn)
+ !
+ ! determines weights based on number of window picks on radial, transverse and vertical components
+ !
+ use mt_weighting
+
+ use mt_constants,only: NDIM
+ use mt_sub,only: get_sacfile_header,drsac1
+ use mt_sub2,only: TOL
+
+ implicit none
+ character(len=10) :: chan_syn
+
+ ! local parameters
+ integer :: npairs,ios,ipair,iposition,ipicks
+ character(len=150) :: datafile,synfile !,dummy
+ character(len=4) :: comp_T,comp_Z,comp_R
+ integer :: picks_T, picks_Z, picks_R,npicks
+ ! sac header information
+ integer :: yr,jda,ho,mi
+ double precision :: sec,dist,az,baz,slat,slon,T_surfacewaves
+ character(len=10) :: net,sta,chan_dat,chan,cmp
+ double precision :: t01, dt1, t02, dt2, t0, dt, tstart, tend
+ integer :: npt1, npt2, npts
+ double precision, dimension(NDIM) :: data, syn
+
+ ! initializes
+ picks_R = 0
+ picks_Z = 0
+ picks_T = 0
+
+ num_P_SV_V = 0.d0
+ num_P_SV_R = 0.d0
+ num_SH_T = 0.d0
+
+ num_Rayleigh_V = 0.d0
+ num_Rayleigh_R = 0.d0
+ num_Love_T = 0.d0
+
+ ! substrings (synthetics components)
+ comp_T = trim(chan_syn)//"T."
+ comp_R = trim(chan_syn)//"R."
+ comp_Z = trim(chan_syn)//"Z."
+
+ ! opens measurement windows
+ open(21,file='MEASUREMENT.WINDOWS',status='old',iostat=ios)
+ if (ios /= 0) then ; print *, 'Error opening input file: MEASUREMENT WINDOWS' ; stop ; endif
+ read(21,*,iostat=ios) npairs
+ if (ios /= 0) then ; print *, 'Error reading number of pairs of data/syn' ; stop ; endif
+
+ ! loops through windows
+ do ipair=1,npairs
+
+ ! reads in file names
+ read(21,'(a)',iostat=ios) datafile
+ if (ios /= 0) then ; print *, 'Error reading windows datafile' ; stop ; endif
+ read(21,'(a)',iostat=ios) synfile
+ if (ios /= 0) then ; print *, 'Error reading windows synfile' ; stop ; endif
+
+ ! read data and syn
+ call drsac1(datafile,data,npt1,t01,dt1)
+ call drsac1(synfile,syn,npt2,t02,dt2)
+
+ if (max(npt1,npt2) > NDIM) then
+ print *, 'Error: Too many number of points in data or syn'
+ stop
+ endif
+ ! check if t0 and dt match
+ if (abs(dt1-dt2) > TOL) then ; print *, 'Error: check if dt match' ; stop ; endif
+ dt = dt1
+ npts = min(npt1,npt2)
+ if (abs(t01-t02) > dt) then
+ print*,'data t0: ',t01
+ print*,'syn t0: ',t02
+ stop 'Check if t0 match'
+ endif
+ t0 = t01
+
+ ! figure out station name, network name, component name, etc
+ call get_sacfile_header(trim(datafile),yr,jda,ho,mi,sec,net,sta, &
+ chan_dat,dist,az,baz,slat,slon)
+ chan = chan_dat
+ cmp = chan_dat(3:3)
+
+
+ ! theoretical surface wave arrival time
+ T_surfacewaves = dist / surface_vel
+
+ ! debug output
+ !print*
+ !print*,'debug: '
+ !print*,' yr,jda,ho,mi,sec : ',yr,jda,ho,mi,sec
+ !print*,' net,sta,chan_dat : ',net,sta,chan_dat
+ !print*,' dist,az,baz,slat,slon : ',dist,az,baz,slat,slon
+ !print*,' cmp = ',cmp
+ !print*,' dist = ',dist
+ !print*,' T_surfacewaves = ',T_surfacewaves
+ !print*
+
+ ! reads in window picks
+ read(21,*,iostat=ios) npicks
+ if (ios /= 0) then ; print *, 'Error reading windows npicks' ; stop ; endif
+
+ ! loops/skips over picks (start/end times)
+ do ipicks=1,npicks
+ !read(21,'(a)',iostat=ios) dummy
+ !if (ios /= 0) then ; print *, 'Error reading window pick' ; stop ; endif
+
+ read(21,*,iostat=ios) tstart, tend
+ if (ios /= 0) then ; print *, 'Error reading window pick: tstart and tend' ; stop ; endif
+
+ tstart = max(tstart,t0)
+ tend = min(tend, t0+(npts-1)*dt)
+ !nlen = floor((tend-tstart)/dt) + 1 ! see subroutine interpolate_data_and_syn
+
+ ! body wave picks
+ if( tend <= T_surfacewaves ) then
+ if( cmp(1:1) == "Z" ) num_P_SV_V = num_P_SV_V + 1.d0
+ if( cmp(1:1) == "R" ) num_P_SV_R = num_P_SV_R + 1.d0
+ if( cmp(1:1) == "T" ) num_SH_T = num_SH_T + 1.d0
+ else
+ ! surface wave picks
+ if( cmp(1:1) == "Z" ) num_Rayleigh_V = num_Rayleigh_V + 1.d0
+ if( cmp(1:1) == "R" ) num_Rayleigh_R = num_Rayleigh_R + 1.d0
+ if( cmp(1:1) == "T" ) num_Love_T = num_Love_T + 1.d0
+ endif
+
+ enddo
+
+ ! determines all picks on a trace component
+ ! transverse
+ iposition = INDEX( trim(synfile), comp_T, .false. )
+ if( iposition > 3 .and. iposition < len_trim( synfile) ) then
+ if( cmp(1:1) /= "T" ) stop 'error T component pick'
+ picks_T = picks_T + npicks
+ else
+ ! radial
+ iposition = INDEX( trim(synfile), comp_R, .false. )
+ if( iposition > 3 .and. iposition < len_trim( synfile) ) then
+ if( cmp(1:1) /= "R" ) stop 'error R component pick'
+ picks_R = picks_R + npicks
+ else
+ ! vertical
+ iposition = INDEX( trim(synfile), comp_Z, .false. )
+ if( iposition > 3 .and. iposition < len_trim( synfile) ) then
+ if( cmp(1:1) /= "Z" ) stop 'error Z component pick'
+ picks_Z = picks_Z + npicks
+ endif
+ endif
+ endif
+
+ enddo
+ close(21)
+
+
+ ! check with total number of picks per component
+ if( nint( num_P_SV_R + num_Rayleigh_R ) /= picks_R ) stop 'error R picks'
+ if( nint( num_P_SV_V + num_Rayleigh_V ) /= picks_Z ) stop 'error Z picks'
+ if( nint( num_SH_T + num_Love_T ) /= picks_T ) stop 'error T picks'
+
+ if( DO_WEIGHTING ) then
+ print*
+ print*,'weighting measurements: '
+ print*,' picks T:',picks_T
+ print*,' picks R:',picks_R
+ print*,' picks Z:',picks_Z
+ print*
+ print*,' picks P_SV_R: ',nint(num_P_SV_R)
+ print*,' picks P_SV_V: ',nint(num_P_SV_V)
+ print*,' picks SH_T : ',nint(num_SH_T)
+ print*,' picks Rayleigh_R: ',nint(num_Rayleigh_R)
+ print*,' picks Rayleigh_V: ',nint(num_Rayleigh_V)
+ print*,' picks Love_T : ',nint(num_Love_T)
+ print*
+ endif
+
+
+ ! sets up weights based on picks
+ weight_T = 1.0d0
+ weight_R = 1.0d0
+ weight_Z = 1.0d0
+
+ ! weighting tries to balance love waves (tranverse) versus rayleigh waves (radial + vertical)
+ !if( picks_T > 0 ) then
+ ! if( picks_R + picks_Z > 0 ) weight_T = dble(picks_R + picks_Z)/dble(picks_T)
+ !endif
+
+ ! use normalization as weights
+ if( picks_T > 0 ) weight_T = 1.d0 / picks_T
+ if( picks_R > 0 ) weight_R = 1.d0 / picks_R
+ if( picks_Z > 0 ) weight_Z = 1.d0 / picks_Z
+
+ ! use normalization
+ if( num_P_SV_R > 0. ) num_P_SV_R = 1.d0 / num_P_SV_R
+ if( num_P_SV_V > 0. ) num_P_SV_V = 1.d0 / num_P_SV_V
+ if( num_SH_T > 0. ) num_SH_T = 1.d0 / num_SH_T
+ if( num_Rayleigh_R > 0. ) num_Rayleigh_R = 1.d0 / num_Rayleigh_R
+ if( num_Rayleigh_V > 0. ) num_Rayleigh_V = 1.d0 / num_Rayleigh_V
+ if( num_Love_T > 0. ) num_Love_T = 1.d0 / num_Love_T
+
+ if( DO_WEIGHTING ) then
+ print*,' weight num_P_SV_R:',num_P_SV_R
+ print*,' weight num_P_SV_V:',num_P_SV_V
+ print*,' weight num_SH_T :',num_SH_T
+ print*,' weight num_Rayleigh_R:',num_Rayleigh_R
+ print*,' weight num_Rayleigh_V:',num_Rayleigh_V
+ print*,' weight num_Love_T :',num_Love_T
+ print*
+ endif
+
+end subroutine
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/mt_constants.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/mt_constants.f90 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/mt_constants.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,36 +0,0 @@
-module mt_constants
-
- ! number of entries in window_chi output file
- integer, parameter :: N_MEASUREMENT = 5
- integer, parameter :: NCHI = 3*(N_MEASUREMENT-1) + 8
-
- ! constants
- double precision, parameter :: PI = 3.141592653589793d+00
- double precision, parameter :: TWOPI = 2.0 * PI
- complex*16, parameter :: CCI = cmplx(0.,1.)
- double precision, parameter :: LARGE_VAL = 1.0d8
-
- ! FFT parameters
- integer, parameter :: LNPT = 15, NPT = 2**LNPT, NDIM = 80000
- double precision, parameter :: FORWARD_FFT = 1.0
- double precision, parameter :: REVERSE_FFT = -1.0
-
- ! phase correction control parameters, set this between (PI, 2PI),
- ! use a higher value for conservative phase wrapping
- double precision, parameter :: PHASE_STEP = 1.5 * PI
-
- ! filter parameters for xapiir bandpass subroutine (filter type is BP)
- ! (These should match the filter used in pre-processing.)
- double precision, parameter :: TRBDNDW = 0.3
- double precision, parameter :: APARM = 30.
- integer, parameter :: IORD = 4
- integer, parameter :: PASSES = 2
-
- ! takes waveform of first trace dat_dtw, without taking the difference waveform to the second trace syn_dtw
- ! this is useful to cissor out later reflections which appear in data (no synthetics needed)
- logical:: NO_WAVEFORM_DIFFERENCE = .false.
-
- ! constructs adjoint sources for a "ray density" kernel, where all misfits are equal to one
- logical:: DO_RAY_DENSITY_SOURCE = .false.
-
-end module mt_constants
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/mt_measure_adj.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/mt_measure_adj.f90 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/mt_measure_adj.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,665 +0,0 @@
-program mt_measure_adj
-
- ! main program that calls the subroutines to make the MT measurements
- ! and compute the corresponding adjoint sources
-
- ! input parameter:
- ! 1. imeas = 1, normalized waveform difference. Adjoint source is constructed from the data
- ! only, with the form −d(t)/ || d(t) || 2
- ! 2. imeas = 2, waveform difference, s(t) − d(t).
- ! 3. imeas = 3, cross-correlation traveltime difference for a (banana-doughtnut) sensitivity ker-
- ! nel. The measurement between data and synthetics is not used in constructing the adjoint
- ! source.
- ! 4. imeas = 4, amplitude difference for a (banana-doughtnut) sensitivity kernel. The measure-
- ! ment between data and synthetics is not used in constructing the adjoint source.
- ! 5. imeas = 5, cross-correlation traveltime difference for an event kernel. The measurement
- ! between data and synthetics is used in constructing the adjoint source.
- ! 6. imeas = 6, amplitude difference for an event kernel. The measurement between data and
- ! synthetics is used in constructing the adjoint source.
- ! 7. imeas = 7, multitaper traveltime difference for an event kernel. The measurement between
- ! data and synthetics is used in constructing the adjoint source. See multitaper_notes.pdf.
- ! 8. imeas = 8, multitaper ampltidue difference for an event kernel. The measurement between
- ! data and synthetics is used in constructing the adjoint source. See multitaper_notes.pdf.
-
- use mt_variables
- use mt_constants
- use ascii_rw ! dwascii()
- use mt_sub2 ! fft(), fftinv()
- use mt_sub ! mt_measure(), mt_adj()
- use mt_weighting
-
- implicit none
-
- character(len=150) :: datafile,synfile,file_prefix,file_prefix0,file_prefix2,measure_file_prefix,adj_file_prefix
- integer :: num_meas, j, ios, npt1, npt2, npts, nn
- double precision, dimension(NDIM) :: data, syn, adj_syn_all, tr_adj_src, am_adj_src, recon_cc_all, syn_dtw_cc
- double precision :: t01, dt1, t02, dt2, t0, dt, tstart, tend, tt, dtt, df
- double precision, dimension(NCHI) :: window_chi
- double precision :: fend0, fstart0, fend, fstart
- !double precision :: TSHORT, TLONG ! mtm_variables.f90
-
- ! sac header information
- integer :: yr,jda,ho,mi
- double precision :: sec,dist,az,baz,slat,slon
- character(len=10) :: net,sta,chan_dat,chan,cmp,chan_syn
- double precision :: tshift, sigma_dt_cc, dlnA, sigma_dlnA_cc, sigma_dt, sigma_dlnA
- double precision :: tr_chi, am_chi, cc_max, T_pmax_dat, T_pmax_syn
- !double precision :: tshift_f1f2, cc_max_f1f2
- double precision, dimension(NPT) :: dtau_w, dlnA_w, err_dt, err_dlnA, syn_dtw, data_dtw
- complex*16, dimension(NPT) :: trans_mtm
- integer :: nlen, i_left, i_pmax_dat, i_pmax_syn, i_right, i_right0, istart, &
- ipair, npairs, nwin, itmax
- logical :: use_trace
- !double precision :: trbdndw, a
- !integer :: iord, passes
-
- integer :: ipick_type
- double precision :: T_surfacewaves
-
- !********* PROGRAM STARTS HERE *********************
-
- ! read in MEASUREMENT.PAR (see mt_sub.f90 and write_par_file.pl)
- ! most variables are global (see mt_variables.f90)
- call read_par_file(fstart0,fend0,tt,dtt,nn,chan)
-
- ! uses weights to balance love and rayleigh measurements
- ! we do a normalization of P_SV, P_SH, Love, Rayleigh with the number of measurement picks
- if( DO_WEIGHTING ) then
- call setup_weighting(chan)
- endif
-
- ! input file: MEASUREMENT.WINDOWS
- open(11,file='MEASUREMENT.WINDOWS',status='old',iostat=ios)
- if (ios /= 0) then ; print *, 'Error opening input file: MEASUREMENT WINDOWS' ; stop ; endif
- read(11,*,iostat=ios) npairs
- if (ios /= 0) then ; print *, 'Error reading number of pairs of data/syn' ; stop ; endif
-
- print *, 'reading in the data and synthetics...'
-
- ! output files
- open(12,file='window_index',status='unknown',iostat=ios)
- open(13,file='window_chi',status='unknown',iostat=ios)
-
- nwin = 0
- do ipair = 1, npairs
-
- data(:) = 0.0
- syn(:) = 0.0
-
- adj_syn_all(:) = 0.0
- recon_cc_all(:) = 0.0
-
- ! reads in file names for data and synthetics
- read(11,'(a)',iostat=ios) datafile
- if (ios /= 0) then ; print *, 'Error reading windows file' ; stop ; endif
- read(11,'(a)',iostat=ios) synfile
- if (ios /= 0) then ; print *, 'Error reading windows file' ; stop ; endif
-
- ! read data and syn
- call drsac1(datafile,data,npt1,t01,dt1)
- call drsac1(synfile,syn,npt2,t02,dt2)
- !print *, npt1,t01,dt1,NDIM ! check: double precision
-
- ! user output
- print *
- print *, 'data: ',trim(datafile)
- print *, ' min/max: ',minval(data(:)),maxval(data(:))
- !print *, ' ',data(1:5)
-
- print *, 'syn: ',trim(synfile)
- print *, ' min/max: ',minval(syn(:)),maxval(syn(:))
- !print *, ' ',syn(1:5)
-
- if (max(npt1,npt2) > NDIM) then
- print *, 'Error: Too many number of points in data or syn'
- stop
- endif
-
- ! check if t0 and dt match
- if (abs(dt1-dt2) > TOL) then ; print *, 'Error: check if dt match' ; stop ; endif
- dt = dt1
- npts = min(npt1,npt2)
-
- ! check
- if (abs(t01-t02) > dt) then
- print*,'data t0: ',t01
- print*,'syn t0: ',t02
- stop 'Check if t0 match'
- else
- print*,' time:',t01
- print*,' dt:',dt
- print*,' npts: ',npts
- endif
-
- ! apply bandpass filter to data and synthetics, if desired
- ! http://www.iris.washington.edu/pipermail/sac-help/2008-March/000376.html
- ! Access to the kidate, xapiir, and getfil is not simple and not
- ! supported under the current state of the SAC code base.
-
- t0 = t01
- if(.not. RUN_BANDPASS) then
- t0 = t01
- else
- !call interpolate_syn(syn,t02,dt,npt2,t01,dt,npts)
- t0 = t01
- call bandpass(data,npts,dt,fstart0,fend0)
- endif
-
- ! figure out station name, network name, component name, etc
- call get_sacfile_header(trim(datafile),yr,jda,ho,mi,sec,net,sta, &
- chan_dat,dist,az,baz,slat,slon)
-
- ! theoretical surface wave arrival time
- T_surfacewaves = dist / surface_vel
-
- ! synthetics always have the form BH_ or LH_, but the data may not (HH_, LH_, BL_, etc).
- cmp = chan_dat(3:3)
- chan_syn = trim(chan)//trim(cmp)
-
- file_prefix0 = trim(sta)//'.'//trim(net)//'.'//trim(chan_syn)
- file_prefix2 = trim(OUT_DIR)//'/'//trim(file_prefix0)
- print *
- print *, trim(file_prefix2), ' --- '
-
- ! note: MT measurement could revert to CC, but still keep the MT suffix
- write(adj_file_prefix,'(a,i2.2)') trim(file_prefix2)//'.iker', imeas0
-!!$ if (imeas == 0) then
-!!$ adj_file_prefix = trim(file_prefix2) // '.ik'
-!!$ else if (imeas == 1) then
-!!$ adj_file_prefix = trim(file_prefix2) // '.mtm'
-!!$ else if (imeas == 2) then
-!!$ adj_file_prefix = trim(file_prefix2) // '.cc'
-!!$ else if (imeas == 3) then
-!!$ adj_file_prefix = trim(file_prefix2) // '.bdcc'
-!!$ else
-!!$ print *, 'imeas = ', imeas
-!!$ print *, 'Error: imeas must be 0, 1, 2, or 3'
-!!$ stop
-!!$ endif
-
- ! reads number of measurement windows
- read(11,*,iostat=ios) num_meas
- if (ios /= 0) then ; print *, 'Error reading num_meas' ; stop ; endif
-
- do j = 1, num_meas
- ! reads in start and end time of measurement window
- read(11,*,iostat=ios) tstart, tend
- if (ios /= 0) then ; print *, 'Error reading tstart and tend' ; stop ; endif
-
- ! checks start and end times of window compared to trace lengths
- tstart = max(tstart,t0)
- tend = min(tend, t0+(npts-1)*dt)
- nlen = floor((tend-tstart)/dt) + 1 ! see subroutine interpolate_data_and_syn
-
- ! body wave picks
- ipick_type = 0
- if( tend <= T_surfacewaves ) then
- if( cmp(1:1) == "Z" ) ipick_type = P_SV_V
- if( cmp(1:1) == "R" ) ipick_type = P_SV_R
- if( cmp(1:1) == "T" ) ipick_type = SH_T
- else
- ! surface wave picks
- if( cmp(1:1) == "Z" ) ipick_type = Rayleigh_V
- if( cmp(1:1) == "R" ) ipick_type = Rayleigh_R
- if( cmp(1:1) == "T" ) ipick_type = Love_T
- endif
-
- ! write values to output file
- nwin = nwin + 1 ! overall window counter
- write(12,'(a3,a8,a5,a5,3i5,2f12.3)') net,sta,chan_syn,chan_dat,nwin,ipair,j,tstart,tend
-
- ! add taper type to file prefix
- write(file_prefix,'(a,i2.2)') trim(file_prefix2)//'.', j
- if (is_mtm == 1) then
- measure_file_prefix = trim(file_prefix) // '.mtm' ! multitaper taper
- elseif (is_mtm == 2) then
- measure_file_prefix = trim(file_prefix) // '.ctp' ! cosine taper
- else
- measure_file_prefix = trim(file_prefix) // '.btp' ! boxcar taper
- endif
-
- print *
- print *, ' Measurements No.', j, ' ... '
-
- ! initialize the measurements
- window_chi(:) = 0.
-
- ! compute integrated waveform difference, normalized by duration of the record
- ! NOTE: (1) this is for the FULL record, not the windowed record
- ! (2) for comparison with waveform_chi, we include the 0.5 factor
- ! (3) we might want to include dt as an integration factor (also for waveform_chi),
- ! but the ratio (d-s)^2 / d^2 avoids the need for dt, nstep, or length of record
- window_chi(17) = 0.5 * sum( data**2 )
- window_chi(18) = 0.5 * sum( syn**2 )
- window_chi(19) = 0.5 * sum( (data-syn)**2 )
- window_chi(20) = npts*dt
-
- ! get the starting frequency to avoid measuring long periods not present
- !fstart = fstart0 ; fend = fend0
- !call mt_measure_select_0(nlen,dt,i_left,i_right,fstart,fend,use_trace)
-
- ! make measurements
- ! also compute reconstructed synthetics for CC (and MT, if specified) measurements
- call mt_measure(datafile,measure_file_prefix,data,syn,t0,dt,npts,tstart,tend,&
- istart,data_dtw,syn_dtw,nlen,tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc,&
- i_pmax_dat,i_pmax_syn,i_right0,trans_mtm,dtau_w,dlnA_w,sigma_dt,sigma_dlnA,err_dt,err_dlnA)
- i_right = i_right0
- i_left = 1
-
- ! period of the max power of the synthetic record
- T_pmax_dat = (dt*NPT) / dble(i_pmax_dat)
- T_pmax_syn = (dt*NPT) / dble(i_pmax_syn)
-
- ! adjust measurements for MT adjoint source
- if (is_mtm == 1) then
- fstart = fstart0 ; fend = fend0
- call mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, &
- dt,i_left,i_right,fstart,fend,use_trace)
- print *, 'fstart0/fend0 :', fstart0, fend0
- print *, 'fstart/fend :', fstart, fend
- print *, 'Tpmax :', T_pmax_dat, T_pmax_syn
-
- ! if MT measurement window is rejected by mt_measure_select, then use a CC measurement
- if(.not. use_trace) then
- !stop 'Check why this MT measurement was rejected'
- print *, 'Reverting from multitaper measurement to cross-correlation measurement'
- imeas = imeas0 - 2
- is_mtm = 3
- call mt_measure(datafile,measure_file_prefix,data,syn,t0,dt,npts,tstart,tend,istart,data_dtw,syn_dtw,nlen,&
- tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc,&
- i_pmax_dat,i_pmax_syn,i_right,trans_mtm,dtau_w,dlnA_w,sigma_dt,sigma_dlnA)
- use_trace = .true.
- endif
-
- else
- use_trace = .true.
- endif
-
- ! check that the CC measurements are within the specified input range
- if (imeas >= 5) call cc_measure_select(tshift,dlnA,cc_max)
-
- ! write frequency limits to file
- if (OUTPUT_MEASUREMENT_FILES) then
- df = 1./(dt*NPT)
- open(71,file=trim(measure_file_prefix)//'.freq_limits')
- write(71,'(6f18.8)') fstart0, fend0, df, i_right0*df, fstart, fend
- close(71)
- endif
-
- ! compute adjoint sources and misfit function values and also the CC-reconstructed records
- if (use_trace) then
-
- ! banana-doughnut kernel (needs only synthetic trace)
- if(imeas == 5 .and. trim(datafile) == trim(synfile) ) then
- print*,'cross-correlation measurement:'
- print*,' only synthetic file: ',trim(synfile)
- print*,' without traveltime difference/uncertainty'
- print*
- ! uses imeas == 3 for adjoint sources without time shift and uncertainty scaling
- ! (pure cross-correlation adjoint source for banana-doughnuts)
- imeas = 3
- endif
-
- tr_chi = 0.0 ; am_chi = 0.0 ! must be initialized
- call mt_adj(istart,data_dtw,syn_dtw,nlen,dt,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc,&
- dtau_w,dlnA_w,err_dt,err_dlnA,sigma_dt,sigma_dlnA,i_left,i_right,&
- window_chi,tr_adj_src,tr_chi,am_adj_src,am_chi)
-
- ! KEY: write misfit function values to file (two for each window)
- ! Here are the 20 columns of the vector window_chi
- ! 1: MT-TT chi, 2: MT-dlnA chi, 3: XC-TT chi, 4: XC-dlnA chi
- ! 5: MT-TT meas, 6: MT-dlnA meas, 7: XC-TT meas, 8: XC-dlnA meas
- ! 9: MT-TT error, 10: MT-dlnA error, 11: XC-TT error, 12: XC-dlnA error
- ! WINDOW : 13: data power, 14: syn power, 15: (data-syn) power, 16: window duration
- ! FULL RECORD: 17: data power, 18: syn power, 19: (data-syn) power, 20: record duration
- ! Example of a reduced file: awk '{print $2,$3,$4,$5,$6,$31,$32}' window_chi > window_chi_sub
- write(13,'(a14,a8,a3,a5,i4,i4,2e14.6,20e14.6,2e14.6,2f14.6)') &
- file_prefix0,sta,net,chan_syn,j,imeas,&
- tstart,tend,window_chi(:),tr_chi,am_chi,T_pmax_dat,T_pmax_syn
- print *, ' tr_chi = ', sngl(tr_chi), ' am_chi = ', sngl(am_chi)
-
- ! uses weighting to balance love / rayleigh measurements
- if( DO_WEIGHTING ) then
- ! weights by transverse/radial/vertical
- !if( cmp(1:1) == "T") then
- ! tr_adj_src(:) = tr_adj_src(:) * weight_T
- !else
- ! if( cmp(1:1) == "R") then
- ! tr_adj_src(:) = tr_adj_src(:) * weight_R
- ! else
- ! if( cmp(1:1) == "Z") then
- ! tr_adj_src(:) = tr_adj_src(:) * weight_Z
- ! endif
- ! endif
- !endif
- ! weights by phase types
- select case(ipick_type)
- case( P_SV_V )
- tr_adj_src(:) = tr_adj_src(:) * num_P_SV_V
- case( P_SV_R )
- tr_adj_src(:) = tr_adj_src(:) * num_P_SV_R
- case( SH_T )
- tr_adj_src(:) = tr_adj_src(:) * num_SH_T
- case( Rayleigh_V )
- tr_adj_src(:) = tr_adj_src(:) * num_Rayleigh_V
- case( Rayleigh_R )
- tr_adj_src(:) = tr_adj_src(:) * num_Rayleigh_R
- case( Love_T )
- tr_adj_src(:) = tr_adj_src(:) * num_Love_T
- case default
- stop 'error ipick_type unknown'
- end select
- endif
-
- ! combine adjoint sources from different measurement windows
- if (COMPUTE_ADJOINT_SOURCE) then
- if (mod(imeas,2)==1) then
- adj_syn_all(:) = adj_syn_all(:) + tr_adj_src(:) ! imeas = 1,3,5,7
- else
- adj_syn_all(:) = adj_syn_all(:) + am_adj_src(:) ! imeas = 2,4,6,8
- endif
- endif
-
- ! combine CC-reconstructed records
- recon_cc_all(istart:istart+nlen-1) = recon_cc_all(istart:istart+nlen-1) + syn_dtw_cc(1:nlen)
-
- endif
-
- ! CHT: (re-)set to multitaper parameters, if originally specified
- if (is_mtm0 == 1) then
- imeas = imeas0
- is_mtm = is_mtm0
- endif
-
- enddo ! nmeas
-
- !----------------------------
- ! write out the adjoint source
-
- if (COMPUTE_ADJOINT_SOURCE) then
-
- ! OPTIONAL: A conservative choice is to filter the adjoint source,
- ! since higher frequencies could enter from the tapering operations.
- ! Note: time_window in mt_adj.f90 tapers the windows.
-
- ! note also:
- ! measurements are done on filtered synthetics F(s) and filtered data F(d), such that DeltaT
- ! is given for filtered data & synthetics.
- ! then kernels,
- ! i.e. for a traveltime measurement: DeltaT = 1/N * int F(d/dt s) F(ds)
- ! should contain this filter as well.
- !
- ! when we construct the adjoint source here,it is initially a filtered version
- ! as well F(s_adj) since we use/depend on filtered synthetics F(s).
- ! however, for kernel simulations, we do run with a reconstructed forward wavefield,
- ! which is unfiltered (only filter there is by source half-time), but we want to convolve
- ! K = int F*(s_adj) F(s)
- ! using the same (bandpass) filter F() as used for filtereing data & synthetics in the meausurements
- ! We can write the kernel expression as K = int F*{F* (s_adj)} s
- ! thus we should apply the filter F() twice on the adjoint source
- !
- ! why is this important? the filter, like bandpassing, is usually acausal, that is, it can
- ! introduce a slight phase-shift to the data. but, phase-shifts is what we are interested in
- ! and invert for. so, filtering might affect our inversions...
-
- ! we do use a bandpass filter here again on the adjoint source. this is slightly different
- ! to the transfer function filter in SAC used initially to filter data & synthetics.
- ! but this seems to be the best and fairly easy what we can do here...
- call bandpass(adj_syn_all,npts,dt,fstart0,fend0)
-
- ! cut and interpolate to match time-stepping for SEM
- ! NOTE: This can leave a non-zero value to start the record,
- ! which is NOT GOOD for the SEM simulation.
- call interpolate_syn(adj_syn_all,t0,dt,npts,tt,dtt,nn)
-
- ! Taper the start of the adjoint source, since cutting the record
- ! may have left a non-zero value to start the record,
- ! which is not good for the SEM simulation.
- itmax = int(TSHORT/dtt)
- call taper_start(adj_syn_all,nn,itmax)
-
- ! output the adjoint source (or ray density) as ASCII or SAC format
- print *, 'writing adjoint source to file for the full seismogram'
- if( DO_RAY_DENSITY_SOURCE ) then
- call dwascii(trim(adj_file_prefix)//'.density.adj',adj_syn_all,nn,tt,dtt)
- else
- call dwascii(trim(adj_file_prefix)//'.adj',adj_syn_all,nn,tt,dtt)
- endif
- !call dwsac1(trim(adj_file_prefix)//'.adj.sac',adj_syn_all,nn,tt,dtt)
-!!$ call dwrite_ascfile_f(trim(adj_file_prefix)//'.adj',tt,dtt,nn,adj_syn_all)
-!!$ !call dwrite_sacfile_f(trim(datafile),trim(adj_file_prefix)//'.adj',tt,nn,adj_syn_all)
-
- endif
-
- !----------------------------
- ! write out the CC-reconstructed data from synthetics
-
- ! cut and interpolate, then write ASCII file
- !call interpolate_syn(recon_cc_all,t0,dt,npts,tt,dtt,nn)
- !call dwrite_ascfile_f(trim(file_prefix2)//'.recon.cc',tt,dtt,nn,recon_cc_all)
-
- ! write SAC file
- call dwsac1(trim(file_prefix2)//'.recon.cc.sac',recon_cc_all,npts,t0,dt)
-
- !if (nerr > 0) then ; print *, 'Error writing reconstructed CC file' ; stop ; endif
- !call dwrite_sacfile_f(trim(datafile),trim(file_prefix2)//'.recon.cc',t0,npts,recon_cc_all)
-
- enddo ! npairs
-
- close(11) ! read: MEASUREMENT.WINDOWS
- close(12) ! write: window_index
- close(13) ! write: window_chi
-
-end program mt_measure_adj
-
-subroutine setup_weighting(chan_syn)
- !
- ! determines weights based on number of window picks on radial, transverse and vertical components
- !
- use mt_weighting
-
- use mt_constants,only: NDIM
- use mt_sub,only: get_sacfile_header,drsac1
- use mt_sub2,only: TOL
-
- implicit none
- character(len=10) :: chan_syn
-
- ! local parameters
- integer :: npairs,ios,ipair,iposition,ipicks
- character(len=150) :: datafile,synfile !,dummy
- character(len=4) :: comp_T,comp_Z,comp_R
- integer :: picks_T, picks_Z, picks_R,npicks
- ! sac header information
- integer :: yr,jda,ho,mi
- double precision :: sec,dist,az,baz,slat,slon,T_surfacewaves
- character(len=10) :: net,sta,chan_dat,chan,cmp
- double precision :: t01, dt1, t02, dt2, t0, dt, tstart, tend
- integer :: npt1, npt2, npts
- double precision, dimension(NDIM) :: data, syn
-
- ! initializes
- picks_R = 0
- picks_Z = 0
- picks_T = 0
-
- num_P_SV_V = 0.d0
- num_P_SV_R = 0.d0
- num_SH_T = 0.d0
-
- num_Rayleigh_V = 0.d0
- num_Rayleigh_R = 0.d0
- num_Love_T = 0.d0
-
- ! substrings (synthetics components)
- comp_T = trim(chan_syn)//"T."
- comp_R = trim(chan_syn)//"R."
- comp_Z = trim(chan_syn)//"Z."
-
- ! opens measurement windows
- open(21,file='MEASUREMENT.WINDOWS',status='old',iostat=ios)
- if (ios /= 0) then ; print *, 'Error opening input file: MEASUREMENT WINDOWS' ; stop ; endif
- read(21,*,iostat=ios) npairs
- if (ios /= 0) then ; print *, 'Error reading number of pairs of data/syn' ; stop ; endif
-
- ! loops through windows
- do ipair=1,npairs
-
- ! reads in file names
- read(21,'(a)',iostat=ios) datafile
- if (ios /= 0) then ; print *, 'Error reading windows datafile' ; stop ; endif
- read(21,'(a)',iostat=ios) synfile
- if (ios /= 0) then ; print *, 'Error reading windows synfile' ; stop ; endif
-
- ! read data and syn
- call drsac1(datafile,data,npt1,t01,dt1)
- call drsac1(synfile,syn,npt2,t02,dt2)
-
- if (max(npt1,npt2) > NDIM) then
- print *, 'Error: Too many number of points in data or syn'
- stop
- endif
- ! check if t0 and dt match
- if (abs(dt1-dt2) > TOL) then ; print *, 'Error: check if dt match' ; stop ; endif
- dt = dt1
- npts = min(npt1,npt2)
- if (abs(t01-t02) > dt) then
- print*,'data t0: ',t01
- print*,'syn t0: ',t02
- stop 'Check if t0 match'
- endif
- t0 = t01
-
- ! figure out station name, network name, component name, etc
- call get_sacfile_header(trim(datafile),yr,jda,ho,mi,sec,net,sta, &
- chan_dat,dist,az,baz,slat,slon)
- chan = chan_dat
- cmp = chan_dat(3:3)
-
-
- ! theoretical surface wave arrival time
- T_surfacewaves = dist / surface_vel
-
- ! debug output
- !print*
- !print*,'debug: '
- !print*,' yr,jda,ho,mi,sec : ',yr,jda,ho,mi,sec
- !print*,' net,sta,chan_dat : ',net,sta,chan_dat
- !print*,' dist,az,baz,slat,slon : ',dist,az,baz,slat,slon
- !print*,' cmp = ',cmp
- !print*,' dist = ',dist
- !print*,' T_surfacewaves = ',T_surfacewaves
- !print*
-
- ! reads in window picks
- read(21,*,iostat=ios) npicks
- if (ios /= 0) then ; print *, 'Error reading windows npicks' ; stop ; endif
-
- ! loops/skips over picks (start/end times)
- do ipicks=1,npicks
- !read(21,'(a)',iostat=ios) dummy
- !if (ios /= 0) then ; print *, 'Error reading window pick' ; stop ; endif
-
- read(21,*,iostat=ios) tstart, tend
- if (ios /= 0) then ; print *, 'Error reading window pick: tstart and tend' ; stop ; endif
-
- tstart = max(tstart,t0)
- tend = min(tend, t0+(npts-1)*dt)
- !nlen = floor((tend-tstart)/dt) + 1 ! see subroutine interpolate_data_and_syn
-
- ! body wave picks
- if( tend <= T_surfacewaves ) then
- if( cmp(1:1) == "Z" ) num_P_SV_V = num_P_SV_V + 1.d0
- if( cmp(1:1) == "R" ) num_P_SV_R = num_P_SV_R + 1.d0
- if( cmp(1:1) == "T" ) num_SH_T = num_SH_T + 1.d0
- else
- ! surface wave picks
- if( cmp(1:1) == "Z" ) num_Rayleigh_V = num_Rayleigh_V + 1.d0
- if( cmp(1:1) == "R" ) num_Rayleigh_R = num_Rayleigh_R + 1.d0
- if( cmp(1:1) == "T" ) num_Love_T = num_Love_T + 1.d0
- endif
-
- enddo
-
- ! determines all picks on a trace component
- ! transverse
- iposition = INDEX( trim(synfile), comp_T, .false. )
- if( iposition > 3 .and. iposition < len_trim( synfile) ) then
- if( cmp(1:1) /= "T" ) stop 'error T component pick'
- picks_T = picks_T + npicks
- else
- ! radial
- iposition = INDEX( trim(synfile), comp_R, .false. )
- if( iposition > 3 .and. iposition < len_trim( synfile) ) then
- if( cmp(1:1) /= "R" ) stop 'error R component pick'
- picks_R = picks_R + npicks
- else
- ! vertical
- iposition = INDEX( trim(synfile), comp_Z, .false. )
- if( iposition > 3 .and. iposition < len_trim( synfile) ) then
- if( cmp(1:1) /= "Z" ) stop 'error Z component pick'
- picks_Z = picks_Z + npicks
- endif
- endif
- endif
-
- enddo
- close(21)
-
-
- ! check with total number of picks per component
- if( nint( num_P_SV_R + num_Rayleigh_R ) /= picks_R ) stop 'error R picks'
- if( nint( num_P_SV_V + num_Rayleigh_V ) /= picks_Z ) stop 'error Z picks'
- if( nint( num_SH_T + num_Love_T ) /= picks_T ) stop 'error T picks'
-
- if( DO_WEIGHTING ) then
- print*
- print*,'weighting measurements: '
- print*,' picks T:',picks_T
- print*,' picks R:',picks_R
- print*,' picks Z:',picks_Z
- print*
- print*,' picks P_SV_R: ',nint(num_P_SV_R)
- print*,' picks P_SV_V: ',nint(num_P_SV_V)
- print*,' picks SH_T : ',nint(num_SH_T)
- print*,' picks Rayleigh_R: ',nint(num_Rayleigh_R)
- print*,' picks Rayleigh_V: ',nint(num_Rayleigh_V)
- print*,' picks Love_T : ',nint(num_Love_T)
- print*
- endif
-
-
- ! sets up weights based on picks
- weight_T = 1.0d0
- weight_R = 1.0d0
- weight_Z = 1.0d0
-
- ! weighting tries to balance love waves (tranverse) versus rayleigh waves (radial + vertical)
- !if( picks_T > 0 ) then
- ! if( picks_R + picks_Z > 0 ) weight_T = dble(picks_R + picks_Z)/dble(picks_T)
- !endif
-
- ! use normalization as weights
- if( picks_T > 0 ) weight_T = 1.d0 / picks_T
- if( picks_R > 0 ) weight_R = 1.d0 / picks_R
- if( picks_Z > 0 ) weight_Z = 1.d0 / picks_Z
-
- ! use normalization
- if( num_P_SV_R > 0. ) num_P_SV_R = 1.d0 / num_P_SV_R
- if( num_P_SV_V > 0. ) num_P_SV_V = 1.d0 / num_P_SV_V
- if( num_SH_T > 0. ) num_SH_T = 1.d0 / num_SH_T
- if( num_Rayleigh_R > 0. ) num_Rayleigh_R = 1.d0 / num_Rayleigh_R
- if( num_Rayleigh_V > 0. ) num_Rayleigh_V = 1.d0 / num_Rayleigh_V
- if( num_Love_T > 0. ) num_Love_T = 1.d0 / num_Love_T
-
- if( DO_WEIGHTING ) then
- print*,' weight num_P_SV_R:',num_P_SV_R
- print*,' weight num_P_SV_V:',num_P_SV_V
- print*,' weight num_SH_T :',num_SH_T
- print*,' weight num_Rayleigh_R:',num_Rayleigh_R
- print*,' weight num_Rayleigh_V:',num_Rayleigh_V
- print*,' weight num_Love_T :',num_Love_T
- print*
- endif
-
-end subroutine
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub.f90 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,2082 +0,0 @@
-module mt_sub
-
- use mt_constants
- use mt_variables
- use mt_sub2
- use ascii_rw
-
- implicit none
-
-contains
-
- ! =================================================================================================
- ! subroutine mt_measure()
- ! Boxcar/Cosine/Multitaper estimates of the transfer function between data and synthetics
- !
- ! Input:
- ! is_mtm -- taper type: 1 for multitaper, 2 for boxcar taper, and 3 for cosine taper
- ! datafile -- original data file in SAC format
- ! file_prefix -- the output file prefix (usually in STA.NT.CMP.N format)
- ! dat_dt(:), syn_dt(:) t0, dt, npts -- original data and synthetics array
- ! tstart, tend -- start and end of the measurement window (can be from Alessia's code)
- ! Output:
- ! istart -- starting index of the windowed portion of original trace
- ! dat_dtw(:), syn_dtw(:), nlen -- windowed and shifted data, windowed synthetics
- ! tshift, dlnA, cc_max -- time shift and amplitude cross-correlation measurements
- ! i_right -- the maximum reliable frequency estimate index
- ! trans_w(:) -- estimates of transfer function
- ! dtau_w(:), dlnA_w(:) -- estimates of travel-time and amplitude anomaly
- ! err_dt(:), err_dlnA(:) -- error bar of the travel-time and amplitude estimates (MT only)
- !
- ! original coding in Fortran77 by Ying Zhou
- ! upgraded to Fortran90 by Alessia Maggi
- ! organized into package form by Qinya Liu
- ! modifications by Carl Tape and Vala Hjorleifsdottir
- !
- ! =================================================================================================
-
- subroutine mt_measure(datafile,file_prefix,dat_dt,syn_dt,t0,dt,npts,tstart,tend, &
- istart,dat_dtw,syn_dtw,nlen,tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,syn_dtw_cc, &
- i_pmax_dat,i_pmax_syn,i_right,trans_w,dtau_w,dlnA_w,sigma_dt,sigma_dlnA,err_dt,err_dlnA)
-
- implicit none
- integer, intent(in) :: npts
- double precision, dimension(:), intent(in) :: dat_dt,syn_dt
- double precision, intent(in) :: tstart,tend,t0,dt
- character(len=150), intent(in) :: file_prefix,datafile
-
- double precision, intent(out) :: tshift,sigma_dt_cc,dlnA,sigma_dlnA_cc,cc_max,sigma_dt,sigma_dlnA
- complex*16, dimension(:), intent(out) :: trans_w
- double precision, dimension(:), intent(out) :: dtau_w,dlnA_w,syn_dtw,dat_dtw,syn_dtw_cc
- integer, intent(out) :: nlen,i_right,istart,i_pmax_dat,i_pmax_syn
- double precision, dimension(:), intent(out), optional :: err_dt,err_dlnA
- !double precision, intent(out), optional :: sigma_dt,sigma_dlnA
-
- double precision, dimension(NPT) :: syn_vtw, syn_dtw_mt, syn_dtw_mt_dt, &
- syn_dtw_cc_dt, dat_dtw_cc, syn_dtw_h, dat_dtw_h
- double precision :: sfac1,fac,f0,df,df_new,dw, &
- ampmax_unw,wtr_use_unw,ampmax,wtr_use,wtr_mtm,dtau_wa,dlnA_wa !omega
- integer :: ishift,i,ictaper,j,fnum,i_amp_max_unw,i_amp_max,i_right_stop,idf_new,iom
-
- complex*16, dimension(NPT) :: syn_dtwo, dat_dtwo, syn_dtw_ho, dat_dtw_ho, &
- top_mtm, bot_mtm, trans_mtm, wseis_recon
- double precision, dimension(NPT) :: wvec, ey1, ey2, dtau_mtm, dlnA_mtm, &
- phi_w, abs_w, err_phi, err_abs, phi_mtm, abs_mtm
- double precision :: eph_ave,edt_ave,eabs_ave,eabs2_ave,eph_iom,edt_iom,eabs_iom,eabs2_iom
- double precision, dimension(:,:),allocatable :: tas,phi_mul,abs_mul,dtau_mul,dlnA_mul
- character(len=150) :: filename
- logical :: output_logical,display_logical
-
- !-------------------------------------------------------------
-
- if ( tstart < t0 .or. tend > t0+(npts-1)*dt .or. tstart >= tend) then
- print *, 'tstart, t0, tend, t0+(npts-1)*dt:'
- print *, tstart, t0, tend, t0+(npts-1)*dt
- stop 'Check tstart and tend'
- endif
-
- ! initializes i_right
- i_right = 0
-
- ! LQY -- is this too small ???
- wtr_mtm = 1.e-10
-
- filename = trim(file_prefix)
-
- if (DISPLAY_DETAILS) then
- call dwascii(trim(file_prefix)//'_data',dat_dt,npts,t0,dt)
- call dwascii(trim(file_prefix)//'_syn',syn_dt,npts,t0,dt)
- !call dwsac1(trim(file_prefix)//'_data.sac',dat_dt,npts,t0,dt)
- !call dwsac1(trim(file_prefix)//'_syn.sac',syn_dt,npts,t0,dt)
-
-!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'_data.sac',t0,npts,dat_dt)
-!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'_syn.sac',t0,npts,syn_dt)
-!!$ !call dwrite_sacfile_f(datafile,trim(file_prefix)//'_diff_dms.sac',t0,npts,dat_dt-syn_dt)
-!!$ !call dwrite_ascfile_f(trim(file_prefix)//'_data.txt',t0,dt,npts,dat_dt)
-!!$ !call dwrite_ascfile_f(trim(file_prefix)//'_syn.txt',t0,dt,npts,syn_dt)
- endif
-
- !--------------------------------------------------------------------------
- ! window and interpolate data and synthetics
- !--------------------------------------------------------------------------
-
- ! interpolate data and synthetics, and also extract time-windowed records
- call interpolate_dat_and_syn(dat_dt,syn_dt,tstart,tend,t0,dt,NPT,dat_dtw,syn_dtw,nlen,istart)
-
- if (nlen <= 1) stop 'Check the length of the data and syn arrays'
- if (nlen > NPT) stop 'Check the dimension of data and syn arrays'
-
- ! some constants
- sfac1 = (2./dble(nlen))**2 ! for Welch window
- ipwr_t = 10 ! for time-domain cosine taper: 1 - [cos(t)]^(ipwr)
-
- ! pre-processing time-domain taper
- do i = 1,nlen
- !fac = 1. ! boxcar window
- !fac = 1 - sfac1*((i-1) - dble(nlen)/2.)**2 ! welch window
- fac = 1. - cos(PI*(i-1)/(nlen-1))**ipwr_t ! cosine window
-
- syn_dtw(i) = syn_dtw(i) * fac ! syn, windowed
- dat_dtw(i) = dat_dtw(i) * fac ! dat, windowed
- enddo
-
- if (DISPLAY_DETAILS) then
- print *, ' NPTs = ', NPT, ' new nlen = ', nlen
- call dwsac1(trim(file_prefix)//'.obs.sac',dat_dtw,nlen,tstart,dt)
- call dwsac1(trim(file_prefix)//'.syn.sac',syn_dtw,nlen,tstart,dt)
-!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'.obs.sac',tstart,nlen,dat_dtw)
-!!$ call dwrite_sacfile_f(datafile,trim(file_prefix)//'.syn.sac',tstart,nlen,syn_dtw)
- endif
-
- ! save a copy of the windowed data
- !dat_dtwc(:) = dat_dtw(:)
-
- !------------------------------------------------------------------
- ! cross-correlation traveltime and amplitude measurements
- !------------------------------------------------------------------
-
- ! compute cross-correlation time shift and also amplitude measurmement
- ! NOTE: records have already been windowed, so no information outside windows is considered
- ! LQY: Ying suggested to align them at relatively long periods
- call compute_cc(syn_dtw, dat_dtw, nlen, dt, ishift, tshift, dlnA, cc_max)
-
- ! compute velocity of synthetics
- do i = 2, nlen-1
- syn_vtw(i) = (syn_dtw(i+1) - syn_dtw(i-1)) / (2.0*dt)
- enddo
- syn_vtw(1) = (syn_dtw(2) - syn_dtw(1)) / dt
- syn_vtw(nlen) = (syn_dtw(nlen) - syn_dtw(nlen-1)) /dt
-
- ! acceleration
- !do i = 2, nlen-1
- ! syn_atw(i) = (syn_vtw(i+1) - syn_vtw(i-1)) / (2.0*dt)
- !enddo
- !syn_atw(1) = (syn_vtw(2) - syn_vtw(1)) / dt
- !syn_atw(nlen) = (syn_vtw(nlen) - syn_vtw(nlen-1)) / dt
-
- ! deconstruct data using (negative) cross-correlation measurments
- call deconstruct_dat_cc(filename,dat_dtw,tstart,dt,nlen, &
- ishift,tshift,dlnA,dat_dtw_cc)
-
- ! reconstruct synthetics using cross-correlation measurments (plotting purposes only)
- call reconstruct_syn_cc(syn_dtw,tstart,dt,nlen,ishift,tshift,dlnA,syn_dtw_cc,syn_dtw_cc_dt)
-
- if (OUTPUT_MEASUREMENT_FILES) then
- call dwsac1(trim(filename)//'.recon_syn_cc.sac',syn_dtw_cc,nlen,tstart,dt)
- call dwsac1(trim(filename)//'.recon_syn_cc_dt.sac',syn_dtw_cc_dt,nlen,tstart,dt)
-!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_cc.sac',tstart,nlen,syn_dtw_cc)
-!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_cc_dt.sac',tstart,nlen,syn_dtw_cc_dt)
-!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn',tstart,dt,nlen,syn_dtw_cc)
-!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn_dt',tstart,dt,nlen,syn_dtw_dt)
- endif
-
- ! compute the estimated uncertainty for the cross-correlation measurment
- sigma_dt_cc = 1.
- sigma_dlnA_cc = 1.
- call compute_average_error(dat_dtw,syn_dtw_cc,syn_dtw_cc_dt,nlen,dt,sigma_dt_cc,sigma_dlnA_cc)
-
- ! write cross-correlation measurement to file
- call write_average_meas(filename,imeas,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc)
-
- !========================================
-
- ! CHT: if you want a simple waveform difference, then return
- if (is_mtm == 0) return
-
- !-----------------------------------------------------------------------------
- ! set up FFT for the frequency domain
- !-----------------------------------------------------------------------------
-
- ! calculate frequency step and number of frequencies
- f0 = 0.
- df = 1./(NPT*dt)
- dw = TWOPI * df
- fnum = NPT/2 + 1
-
- ! calculate frequency spacing of sampling points
- df_new = 1.0 / (tend-tstart)
- idf_new = df_new / df
-
- ! assemble omega vector (NPT is the FFT length)
- wvec(:) = 0.
- do j = 1,NPT
- if(j > NPT/2+1) then
- wvec(j) = dw*(j-NPT-1) ! negative frequencies in second half
- else
- wvec(j) = dw*(j-1) ! positive frequencies in first half
- endif
- enddo
-
- ! create complex synthetic seismogram and CC-deconstructed data seismogram
- syn_dtwo = cmplx(0.,0.)
- dat_dtwo = cmplx(0.,0.)
- !syn_dtwo(1:nlen) = syn_dtw(1:nlen)
- !dat_dtwo(1:nlen) = dat_dtw_cc(1:nlen)
- syn_dtwo(1:nlen) = cmplx(syn_dtw(1:nlen))
- dat_dtwo(1:nlen) = cmplx(dat_dtw_cc(1:nlen))
-
- call fft(LNPT,syn_dtwo,FORWARD_FFT,dt)
- call fft(LNPT,dat_dtwo,FORWARD_FFT,dt)
-
- ! index of the freq of the max power in the windowed data
- ampmax_unw = 0.
- i_pmax_dat = 1
- do i = 1, fnum ! loop over frequencies
- if( abs(dat_dtwo(i)) > ampmax_unw) then
- ampmax_unw = abs(dat_dtwo(i))
- i_pmax_dat = i
- endif
- enddo
-
- ! water level based untapered synthetics
- ! used to determine the i_right values (maximum frequency for measurement)
- ampmax_unw = 0.
- do i = 1, fnum ! loop over frequencies
- if( abs(syn_dtwo(i)) > ampmax_unw) then
- ampmax_unw = abs(syn_dtwo(i))
- i_amp_max_unw = i
- endif
- enddo
- wtr_use_unw = cmplx(ampmax_unw * WTR, 0.)
-
- ! index of the freq of the max power in the windowed synthetics
- i_pmax_syn = i_amp_max_unw
-
- i_right = fnum
- i_right_stop = 0
- do i = 1,fnum
- if( abs(syn_dtwo(i)) <= abs(wtr_use_unw) .and. i_right_stop==0 .and. i > i_amp_max_unw ) then
- i_right_stop = 1
- i_right = i
- endif
- if( abs(syn_dtwo(i)) >= 10.*abs(wtr_use_unw) .and. i_right_stop==1 .and. i > i_amp_max_unw) then
- i_right_stop = 0
- i_right = i
- endif
- enddo
-
- if (DISPLAY_DETAILS) then
- print *, 'Frequency of max power in windowed synthetic (Hz):'
- print *, ' i_pmax_syn = ', i_pmax_syn, ', f_pmax = ', sngl(i_pmax_syn * df), ', T_pmax = ', sngl(1./(i_pmax_syn*df))
- print *, 'FFT freq spacing df = ', sngl(df)
- print *, 'measurement spacing df_new = ', sngl(df_new)
- print *, ' i_right = ', i_right, ', stopping freq = ', sngl(i_right * df)
-
- ! write out power for each signal
- call dwascii(trim(file_prefix)//'.obs.power',abs(dat_dtwo(1:i_right)),i_right,df,df)
- call dwascii(trim(file_prefix)//'.syn.power',abs(syn_dtwo(1:i_right)),i_right,df,df)
- !call dwsac1(trim(file_prefix)//'.obs.power.sac',abs(dat_dtwo(1:i_right)),i_right,df,df)
- !call dwsac1(trim(file_prefix)//'.syn.power.sac',abs(syn_dtwo(1:i_right)),i_right,df,df)
-!!$ call dwrite_ascfile_f(trim(file_prefix)//'.obs.power',df,df,i_right,abs(dat_dtwo(1:i_right)) )
-!!$ call dwrite_ascfile_f(trim(file_prefix)//'.syn.power',df,df,i_right,abs(syn_dtwo(1:i_right)) )
-
- endif
-
- !-------------------------------------------------------------------------------
- ! single-taper estimation of transfer function
- !-------------------------------------------------------------------------------
-
- ! assign number of tapers
- if (is_mtm == 1) then
- ntaper = int(NPI * 2.0)
- else
- ntaper = 1
- endif
- allocate(tas(NPT,ntaper))
-
- ! calculate the tapers
- if (is_mtm == 1) then
- call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
- elseif (is_mtm == 2) then
- call costaper(nlen, NPT, tas)
- elseif (is_mtm == 3) then
- call boxcar(nlen, NPT, tas)
- endif
-!!$ if (is_mtm == 1) then
-!!$ call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
-!!$ elseif (is_mtm == 2) then
-!!$ call costaper(nlen, NPT, tas)
-!!$ elseif (is_mtm == 3) then
-!!$ call boxcar(nlen, NPT, tas)
-!!$ endif
-
- ! initialize transfer function terms
- top_mtm(:) = cmplx(0.,0.)
- bot_mtm(:) = cmplx(0.,0.)
- trans_mtm(:) = cmplx(0.,0.)
-
- do ictaper = 1, ntaper
-
- syn_dtw_ho(:) = cmplx(0.,0.) ! note: this has to be initialized inside the loop
- dat_dtw_ho(:) = cmplx(0.,0.)
-
- ! apply time-domain taper
- do i = 1, nlen
- syn_dtw_h(i) = syn_dtw(i) * tas(i,ictaper) ! single-tapered, windowed syn
- dat_dtw_h(i) = dat_dtw_cc(i) * tas(i,ictaper) ! single-tapered, windowed, shifted data
- enddo
-
- syn_dtw_ho(1:nlen) = cmplx(syn_dtw_h(1:nlen),0.)
- dat_dtw_ho(1:nlen) = cmplx(dat_dtw_h(1:nlen),0.)
-
- ! apply FFT to get complex spectra
- call fft(LNPT,syn_dtw_ho,FORWARD_FFT,dt)
- call fft(LNPT,dat_dtw_ho,FORWARD_FFT,dt)
-
- ! compute water level for single taper measurement by finding max spectral power
- ! in the tapered synthetics record
- ampmax = 0.
- do i = 1, fnum ! loop over frequencies
- if( abs(syn_dtw_ho(i)) > ampmax) then ! syn, single_tapered
- ampmax = abs(syn_dtw_ho(i))
- i_amp_max = i
- endif
- enddo
- wtr_use = cmplx(ampmax * WTR, 0.)
- !print *, ' wtr_use :', wtr_use
-
- ! calculate top and bottom of MT transfer function
- do i = 1, fnum
- top_mtm(i) = top_mtm(i) + dat_dtw_ho(i) * conjg(syn_dtw_ho(i)) ! uses data and syn
- bot_mtm(i) = bot_mtm(i) + syn_dtw_ho(i) * conjg(syn_dtw_ho(i)) ! uses syn only
-
- ! calculate transfer function for single taper measurement using water level
- if (is_mtm /= 1) then
- if(abs(syn_dtw_ho(i)) > abs(wtr_use)) trans_w(i) = dat_dtw_ho(i) / syn_dtw_ho(i)
- if(abs(syn_dtw_ho(i)) <= abs(wtr_use)) trans_w(i) = dat_dtw_ho(i) / (syn_dtw_ho(i)+wtr_use)
- endif
- enddo
-
- ! for cosine or boxcar tapers only -- SEE COMMENTS BELOW for the multitaper case
- ! NOTE 1: here we are using trans_w, not trans_mtm
- ! NOTE 2: The single-taper transfer function should give you a perfect fit,
- ! but it is not relevant from the perspective of obtaining a measurement.
- if (is_mtm /= 1) then
- ! phase, abs(trans), travel-time and amplitude as a func of freq for single-tapered measurements
- call write_trans(filename,trans_w,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
- phi_w,abs_w,dtau_w,dlnA_w,dtau_wa,dlnA_wa)
- call reconstruct_syn(filename,syn_dtwo,wvec,dtau_w,dlnA_w, &
- i_right,tstart,dt,nlen,syn_dtw_mt, syn_dtw_mt_dt)
- !call check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift,tshift_f1f2,cc_max_f1f2,cc_max)
- !call compute_average_error(dat_dtw,syn_dtw_mt,syn_dtw_mt_dt,nlen,dt,sigma_dt,sigma_dlnA)
- !call write_average_meas(filename, imeas, dtau_wa, dlnA_wa, sigma_dt, sigma_dlnA)
- endif
-
- enddo ! ictapers
-
- ! for single taper, pass back the transfer function
- if (is_mtm /= 1) return
-
- !-------------------------------------------------------------------------------
- ! multitaper estimation of transfer function
- !-------------------------------------------------------------------------------
-
- ! water level for multitaper measurements
- ampmax = 0.
- do i = 1, fnum
- if( abs(bot_mtm(i)) > ampmax) then
- ampmax = abs(bot_mtm(i))
- i_amp_max = i
- endif
- enddo
- wtr_use = cmplx(ampmax * wtr_mtm**2, 0.)
- !wtr_use = cmplx(ampmax * WTR, 0.)
-
- ! calculate MT transfer function using water level
- do i = 1, fnum
- if(abs(bot_mtm(i)) > abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i)
- if(abs(bot_mtm(i)) < abs(wtr_use)) trans_mtm(i) = top_mtm(i) / (bot_mtm(i)+wtr_use)
- enddo
-
- ! multitaper phase, abs, tt, and amp (freq)
- call write_trans(filename,trans_mtm,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
- phi_mtm,abs_mtm,dtau_mtm,dlnA_mtm,dtau_wa,dlnA_wa)
-
- ! apply transfer function to the syn
- call reconstruct_syn(filename,syn_dtwo,wvec,dtau_mtm,dlnA_mtm, &
- i_right,tstart,dt,nlen,syn_dtw_mt,syn_dtw_mt_dt)
-
- ! check quality
- !call check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift, tshift_f1f2, cc_max_f1f2,cc_max)
-
- ! CHT: estimate error using the same procedure as for the cross-correlation error estimate
- !sigma_dt = 1. ; sigma_dlnA = 1.
- !call compute_average_error(dat_dtw,syn_dtw_mt,syn_dtw_mt_dt,nlen,dt,sigma_dt,sigma_dlnA)
- sigma_dt = sigma_dt_cc ; sigma_dlnA = sigma_dlnA_cc
-
- ! write average multitaper measurement to file
- call write_average_meas(file_prefix, imeas, dtau_wa, dlnA_wa, sigma_dt, sigma_dlnA)
-
- !-------------------------------------------------------------------------------
- ! multitaper error estimation
- !-------------------------------------------------------------------------------
-
- if (ntaper > 1) then
-
- ! save a copy of the control logicals
- output_logical = OUTPUT_MEASUREMENT_FILES
- display_logical = DISPLAY_DETAILS
- ! avoid I/O output for MT error estimates
- OUTPUT_MEASUREMENT_FILES = .false.
- DISPLAY_DETAILS = .false.
-
- ! allocate Jacknife MT estimates
- allocate(phi_mul(NPT,ntaper))
- allocate(abs_mul(NPT,ntaper))
- allocate(dtau_mul(NPT,ntaper))
- allocate(dlnA_mul(NPT,ntaper))
-
- do iom = 1, ntaper
-
- top_mtm(:) = cmplx(0.,0.)
- bot_mtm(:) = cmplx(0.,0.)
-
- do ictaper = 1, ntaper
- if(ictaper.eq.iom) cycle
-
- ! apply ictaper-th taper
- syn_dtw_h(1:nlen) = syn_dtw(1:nlen) * tas(1:nlen,ictaper)
- dat_dtw_h(1:nlen) = dat_dtw_cc(1:nlen) * tas(1:nlen,ictaper)
-
- ! complex tapered series
- syn_dtw_ho(:) = cmplx(0.,0.)
- dat_dtw_ho(:) = cmplx(0.,0.)
- syn_dtw_ho(1:nlen) = cmplx(syn_dtw_h(1:nlen),0.)
- dat_dtw_ho(1:nlen) = cmplx(dat_dtw_h(1:nlen),0.)
-
- ! apply f.t. to get complex spectra
- call fft(LNPT,syn_dtw_ho,FORWARD_FFT,dt)
- call fft(LNPT,dat_dtw_ho,FORWARD_FFT,dt)
-
- ! calculate top and bottom of Jacknife transfer function
- do i = 1, fnum
- top_mtm(i) = top_mtm(i) + dat_dtw_ho(i) * conjg(syn_dtw_ho(i))
- bot_mtm(i) = bot_mtm(i) + syn_dtw_ho(i) * conjg(syn_dtw_ho(i))
- enddo
- enddo ! ictaper
-
- ! water level
- ampmax = 0.
- do i = 1, fnum
- if( abs(bot_mtm(i)).gt.ampmax) then
- ampmax = abs(bot_mtm(i))
- i_amp_max = i
- endif
- enddo
- wtr_use = cmplx(ampmax * wtr_mtm ** 2, 0.)
-
- ! calculate transfer function using water level
- do i = 1, fnum
- if(abs(bot_mtm(i)).gt.abs(wtr_use)) trans_mtm(i) = top_mtm(i) / bot_mtm(i)
- if(abs(bot_mtm(i)).le.abs(wtr_use)) trans_mtm(i) = top_mtm(i) /(bot_mtm(i)+wtr_use)
- enddo
-
- call write_trans(filename,trans_mtm,wvec,fnum,i_right,idf_new,df,tshift,dlnA, &
- phi_mul(:,iom),abs_mul(:,iom),dtau_mul(:,iom),dlnA_mul(:,iom))
-
- enddo ! iom
-
- !----------------------
-
- open(10,file=trim(filename)//'.err_ph')
- open(20,file=trim(filename)//'.err_dt')
- open(30,file=trim(filename)//'.err_abs')
- open(40,file=trim(filename)//'.err_dlnA')
-
- ! CHT: Since all freq. domain points are used in constructing the
- ! adjoint source, we also want to show the entire sigma(f) functions,
- ! not just the sub-sampled version.
- open(50,file=trim(filename)//'.err_dt_full')
- open(60,file=trim(filename)//'.err_dlnA_full')
-
- err_phi = 0.
- err_dt = 0.
- err_abs = 0.
- err_dlnA = 0.
-
- do i = 1, i_right
-
- eph_ave = 0.
- edt_ave = 0.
- eabs_ave = 0.
- eabs2_ave = 0.
-
- do iom = 1, ntaper
- eph_iom = ntaper*phi_mtm(i) - (ntaper-1)*phi_mul(i,iom)
- eph_ave = eph_ave + eph_iom
-
- edt_iom = ntaper*dtau_mtm(i) - (ntaper-1)*dtau_mul(i,iom)
- edt_ave = edt_ave + edt_iom
-
- eabs_iom = ntaper*abs_mtm(i) - (ntaper-1)*abs_mul(i,iom)
- eabs_ave = eabs_ave + eabs_iom
-
- eabs2_iom = ntaper*dlnA_mtm(i) - (ntaper-1)*dlnA_mul(i,iom)
- eabs2_ave = eabs2_ave + eabs2_iom
- enddo
-
- eph_ave = eph_ave / (ntaper)
- edt_ave = edt_ave / (ntaper)
- eabs_ave = eabs_ave / (ntaper)
- eabs2_ave = eabs2_ave / (ntaper)
-
- do iom = 1, ntaper
- err_phi(i) = err_phi(i) + ( phi_mul(i,iom) - eph_ave)**2
- err_dt(i) = err_dt(i) + (dtau_mul(i,iom) - edt_ave)**2
- err_abs(i) = err_abs(i) + ( abs_mul(i,iom) - eabs_ave)**2
- err_dlnA(i) = err_dlnA(i)+ (dlnA_mul(i,iom) - eabs2_ave)**2
- enddo
-
- err_phi(i) = sqrt( err_phi(i) / (ntaper * (ntaper-1) ) )
- err_dt(i) = sqrt( err_dt(i) / (ntaper * (ntaper-1) ) )
- ! set the error bar for the first point corresponding to
- ! static offset to be large, which makes no contribution to
- ! the adjoint source
- if (i == 1) err_dt(i) = LARGE_VAL
- err_abs(i) = sqrt( err_abs(i) / (ntaper * (ntaper-1) ) )
- err_dlnA(i) = sqrt( err_dlnA(i) / (ntaper * (ntaper-1) ) )
-
- ! only write out the errors for the 'independent' freq-domain sampling points
- if (mod(i,idf_new) == 0) then
- write(10,*) df*(i-1), phi_mtm(i), err_phi(i)
- if (i > 1) write(20,*) df*(i-1), dtau_mtm(i), err_dt(i)
- write(30,*) df*(i-1), abs_mtm(i), err_abs(i)
- write(40,*) df*(i-1), dlnA_mtm(i), err_dlnA(i)
- endif
-
- ! CHT: write out the entire dt(f) and dlnA(f) for adjoint sources
- write(50,*) df*(i-1), dtau_mtm(i), err_dt(i)
- write(60,*) df*(i-1), dlnA_mtm(i), err_dlnA(i)
-
- enddo ! i_right
-
- close(10)
- close(20)
- close(30)
- close(40)
- close(50)
- close(60)
-
- ! pass the MT transfer funnction
- trans_w = trans_mtm
- dtau_w = dtau_mtm
- dlnA_w = dlnA_mtm
-
- ! reset the control parameters
- OUTPUT_MEASUREMENT_FILES = output_logical
- DISPLAY_DETAILS = display_logical
-
- endif
-
- ! ------------------------------------------------------------------
- ! End error calculation loop
- ! ------------------------------------------------------------------
-
- end subroutine mt_measure
-
-
- ! =====================================================================================================
- ! subroutine mt_adj()
- ! Compute cross-correlation travel-time/amplitude/banana-donut travel-time/banana-donut amplitude
- ! adjoint sources by assimulate the measurements passed from mt_measure()
- !
- ! Input:
- ! imeas -- adjoint source type: 0 for waveform, 1 for multitaper, 2 for cc, 3 for cc banana-doughnut
- ! istart -- starting index of the windowed portion of original trace, used to generate adjoint
- ! source that correspond to the original synthetics
- ! dat_dtw(:), syn_dtw(:), nlen, dt -- windowed data and synthetics
- ! with length nlen and sampling rate dt
- ! tshift, dlnA -- cross-correlation traveltime and amplitude measurements
- ! dtau_w(:), dlnA_w(:), err_dtau(:), err_dlnA(:), i_right -- traveltime and amplitude measurements
- ! and corresponding error bars as a function of frequency (1: i_right)
- !
- ! Output:
- ! tr_adj_src(:), tr_chi -- travel-time adjoint source and chi value
- ! am_adj_src(:), am_chi -- amplitude adjoint source and chi value
- ! window_chi(:) -- all available scalar measurement values and chi values
- !
- ! original coding by Carl Tape, finalized by Qinya Liu
- ! ======================================================================================================
-
- subroutine mt_adj(istart,dat_dtw,syn_dtw,nlen,dt,tshift,dlnA,sigma_dt_cc,sigma_dlnA_cc, &
- dtau_w,dlnA_w,err_dtau,err_dlnA,sigma_dt,sigma_dlnA,i_left,i_right, &
- window_chi,tr_adj_src,tr_chi,am_adj_src,am_chi)
-
- implicit none
- integer, intent(in) :: istart, nlen, i_left, i_right
- double precision, dimension(:), intent(in) :: dat_dtw, syn_dtw
- double precision, intent(in) :: dt, tshift, dlnA, sigma_dt_cc, sigma_dlnA_cc, sigma_dt, sigma_dlnA
- double precision, dimension(:), intent(in) :: dtau_w, dlnA_w, err_dtau, err_dlnA
-
- double precision, dimension(:), intent(out) :: tr_adj_src, am_adj_src
- double precision, intent(out) :: tr_chi, am_chi
- double precision, dimension(NCHI), intent(inout) :: window_chi
- !double precision, dimension(:), intent(out), optional :: am_adj_src
- !double precision, intent(out), optional :: am_chi
-
- double precision, dimension(NPT) :: syn_vtw, syn_vtw_h, syn_dtw_h, ey1, ey2
- double precision, dimension(NPT) :: ft_bar_t, fa_bar_t, fp, fq, wp_taper, wq_taper
- complex*16, dimension(NPT) :: d_bot_mtm, v_bot_mtm
- integer :: i, i1, ictaper, ntaper
- double precision :: df,Nnorm,Mnorm,fac,ffac,w_taper(NPT), time_window(NPT)
- double precision, dimension(:,:), allocatable :: tas
- complex*16, dimension(:,:),allocatable :: syn_dtw_ho_all, syn_vtw_ho_all
- complex*16, dimension(NPT) :: pwc_adj,qwc_adj
- double precision, dimension(NPT) :: dtau_pj_t, dlnA_qj_t
- double precision :: dtau_wtr, dlnA_wtr, err_t, err_A
- double precision :: waveform_chi, waveform_d2, waveform_s2, waveform_temp1, waveform_temp2, waveform_temp3
-
- ! waveform adjoint source is passed by tr_adj_src and tr_chi
- !if (imeas == 0 .and. (present(am_adj_src) .or. present(am_chi))) stop &
- ! 'am_adj_src and am_chi are not needed for imeas = 0 (waveform adjoint source case)'
-
- ! check the window length
- if (istart + nlen > NDIM) stop 'Check istart + nlen and NPT'
-
- ! waveform
- if(imeas==1 .or. imeas==2) then
- print *, 'computing waveform adjoint source'
- elseif(imeas==3 .or. imeas==4) then
- print *, 'computing banana-doughtnut adjoint source'
- elseif(imeas==5 .or. imeas==6) then
- print *, 'computing cross-correlation adjoint source'
- elseif(imeas==7 .or. imeas==8) then
- print *, 'computing multitaper adjoint source'
- endif
-
- ! ----------------------
- ! TAPERS
- ! ----------------------
- if( is_mtm == 1 ) then
- ! frequency-domain tapers
- ! THIS CHOICE WILL HAVE AN EFFECT ON THE ADJOINT SOURCES
- ipwr_w = 10
- w_taper(:) = 0.
- do i = i_left, i_right ! CHT: 1 --> i_left
- ! type of filter in the freq domain
- !w_taper(i) = 1. ! boxcar
- !w_taper(i) = 1. - (2.0/nw)**2 * ((i-1) - nw/2.0)**2 ! welch
- w_taper(i) = 1. - cos(PI*(i-i_left)/(i_right-i_left))**ipwr_w ! cosine
- enddo
-
- ! compute normalization factor for w_taper
- ! note: 2 is needed for the integration from -inf to inf
- df = 1. /(NPT*dt)
- ffac = 2.0 * df * sum(w_taper(i_left:i_right) ) ! CHT: 1 --> i_left
- if (DISPLAY_DETAILS) print *, 'Taper normalization factor, ffac = ', ffac
-
- ! wp_taper and wq_taper are modified frequency-domain tapers
- ! Notice the option to include the frequency-dependent error.
- wp_taper(:) = 0.
- wq_taper(:) = 0.
- dtau_wtr = WTR * sum(abs(dtau_w(i_left:i_right)))/(i_right-i_left) ! CHT i_left
- dlnA_wtr = WTR * sum(abs(dlnA_w(i_left:i_right)))/(i_right-i_left) ! CHT i_left
-
- do i = i_left, i_right ! CHT: 1 --> i_left
-
- if (ERROR_TYPE == 0 .or. DO_RAY_DENSITY_SOURCE ) then
- ! no error estimate
- ! only adds normalization factor
- wp_taper(i) = w_taper(i) / ffac
- wq_taper(i) = w_taper(i) / ffac
-
- elseif (ERROR_TYPE == 1) then
- ! MT error estimate is assigned the CC error estimate
- wp_taper(i) = w_taper(i) / ffac / (sigma_dt ** 2)
- wq_taper(i) = w_taper(i) / ffac / (sigma_dlnA ** 2)
-
- elseif (ERROR_TYPE == 2) then
- ! MT jack-knife error estimate
- err_t = err_dtau(i)
- if (err_dtau(i) < dtau_wtr) err_t = err_t + dtau_wtr
- err_A = err_dlnA(i)
- if (err_dlnA(i) < dlnA_wtr) err_A = err_A + dlnA_wtr
- wp_taper(i) = w_taper(i) / ffac / (err_t ** 2)
- wq_taper(i) = w_taper(i) / ffac / (err_A ** 2)
- endif
- enddo
-
-!!$ open(88,file='ftaper.dat')
-!!$ do i = 1,i_right
-!!$ write(88,'(5e18.6)') df*i, w_taper(i), dtau_w(i), dtau_w(i)*w_taper(i), dtau_w(i)*wp_taper(i)
-!!$ enddo
-!!$ close(88)
-
- endif ! is_mtm == 1
-
-
- ! post-processing time-domain taper
- ! NOTE: If the adjoint sources will be band-pass filtered at the end,
- ! then perhaps time_window is not necessary (i.e., use boxcar).
- ! However, if you are using a waveform difference, then you want
- ! to make sure that the endpoints of the windows are at zero, since
- ! you would NOT apply the post-processing band-pass filter.
- time_window(:) = 0.
- ipwr_t = 10
- do i = 1,nlen
- fac = 1. ! boxcar window
- !fac = 1 - sfac2*((i-1) - dble(nlen1)/2.0)**2 ! welch window
- !fac = 1. - cos(PI*(i-1)/(nlen-1))**ipwr_t ! cosine window
- time_window(i) = fac
- enddo
-
- ! ----------------------------------
- ! CROSS CORRELATION ADJOINT SOURCES
- ! ----------------------------------
- if( (imeas >= 3).and.(imeas <= 6) ) then
-
- ! compute synthetic velocity
- do i = 2, nlen-1
- syn_vtw(i) = (syn_dtw(i+1) - syn_dtw(i-1)) / (2.0*dt)
- enddo
- syn_vtw(1) = (syn_dtw(2) - syn_dtw(1)) / dt
- syn_vtw(nlen) = (syn_dtw(nlen) - syn_dtw(nlen-1)) / dt
-
- ! compute CC traveltime and amplitude banana-dougnut kernels
- ft_bar_t = 0.
- Nnorm = dt * sum( syn_vtw(1:nlen) * syn_vtw(1:nlen) )
- ft_bar_t(1:nlen) = -syn_vtw(1:nlen) / Nnorm
-
- fa_bar_t = 0.
- Mnorm = dt * sum( syn_dtw(1:nlen) * syn_dtw(1:nlen) )
- fa_bar_t(1:nlen) = syn_dtw(1:nlen) / Mnorm
- endif
-
- ! -------------------------------
- ! MULTITAPER ADJOINT SOURCES
- ! -------------------------------
-
- if ( (is_mtm == 1).and.COMPUTE_ADJOINT_SOURCE ) then
-
- ! allocate MT variables
- ntaper = int(NPI * 2.0)
- allocate(tas(NPT,ntaper))
- allocate(syn_dtw_ho_all(NPT,ntaper))
- allocate(syn_vtw_ho_all(NPT,ntaper))
-
- ! get the MT tapers
- call staper(nlen, NPI, NTAPER, tas, NPT, ey1, ey2)
-
- d_bot_mtm = 0.
- v_bot_mtm = 0.
-
- ! compute the bot required to compute p_j's and q_j's
- do ictaper = 1,ntaper
-
- ! tapered synthetic displacement
- syn_dtw_h(1:nlen) = syn_dtw(1:nlen) * tas(1:nlen,ictaper)
-
- ! compute velocity of tapered syn
- do i = 2, nlen-1
- syn_vtw_h(i) = (syn_dtw_h(i+1) - syn_dtw_h(i-1)) / (2.0*dt)
- enddo
- syn_vtw_h(1) = (syn_dtw_h(2) - syn_dtw_h(1)) / dt
- syn_vtw_h(nlen) = (syn_dtw_h(nlen) - syn_dtw_h(nlen-1)) /dt
-
- ! single-tapered complex synthetic displacement and velocity
- syn_dtw_ho_all(:,ictaper) = 0.
- syn_vtw_ho_all(:,ictaper) = 0.
- syn_dtw_ho_all(1:nlen,ictaper) = cmplx(syn_dtw_h(1:nlen),0.)
- syn_vtw_ho_all(1:nlen,ictaper) = cmplx(syn_vtw_h(1:nlen),0.)
-
- ! apply FFT get complex spectra
- call fft(LNPT,syn_dtw_ho_all(:,ictaper),FORWARD_FFT,DT)
- call fft(LNPT,syn_vtw_ho_all(:,ictaper),FORWARD_FFT,DT)
-
- d_bot_mtm(:) = d_bot_mtm(:) + syn_dtw_ho_all(:,ictaper) * conjg(syn_dtw_ho_all(:,ictaper))
- v_bot_mtm(:) = v_bot_mtm(:) + syn_vtw_ho_all(:,ictaper) * conjg(syn_vtw_ho_all(:,ictaper))
-
- enddo ! ictaper
-
- ! compute p_j, q_j, P_j, Q_j and adjoint source fp, fq
- fp = 0.
- fq = 0.
- do ictaper = 1,ntaper
-
- ! compute p_j(w) and q_j(w)
- pwc_adj(:) = cmplx(0.,0.)
- qwc_adj(:) = cmplx(0.,0.)
-
- do i = 1, i_right
- pwc_adj(i) = syn_vtw_ho_all(i,ictaper) / v_bot_mtm(i)
- qwc_adj(i) = -syn_dtw_ho_all(i,ictaper) / d_bot_mtm(i)
- enddo
-
- ! compute P_j(w) and Q_j(w)
- ! NOTE: the MT measurement is incorporated here
- ! also note that wp_taper and wq_taper can contain uncertainty estimations
- if( DO_RAY_DENSITY_SOURCE ) then
- ! uses a misfit measurement dtau, dlnA = 1
- pwc_adj(:) = pwc_adj(:) * cmplx(1.0,0.) * cmplx(wp_taper(:),0.)
- qwc_adj(:) = qwc_adj(:) * cmplx(1.0,0.) * cmplx(wq_taper(:),0.)
- else
- ! adds misfit measurement dtau, dlnA
- pwc_adj(:) = pwc_adj(:) * cmplx(dtau_w(:),0.) * cmplx(wp_taper(:),0.)
- qwc_adj(:) = qwc_adj(:) * cmplx(dlnA_w(:),0.) * cmplx(wq_taper(:),0.)
- endif
-
- ! IFFT into the time domain
- call fftinv(LNPT,pwc_adj,REVERSE_FFT,dt,dtau_pj_t)
- call fftinv(LNPT,qwc_adj,REVERSE_FFT,dt,dlnA_qj_t)
-
- ! create adjoint source
- ! applies taper to time signal
- fp(:) = fp(:) + tas(:,ictaper) * dtau_pj_t(:)
- fq(:) = fq(:) + tas(:,ictaper) * dlnA_qj_t(:)
-
- enddo
-
- endif ! MT adjoint source
-
- ! -------------------------------------
- ! COMPUTE ADJOINT SOURCE
- ! -------------------------------------
-
- tr_adj_src = 0.
- am_adj_src = 0.
-
- ! integrated waveform difference squared
- waveform_temp1 = 0. ; waveform_temp2 = 0. ; waveform_temp3 = 0.
- do i = 1,nlen
- waveform_temp1 = waveform_temp1 + ( dat_dtw(i) * time_window(i) )**2
- waveform_temp2 = waveform_temp2 + ( syn_dtw(i) * time_window(i) )**2
- waveform_temp3 = waveform_temp3 + (( dat_dtw(i) - syn_dtw(i) ) * time_window(i) )**2
- enddo
- ! NOTE: does not include DT factor or normalization by duration of window
- waveform_d2 = waveform_temp1
- waveform_s2 = waveform_temp2
- waveform_chi = waveform_temp3
-
- ! compute traveltime and amplitude adjoint sources
- if (COMPUTE_ADJOINT_SOURCE) then
-
- do i = 1,nlen
- i1 = istart + i
-
- ! waveform
- if(imeas==1 .or. imeas==2) then
- tr_adj_src(i1) = -dat_dtw(i)/waveform_d2 * time_window(i)
- am_adj_src(i1) = ( syn_dtw(i) - dat_dtw(i) ) * time_window(i)
- ! consider normalizing this by waveform_d2
-
- ! use pure data waveform in time window
- if( NO_WAVEFORM_DIFFERENCE ) then
- tr_adj_src(i1) = dat_dtw(i) * time_window(i) ! waveform misfit
- endif
-
- ! banana-doughnut kernel adjoint source (no measurement)
- elseif(imeas==3 .or. imeas==4) then
- tr_adj_src(i1) = ft_bar_t(i) * time_window(i)
- am_adj_src(i1) = fa_bar_t(i) * time_window(i)
-
- ! cross-correlation
- elseif(imeas==5 .or. imeas==6) then
- tr_adj_src(i1) = -(tshift / sigma_dt_cc**2 ) * ft_bar_t(i) * time_window(i)
- am_adj_src(i1) = -(dlnA / sigma_dlnA_cc**2 ) * fa_bar_t(i) * time_window(i)
-
- ! ray density
- if( DO_RAY_DENSITY_SOURCE ) then
- ! uses a misfit measurement of 1
- tr_adj_src(i1) = - (1.0) * ft_bar_t(i) * time_window(i)
- am_adj_src(i1) = - (1.0) * fa_bar_t(i) * time_window(i)
- endif
-
- ! multitaper
- elseif(imeas==7 .or. imeas==8) then
- tr_adj_src(i1) = fp(i) * time_window(i)
- am_adj_src(i1) = fq(i) * time_window(i)
- endif
- enddo
-
- endif
-
- ! -------------------------------------
- ! COMPUTE MISFIT FUNCTION VALUE
- ! -------------------------------------
-
- ! CHT: compute misfit function value and measurement value
- ! Note: The taper functions for MT may include error estimates.
- ! 1: multitaper, TT
- ! 2: multitaper, dlnA
- ! 3: cross-correlation, TT
- ! 4: cross-correlation, dlnA
- !window_chi(:) = 0.
-
-
- ! misfit function value
- if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (dtau_w(1:i_right))**2 * wp_taper(1:i_right) )
- if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (dlnA_w(1:i_right))**2 * wq_taper(1:i_right) )
- window_chi(3) = 0.5 * (tshift/sigma_dt_cc)**2
- window_chi(4) = 0.5 * (dlnA/sigma_dlnA_cc)**2
-
- ! measurement (no uncertainty estimates)
- if(is_mtm==1) window_chi(5) = sum( dtau_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
- if(is_mtm==1) window_chi(6) = sum( dlnA_w(1:i_right) * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
- window_chi(7) = tshift
- window_chi(8) = dlnA
-
- ! replaces misfit function values
- if( DO_RAY_DENSITY_SOURCE ) then
- ! uses misfit measurements equal to 1
- ! misfit function value
- if(is_mtm==1) window_chi(1) = 0.5 * 2.0 * df * sum( (1.0)**2 * wp_taper(1:i_right) )
- if(is_mtm==1) window_chi(2) = 0.5 * 2.0 * df * sum( (1.0)**2 * wq_taper(1:i_right) )
- window_chi(3) = 0.5 * (1.0)**2
- window_chi(4) = 0.5 * (1.0)**2
-
- ! measurement (no uncertainty estimates)
- if(is_mtm==1) window_chi(5) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
- if(is_mtm==1) window_chi(6) = sum( 1.0 * w_taper(1:i_right) ) / sum(w_taper(1:i_right) )
- window_chi(7) = 1.0
- window_chi(8) = 1.0
- endif
-
- ! estimated mesurement uncertainties
- if(is_mtm==1) window_chi(9) = sigma_dt
- if(is_mtm==1) window_chi(10) = sigma_dlnA
- window_chi(11) = sigma_dt_cc
- window_chi(12) = sigma_dlnA_cc
-
- ! for normalization, divide by duration of window
- window_chi(13) = 0.5 * waveform_d2
- window_chi(14) = 0.5 * waveform_s2
- window_chi(15) = 0.5 * waveform_chi
- window_chi(16) = nlen*dt
-
-!!$ open(88,file='testing.dat')
-!!$ do i = 1,i_right
-!!$ write(88,'(5e18.6)') df*i, dtau_w(i), dlnA_w(i), wp_taper(i), wq_taper(i)
-!!$ enddo
-!!$ close(88)
-
- if(imeas <= 2) then ! waveform
- tr_chi = 0.5 * waveform_chi
- am_chi = 0.5 * waveform_chi
-
- elseif( (imeas >= 3).and.(imeas <= 6) ) then ! cross_correlation
- tr_chi = window_chi(3)
- am_chi = window_chi(4)
-
- elseif( (imeas==7).or.(imeas==8) ) then ! multitaper
- tr_chi = window_chi(1)
- am_chi = window_chi(2)
-
- endif
-
- end subroutine mt_adj
-
- !==============================================================================
- !==============================================================================
-
- !----------------------------------------------------------------------
-
- subroutine bandpass(x,n,delta_t,f1,f2)
- ! modified from FLEXWIN subroutines on 26-July-2009
-
- implicit none
- integer, intent(in) :: n
- double precision, intent(inout), dimension(*) :: x
- double precision, intent(in) :: delta_t,f1,f2
- real, dimension(:), allocatable :: x_sngl
-
- allocate(x_sngl(n))
-
- x_sngl(1:n) = sngl(x(1:n))
- ! delta_t_sngl = sngl(delta_t)
-
- ! old version - uses old SacLib
- ! does band-pass filter
- !call xapiir(x_sngl,n,'BU',sngl(TRBDNDW),sngl(APARM),IORD,'BP',sngl(FSTART),sngl(FEND),delta_t_sngl,PASSES)
-
- ! new version, uses subroutines in libsac.a
- ! does band-pass filter
- ! BU - butterworth
- ! BP - bandpass
- call xapiir(x_sngl,n,'BU',TRBDNDW,APARM,IORD,'BP',f1,f2,delta_t,PASSES)
-
- x(1:n) = dble(x_sngl(1:n))
-
- deallocate(x_sngl)
-
- end subroutine bandpass
-
- !-----------------------------------------------------------------------------
-
- subroutine drsac1(datafile,data,npt1,b1,dt1)
- ! read sac file and convert to double precision
-
- implicit none
- character(len=*),intent(in) :: datafile
- real, dimension(NDIM) :: dat_sngl
- double precision, dimension(NDIM), intent(out) :: data
- integer :: npt1, nerr
- real :: b1_sngl,dt1_sngl
- double precision :: b1,dt1
-
- ! read file as single precision
- call rsac1(datafile,dat_sngl,npt1,b1_sngl,dt1_sngl,NDIM,nerr)
- if (nerr > 0) then
- print *, 'Error reading sac file', trim(datafile)
- stop
- endif
-
- ! return double precision quantities
- b1 = dble(b1_sngl)
- dt1 = dble(dt1_sngl)
- data = dble(dat_sngl)
-
- end subroutine drsac1
-
- !-----------------------------------------------------------------------------
-
- subroutine dwsac1(datafile,data,npt1,b1,dt1)
- ! convert to single precision, then write sac file
- ! --> includes an option to add minmax values to sac file,
- ! which are used in the plotting scripts
-
- implicit none
- character(len=*),intent(in) :: datafile
- integer, intent(in) :: npt1
- double precision, dimension(npt1), intent(in) :: data
- double precision, intent(in) :: b1,dt1
- logical, parameter :: minmax_header = .true.
-
- real, dimension(npt1) :: dat_sngl,ti_sngl
- real :: b1_sngl,dt1_sngl,xmin_sngl,xmax_sngl
- integer :: nerr,i
-
- ! convert to single precision
- b1_sngl = real(b1)
- dt1_sngl = real(dt1)
- dat_sngl = real(data)
-
- if (minmax_header) then
- ! get time vector
- ti_sngl = 0.
- do i = 1,npt1
- ti_sngl(i) = b1_sngl + (i-1)*dt1_sngl
- enddo
-
- !call newhdr() ! create a new header
-
- ! set minmax values in sac file
- xmin_sngl = minval(dat_sngl)
- xmax_sngl = maxval(dat_sngl)
- call setfhv('depmin',xmin_sngl,nerr)
- call setfhv('depmax',xmax_sngl,nerr)
-
- call setnhv('npts',npt1,nerr) ! sets number of points
- !call setfhv('b',ti_sngl(1),nerr) ! sets begin
- !call setfhv('e',ti_sngl(npt1),nerr) ! sets end
- !call setlhv('leven',.false.,nerr) ! sets un-even sampling
- !call setihv('iftype','itime',nerr) ! sets file type: time file
-
- ! write file with headers
- call wsac0(datafile,ti_sngl,dat_sngl,nerr)
-
- else
- call wsac1(datafile,dat_sngl,npt1,b1_sngl,dt1_sngl,nerr)
- endif
- if (nerr > 0) then
- print *, 'Error writing sac file', trim(datafile)
- stop
- endif
-
- end subroutine dwsac1
-
- !-----------------------------------------------------------------------------
-
- subroutine cc_measure_select(tshift,dlnA,cc_max)
-
- ! CHT: If the CC timeshift is for some reason larger than the allowable max,
- ! then effectively eliminate the window by zeroing the
- ! cross-correlation traveltime and amplitude measurements.
- ! See subroutine compute_cc in mt_sub.f90.
-
- implicit none
- double precision, intent(inout) :: tshift, dlnA, cc_max
-
- if( (cc_max < CC_MIN) .or. (tshift < TSHIFT_MIN) .or. (tshift > TSHIFT_MAX) &
- .or. (dlnA < DLNA_MIN) .or. (dlnA > DLNA_MAX) ) then
- ! zero the CC measurments
- if (DISPLAY_DETAILS) then
- print *, 'Fail if ANY of these is true :'
- print *, ' cc_max : ', cc_max, CC_MIN, cc_max < CC_MIN
- print *, ' tshift : ', tshift, TSHIFT_MIN, tshift < TSHIFT_MIN
- print *, ' tshift : ', tshift, TSHIFT_MAX, tshift > TSHIFT_MAX
- print *, ' dlnA : ', dlnA, DLNA_MIN, dlnA < DLNA_MIN
- print *, ' dlnA : ', dlnA, DLNA_MAX, dlnA > DLNA_MAX
- endif
-
- ! zero the CC measurments
- tshift = 0.0
- dlnA = 0.0
- endif
-
- end subroutine cc_measure_select
-
- !-----------------------------------------------------------------------------
-
- subroutine mt_measure_select(nlen,tshift,i_pmax_syn,dtau_w,err_dt, &
- dt,i_left,i_right,fstart,fend,use_trace)
-
- ! an important subroutine to determine whether an MT measurement should be rejected,
- ! in which case a CC measurement is used -- several choices are made here
-
- implicit none
- integer, intent(in) :: nlen, i_pmax_syn
- double precision, intent(in) :: tshift, dt
- double precision, dimension(:), intent(inout) :: dtau_w, err_dt
- double precision, intent(inout) :: fstart, fend
- integer,intent(inout) :: i_left, i_right
- logical,intent(out) :: use_trace
-
- double precision :: df, fvec(NPT), f_pmax, T_pmax, Wlen
- integer :: i_right_old, i_left_old
- integer :: j,ntaper
- !logical :: stop_freq
-
- use_trace = .true.
- df = 1./(dt*NPT)
- f_pmax = df * i_pmax_syn
- T_pmax = 1./ f_pmax
- Wlen = dt*nlen
-
- if( NCYCLE_IN_WINDOW * T_pmax > Wlen ) then
- print *, 'rejecting trace for too few cycles within time window:'
- print *, ' T_pmax : ', T_pmax
- print *, ' Wlen : ', Wlen
- print *, ' NCYCLE_IN_WINDOW : ', NCYCLE_IN_WINDOW
- print *, ' REJECTION: ', NCYCLE_IN_WINDOW*T_pmax, Wlen, NCYCLE_IN_WINDOW * T_pmax < Wlen
- use_trace = .false.
- endif
-
- !write(*,'(a8,4f12.6)') 'fstart :', fstart, NCYCLE_IN_WINDOW/(Wlen), NCYCLE_IN_WINDOW, Wlen
- !write(*,'(a8,4f12.6)') 'fend :', fend, 1./(2.0*dt), dt
-
- ! DECREASE the frequency range of the measurement (and adjoint source)
- ! --> note NCYCLE_IN_WINDOW and window length
- ! We subjectively state that we want at least 10 frequency points for the multitaper measurement.
- fstart = max(fstart, NCYCLE_IN_WINDOW/Wlen)
- fend = min(fend, 1./(2.0*dt))
-
- ! number of tapers (slepian tapers, type = 1)
- ntaper = int(NPI * 2.0)
- if( ntaper > 10 ) ntaper = 10
- if( ntaper < 1 ) ntaper = 10
- if( use_trace .and. fstart >= fend - ntaper*df ) then
- print *, 'rejecting trace for frequency range (NCYCLE_IN_WINDOW/Wlen):'
- print *, ' fstart, fend, df, ntaper : ', fstart,fend,df,ntaper
- print *, ' NCYCLE_IN_WINDOW, Wlen : ', NCYCLE_IN_WINDOW,Wlen,NCYCLE_IN_WINDOW/Wlen
- print *, ' REJECTION fstart >= fend - ntaper*df : ', fstart, fend - ntaper*df, fstart >= fend - ntaper*df
- use_trace = .false.
- !stop 'testing rejection criteria'
- endif
-
- ! assemble frequency vector (NPT is the FFT length)
- fvec(:) = 0.
- do j = 1,NPT
- if(j > NPT/2+1) then
- fvec(j) = df*(j-NPT-1) ! negative frequencies in second half
- else
- fvec(j) = df*(j-1) ! positive frequencies in first half
- endif
- enddo
-
-!!$ stop_freq = .false.
-!!$ do j = 1, i_right
-!!$ if (stop_freq) exit
-!!$ print *, j, dtau_w(j),stop_freq
-!!$ if (abs(dtau_w(j)) > 3 * abs(tshift)) then
-!!$ dtau_w(j) = 0
-!!$ else if (j /= 1) then
-!!$ stop_freq = .true.
-!!$ endif
-!!$ enddo
-
- ! determine the indices that denote the new frequency range (CHT)
- ! IT SEEMS LIKE THERE SHOULD BE NO NEED FOR THIS, SINCE THE SIGNAL HAS ALREADY
- ! BEEN BAND-PASSED PRIOR TO MAKING THE MULTITAPER MEASUREMENT.
- if (1==1) then
- i_left_old = i_left
- i_right_old = i_right
- do j = i_left_old, i_right_old
- if (fvec(j) > fstart) then
- i_left = j-1
- exit
- endif
- enddo
- do j = i_left_old, i_right_old
- if (fvec(j) > fend) then
- i_right = j-1
- exit
- endif
- enddo
- if (DISPLAY_DETAILS) then
- write(*,'(a24,2i6,2f14.8)') 'Old frequency bounds :', i_left_old, i_right_old, df*i_left_old, df*i_right_old
- write(*,'(a24,2i6,2f14.8)') 'New frequency bounds :', i_left, i_right, df*i_left, df*i_right
- endif
- endif
-
- ! update the frequency limits
- fstart = (i_left-1)*df
- fend = (i_right-1)*df
-
- ! if the cross-correlation time-shift is <= a time-step, set dtau(w) to zero
- ! NOTE: this should probably be a user parameter
- if ( abs(tshift) <= 1.01*dt ) then
- dtau_w(:) = 0.
- use_trace = .false.
- if (DISPLAY_DETAILS) then
- print *, 'rejecting trace for too small a time shift:'
- print *, ' dt = ', dt
- print *, ' tshift = ', tshift
- endif
- endif
-
- ! within the frequency range of interest, check various criteria
- ! CHT: dtau_w(j) --> abs(dtau_w(j)) for the first criterion
- do j = i_left, i_right
- if (use_trace .and. (abs(dtau_w(j)) > 1./(DT_FAC*fvec(j)) .or. err_dt(j) > 1./(ERR_FAC*fvec(j)) &
- .or. abs(dtau_w(j)) > DT_MAX_SCALE*abs(tshift))) then
- use_trace = .false.
- if (DISPLAY_DETAILS) then
- print *, 'rejecting trace (T leads to rejection):'
- print *, ' f = ', fvec(j), j
- print *, 'DT_FAC (lower) : ', abs(dtau_w(j)), 1./(DT_FAC * fvec(j)), abs(dtau_w(j)) > 1./(DT_FAC * fvec(j))
- print *, 'ERR_FAC (lower) : ', err_dt(j), 1./(ERR_FAC * fvec(j)), err_dt(j) > 1./(ERR_FAC * fvec(j))
- print *, 'DT_MAX_SCALE (lower) : ', abs(dtau_w(j)), DT_MAX_SCALE*abs(tshift), &
- abs(dtau_w(j)) > DT_MAX_SCALE*abs(tshift)
- !stop 'testing MT trace rejection'
- endif
- endif
- enddo
-
- end subroutine mt_measure_select
-
- !==============================================================================
- ! subroutines used in mtm_measure() and mtm_adj()
- !==============================================================================
-
- subroutine interpolate_dat_and_syn(data, syn, tstart, tend, t0, dt, NPT, dat_win, syn_win, nlen, istart)
-
- implicit none
- double precision, dimension(NPT), intent(in) :: data, syn
- double precision, dimension(NPT), intent(out) :: dat_win, syn_win
- double precision, intent(in) :: tstart, tend, t0, dt
- integer, intent(in) :: NPT
- integer, intent(out) :: nlen, istart
-
- integer :: ii, i
- double precision :: time, t1
-
- nlen = floor((tend-tstart)/dt) + 1
- istart = floor((tstart-t0)/dt)
-
- ! limits array bounds
- if( nlen > NPT ) nlen = NPT
-
- do i = 1, nlen
- time = tstart + (i-1) * dt
- ii = floor((time-t0)/dt) + 1
-
- ! checks out-of-bounds
- if( ii >= NPT ) cycle
-
- t1 = floor((time-t0)/dt) * dt + t0
-
- dat_win(i) = data(ii) + (data(ii+1)-data(ii)) * (time-t1) / dt ! data
- syn_win(i) = syn(ii) + (syn(ii+1)-syn(ii)) * (time-t1) /dt ! syn
-
- enddo
-
- end subroutine interpolate_dat_and_syn
-
- !-----------------------------------------------------------------------------
-
- subroutine compute_cc(syn, data, nlen, dt, ishift, tshift, dlnA, cc_max)
-
- ! time shift MEASUREMENT between data (data) and synthetics (syn)
- ! CHT: modified the subroutine to resemble the one used in FLEXWIN
-
- implicit none
- double precision, dimension(*), intent(in) :: syn, data
- integer, intent(in) :: nlen
- double precision, intent(in) :: dt
- double precision, intent(out) :: tshift, dlnA, cc_max
- integer, intent(out) :: ishift
-
- double precision :: cc, norm_s, norm ! cr_shift
- integer i1, i2, i, j, i_left, i_right, id_left, id_right
-
-!!$ ! these choices will slide the entire windowed record past the other
-!!$ cr_shift = nlen*dt
-!!$ i_left = ceiling( -1.0 * cr_shift / dt )
-!!$ i_right = floor( cr_shift / dt )
-!!$
-!!$ ! cross-correlation
-!!$ ishift = 0
-!!$ do i = i_left, i_right, 1
-!!$
-!!$ cc = 0.
-!!$ do j = 1, nlen
-!!$ if((j+i) > 1 .and. (j+i) < nlen) cc = cc + syn(j) * data(j+i)
-!!$ enddo
-!!$
-!!$ !if(cc > cc_max) then
-!!$ ! CHT, 07-Sept-2008: Do not allow time shifts larger than the specified input
-!!$ if(cc > cc_max .and. abs(i*dt) <= BEFORE_TSHIFT ) then
-!!$ cc_max = cc
-!!$ ishift = i
-!!$ endif
-!!$
-!!$ enddo
-!!$ tshift = ishift*dt
-
- ! initialise shift and cross correlation to zero
- ishift = 0
- cc_max = 0.0
-
- ! index of window limits
- i1 = 1
- i2 = nlen
-
- ! length of window (number of points, including ends)
- !nlen = i2 - i1 + 1
-
- ! power of synthetic signal in window
- norm_s = sqrt(sum(syn(i1:i2)*syn(i1:i2)))
-
- ! left and right limits of index (time) shift search
- ! NOTE: This looks OUTSIDE the time window of interest to compute TSHIFT and CC.
- ! How far to look outside, in theory, should be another parameter.
- ! However, it does not matter as much if the data and synthetics are
- ! zeroed outside the windows.
- i_left = -1*int(nlen/2.0)
- i_right = int(nlen/2.0)
-
- ! i is the index to shift to be applied to DATA (data)
- do i = i_left, i_right
-
- ! normalization factor varies as you take different windows of data
- id_left = max(1,i1+i) ! left index for data window
- id_right = min(nlen,i2+i) ! right index for data window
- norm = norm_s * sqrt(sum(data(id_left:id_right)*(data(id_left:id_right))))
-
- ! cc as a function of i
- cc = 0.
- do j = i1, i2 ! loop over full window length
- if((j+i).ge.1 .and. (j+i).le.nlen) cc = cc + syn(j)*data(j+i) ! d is shifted by i
- enddo
- cc = cc/norm
-
- if (cc > cc_max) then
- ! CHT: do not allow time shifts larger than the specified input range
- ! This is an important criterion, since it may pick TSHIFT_MIN or TSHIFT_MAX
- ! if cc_max within the interval occurs on the boundary.
- if( (i*dt >= TSHIFT_MIN).and.(i*dt <= TSHIFT_MAX) ) then
- cc_max = cc
- ishift = i
- endif
- endif
-
- enddo
- tshift = ishift*dt
-
- ! The previously used expression for dlnA of Dahlen and Baig (2002),
- ! is a first-order perturbation of ln(A1/A2) = (A1-A2)/A2 .
- ! The new expression is better suited to getting Gaussian-distributed
- ! values between -1 and 1, with dlnA = 0 indicating perfect fit, as before.
- dlnA = 0.5 * log( sum(data(i1:i2) * data(i1:i2)) / sum(syn(i1:i2) * syn(i1:i2)) )
-
- end subroutine compute_cc
-
- ! ---------------------------------------------------------------------------
-
- subroutine compute_average_error(data_dtw,syn_dtw_cc,syn_dtw_cc_dt,nlen,dt,sigma_dt,sigma_dlnA)
-
- ! CHT: Estimate the uncertainty in the CC measurement
- ! based on the integrated waveform difference between the data
- ! and the reconstructed synthetics.
- ! NOTE: We implement the exact equations that are in the Latex notes.
-
- implicit none
- double precision, dimension(*), intent(in) :: data_dtw, syn_dtw_cc, syn_dtw_cc_dt
- integer, intent(in) :: nlen
- double precision, intent(in) :: dt
- double precision, intent(inout) :: sigma_dt, sigma_dlnA
-
- double precision, dimension(nlen) :: syn_vtw_cc
- double precision :: sigma_dt_top, sigma_dlnA_top, sigma_dt_bot, sigma_dlnA_bot
- integer i
-
- ! compute synthetic velocity (shifted and stretched)
- do i = 2, nlen-1
- syn_vtw_cc(i) = (syn_dtw_cc(i+1) - syn_dtw_cc(i-1)) / (2.0*dt)
- enddo
- syn_vtw_cc(1) = (syn_dtw_cc(2) - syn_dtw_cc(1)) / dt
- syn_vtw_cc(nlen) = (syn_dtw_cc(nlen) - syn_dtw_cc(nlen-1)) / dt
-
- ! estimated uncertainty in cross-correlation travltime and amplitude
- sigma_dt_top = sum( (data_dtw(1:nlen) - syn_dtw_cc(1:nlen) )**2 )
- sigma_dlnA_top = sigma_dt_top
- sigma_dt_bot = sum( syn_vtw_cc(1:nlen)**2 )
- sigma_dlnA_bot = sum( (syn_dtw_cc_dt(1:nlen))**2 )
- sigma_dt = sqrt( sigma_dt_top / sigma_dt_bot )
- sigma_dlnA = sqrt( sigma_dlnA_top / sigma_dlnA_bot )
-
- if(0==1) then
- print *, ' sigma_dt : ', sigma_dt
- print *, ' sigma_dlnA : ', sigma_dlnA
- open(88,file='tshift.dat')
- do i = 1,nlen
- write(88,'(5e18.6)') (i-1)*dt, data_dtw(i), syn_dtw_cc(i), syn_dtw_cc_dt(i), syn_vtw_cc(i)
- enddo
- close(88)
- stop 'testing'
- endif
-
- ! make final adjustments to uncertainty estimate
- if (ERROR_TYPE == 0) then
- ! set uncertainty factors to 1 if you do not want to incorporate them
- ! into the adjoint sources and the misfit function values
- sigma_dt = 1.0
- sigma_dlnA = 1.0
-
- else
- ! make sure that the uncertainty estimates are not below the water level;
- ! otherwise, the adjoint sources will blow up unreasonably
- if( sigma_dt < DT_SIGMA_MIN) sigma_dt = DT_SIGMA_MIN
- if( sigma_dlnA < DLNA_SIGMA_MIN) sigma_dlnA = DLNA_SIGMA_MIN
-
- endif
-
- end subroutine compute_average_error
-
- ! ---------------------------------------------------------------------------
-
- subroutine write_average_meas(filename, imeas, dtau_meas, dlnA_meas, dtau_sigma, dlnA_sigma)
-
- implicit none
- character(len=*), intent(in) :: filename
- double precision, intent(in) :: dtau_meas, dlnA_meas, dtau_sigma, dlnA_sigma
- integer, intent(in) :: imeas
- character(len=40) :: stlab, suffix
-
- if ( imeas == 7 .or. imeas == 8 ) then
- stlab = 'Multitaper' ; suffix = 'average'
- else
- stlab = 'Cross-correlation' ; suffix = 'cc'
- endif
-
- if ( imeas .ge. 3 ) then
- if (DISPLAY_DETAILS) then
- print *, trim(stlab)//' average measurements:'
- print *, ' traveltime :', sngl(dtau_meas), ' +/- ', sngl(dtau_sigma)
- print *, ' amplitude :', sngl(dlnA_meas), ' +/- ', sngl(dlnA_sigma)
- endif
-
- ! write average error estimates to file
- if (OUTPUT_MEASUREMENT_FILES) then
- open(71,file=trim(filename)//'.dt_'//trim(suffix))
- write(71,*) dtau_meas, dtau_sigma
- close(71)
- open(72,file=trim(filename)//'.dlnA_'//trim(suffix))
- write(72,*) dlnA_meas, dlnA_sigma
- close(72)
- endif
- endif
-
- end subroutine write_average_meas
-
- ! ---------------------------------------------------------------------------
-
- subroutine write_trans(filename, trans, wvec, fnum, i_right, idf_new, df, tshift, dlnA, &
- phi_wt, abs_wt, dtau_wt, dlnA_wt, dtau_wa, dlnA_wa)
-
- ! The transfer function maps the synthetics to the CC-deconstructed data;
- ! the CC measurements then need to be applied to match the original data.
-
- implicit none
- character(len=*), intent(in) :: filename
- complex*16, intent(in) :: trans(:)
- double precision, intent(in) :: wvec(:), df, tshift, dlnA
- integer, intent(in) :: fnum, i_right, idf_new
- double precision, dimension(:), intent(out) :: phi_wt, abs_wt, dtau_wt, dlnA_wt
- double precision, intent(out), optional :: dtau_wa, dlnA_wa
-
- integer :: i, j
- double precision, dimension(NPT) :: fr
- double precision :: smth, smth1, smth2 ! f0
-
- abs_wt(:) = 0.
- phi_wt(:) = 0.
-
- ! note that with the idf_new value, these files are SUB-SAMPLED
- if (OUTPUT_MEASUREMENT_FILES) then
- open(10,file=trim(filename)//'.ph')
- open(20,file=trim(filename)//'.abs')
- open(30,file=trim(filename)//'.dlnA')
- open(40,file=trim(filename)//'.ph_cor')
- open(50,file=trim(filename)//'.dt')
- endif
-
- ! loop to calculate phase and amplitude
- do i = 1, i_right
- phi_wt(i) = atan2( aimag(trans(i)) , real(trans(i)) )
- abs_wt(i) = abs(trans(i))
- fr(i) = df*(i-1)
- if (mod(i,idf_new).eq.0 .and. OUTPUT_MEASUREMENT_FILES) then
- write(10,*) fr(i), phi_wt(i)
- write(20,*) fr(i), abs_wt(i)
- write(30,*) fr(i), log(abs_wt(i))
- endif
- enddo
-
- ! NOTE: the CC measurements dT (tshift) and dlnA are BOTH included
- dtau_wt(1) = tshift
- do i = 1, i_right
-
- if (i > 1 .and. i < i_right) then
- ! check the smoothness (2nd-order derivative) by 2*pi changes
- smth = phi_wt(i+1) + phi_wt(i-1) - 2.0 * phi_wt(i)
- smth1 = (phi_wt(i+1) + TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i)
- smth2 = (phi_wt(i+1) - TWOPI) + phi_wt(i-1) - 2.0 * phi_wt(i)
- if(abs(smth1).lt.abs(smth).and.abs(smth1).lt.abs(smth2).and. abs(phi_wt(i) - phi_wt(i+1)) > PHASE_STEP)then
- if (DISPLAY_DETAILS) print *, 'phase correction : 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1))
- do j = i+1, i_right
- phi_wt(j) = phi_wt(j) + TWOPI
- enddo
- endif
- if(abs(smth2).lt.abs(smth).and.abs(smth2).lt.abs(smth1).and. abs(phi_wt(i) - phi_wt(i+1)) > PHASE_STEP)then
- if (DISPLAY_DETAILS) print *, 'phase correction : - 2 pi', sngl(fr(i)), sngl(phi_wt(i) - phi_wt(i+1))
- do j = i+1, i_right
- phi_wt(j) = phi_wt(j) - TWOPI
- enddo
- endif
- endif
-
- ! add the CC measurements to the transfer function
- if (i > 1) dtau_wt(i) = (-1./wvec(i)) * phi_wt(i) + tshift
- dlnA_wt(i) = log(abs_wt(i)) + dlnA
- !dlnA_wt(i) = log(abs_wt(i))
- !!dlnA_wt(i) = abs_wt(i) - 1.
-
- if(mod(i,idf_new).eq.0 .and. OUTPUT_MEASUREMENT_FILES) then
- write(40,*) fr(i), phi_wt(i)
- write(50,*) fr(i), dtau_wt(i)
- endif
-
- enddo
-
- if (OUTPUT_MEASUREMENT_FILES) then
- close(10)
- close(20)
- close(30)
- close(40)
- close(50)
- endif
-
- ! average values of the transfer functions (optional output argument)
- if (present(dtau_wa) .and. present(dlnA_wa)) then
- dtau_wa = sum( dtau_wt(1:i_right) ) / i_right
- dlnA_wa = sum( dlnA_wt(1:i_right) ) / i_right
- endif
-
-!!$ if (DISPLAY_DETAILS) then
-!!$ print *, ' Taper traveltime measurement average : ', sngl(dtau_wa)
-!!$ print *, ' Taper amplitude measurement average : ', sngl(dlnA_wa)
-!!$ print *, ' i_right : ', i_right
-!!$ !f0 = 0.
-!!$ !call dwrite_ascfile_f(trim(filename)//'.dt_full',f0,df,i_right,dtau_wt(1:i_right))
-!!$ !call dwrite_ascfile_f(trim(filename)//'.dlnA_full',f0,df,i_right,dlnA_wt(1:i_right))
-!!$ !call dwrite_ascfile_f(trim(filename)//'.transfer_full',f0,df,i_right,abs(trans(1:i_right)))
-!!$ endif
-
- end subroutine write_trans
-
- ! --------------------------------------------------------------------
-
- subroutine deconstruct_dat_cc(filename,dat_dtw,tstart,dt,nlen,&
- ishift,tshift,dlnA,dat_dtw_cc)
-
- ! Using CC measurements, map the data to the synthetics;
- ! because the windows are picked based on the synthetics,
- ! we apply the transfer function from the synthetics to the
- ! CC-deconstructed data.
- implicit none
- character(len=*), intent(in) :: filename
- double precision, dimension(NPT), intent(in) :: dat_dtw
- integer, intent(in) :: ishift, nlen
- double precision, intent(in) :: tshift, dlnA, tstart, dt
- double precision, dimension(NPT), intent(out) :: dat_dtw_cc
- integer i
-
- ! apply time shift (-dT) to OBSERVED seismogram
- dat_dtw_cc(:) = dat_dtw(:)
- do i = 1, nlen
- if ((ishift+i) > 1 .and. (ishift+i) < nlen ) dat_dtw_cc(i) = dat_dtw(i+ishift)
- enddo
- ! fill the missing time window with the endpoint value
- if (ishift < 0) dat_dtw_cc(1:-ishift+1) = dat_dtw_cc(-ishift+2)
- if (ishift > 0) dat_dtw_cc(nlen-ishift:nlen) = dat_dtw_cc(nlen-ishift-1)
-
- ! apply cross-correlation amplitude measurement (-DlnA) to OBSERVED seismogram
- dat_dtw_cc(:) = dat_dtw_cc(:) * exp( -dlnA )
-
- !if (DISPLAY_DETAILS) then
- ! call dwrite_sacfile_f(datafile,'windowed_shifted_data.sac',tstart,nlen,dat_dtw0)
- !endif
-
- end subroutine deconstruct_dat_cc
-
- ! --------------------------------------------------------------------
-
- subroutine reconstruct_syn_cc(syn_dtw,tstart,dt,nlen,ishift,tshift,dlnA,syn_dtw_cc,syn_dtw_cc_dt)
-
- ! reconstruct the synthetics using cross-correlation measurements:
- ! (1) apply dT to get syn_dtw_cc_dt
- ! (2) apply dT and dlnA to get syn_dtw_cc
- implicit none
- double precision, dimension(NPT), intent(in) :: syn_dtw
- integer, intent(in) :: ishift, nlen
- double precision, intent(in) :: tshift, dlnA, tstart, dt
- double precision, dimension(NPT), intent(out) :: syn_dtw_cc, syn_dtw_cc_dt
- integer i
-
- ! shift synthetics by tshift (in the main program, we shift the data instead)
- ! ishift = tshift * dt
- syn_dtw_cc_dt(:) = syn_dtw(:)
- do i = 1, nlen
- if ((i-ishift) > 1 .and. (i-ishift) < nlen ) syn_dtw_cc_dt(i) = syn_dtw(i-ishift)
- enddo
- ! fill the missing time window with the endpoint value
- if (ishift > 0) syn_dtw_cc_dt(1:ishift+1) = syn_dtw_cc_dt(ishift+2)
- if (ishift < 0) syn_dtw_cc_dt(nlen+ishift:nlen) = syn_dtw_cc_dt(nlen+ishift-1)
-
- ! apply cross-correlation amplitude measurement
- syn_dtw_cc(:) = 0.
- syn_dtw_cc(:) = syn_dtw_cc_dt * exp( dlnA ) ! based on dlnA = ln(Aobs/Asyn)
- !syn_dtw_cc(:) = syn_dtw_cc_dt * (1. + dlnA) ! based on first-order approximation of dlnA
-
- end subroutine reconstruct_syn_cc
-
- ! -----------------------------------------------------------------------
-
- subroutine reconstruct_syn(filename, syn_dtwo, wvec, dtau_wt, dlnA_wt, &
- i_right, tstart, dt, nlen, syn_dtw_mt, syn_dtw_mt_dt)
-
- ! reconstruct the synthetics using multitaper measurements:
- ! (1) apply dtau(w) and dlnA(w) to get syn_dtw_mt0
- implicit none
- character(len=*), intent(in) :: filename
- complex*16, dimension(:), intent(in) :: syn_dtwo
- double precision, dimension(:), intent(in) :: wvec, dtau_wt, dlnA_wt
- integer, intent(in) :: i_right, nlen
- double precision, intent(in) :: tstart, dt
- double precision, dimension(:), intent(out) :: syn_dtw_mt, syn_dtw_mt_dt
-
- complex*16, dimension(NPT) :: wseis_recon
- integer i
- double precision omega
-
- ! apply transfer function to synthetics (phase and amplitude)
- syn_dtw_mt(:) = 0.
- wseis_recon(:) = cmplx(0.,0.)
- do i = 1,i_right
- omega = wvec(i)
- wseis_recon(i) = syn_dtwo(i) * exp(dlnA_wt(i)) * exp(-CCI*omega*dtau_wt(i))
- !wseis_recon(i) = syn_dtwo(i) * (1.+ dlnA_wt(i)) * exp(-CCI*omega*dtau_wt(i))
- !wseis_recon(i) = syn_dtwo(i) * trans_mtm(i) * exp(-CCI*omega*tshift)
- enddo
- call fftinv(LNPT,wseis_recon,REVERSE_FFT,dt,syn_dtw_mt)
-
- ! apply phase shifts only
- syn_dtw_mt_dt(:) = 0.
- wseis_recon(:) = cmplx(0.,0.)
- do i = 1,i_right
- omega = wvec(i)
- wseis_recon(i) = syn_dtwo(i) * exp(-CCI*omega*dtau_wt(i))
- enddo
- call fftinv(LNPT,wseis_recon,REVERSE_FFT,dt,syn_dtw_mt_dt)
-
- if (OUTPUT_MEASUREMENT_FILES) then
- call dwsac1(trim(filename)//'.recon_syn.sac',syn_dtw_mt,nlen,tstart,dt)
- call dwsac1(trim(filename)//'.recon_syn_dt.sac',syn_dtw_mt_dt,nlen,tstart,dt)
-!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn.sac',tstart,nlen,syn_dtw_mt)
-!!$ call dwrite_sacfile_f(datafile,trim(filename)//'.recon_syn_dt.sac',tstart,nlen,syn_dtw_mt_dt)
-!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn',tstart,dt,nlen,syn_dtw_mt)
-!!$ !call dwrite_ascfile_f(trim(filename)//'.recon_syn_dt',tstart,dt,nlen,syn_dtw_mt_dt)
- endif
-
- end subroutine reconstruct_syn
-
- ! -----------------------------------------------------------------------
-
-!!$ subroutine check_recon_quality(filename,dat_dtw_cc,syn_dtw,dat_dtw,syn_dtw_mt,nlen,dt,tshift,tshift_f1f2,cc_max_f1f2,cc_max)
-!!$
-!!$ character(len=*), intent(in) :: filename
-!!$ double precision, dimension(:), intent(in) :: dat_dtw_cc, syn_dtw, dat_dtw, syn_dtw_mt
-!!$ double precision, intent(in) :: dt, tshift
-!!$ integer, intent(in) :: nlen
-!!$ double precision, intent(out) :: tshift_f1f2, cc_max_f1f2, cc_max
-!!$
-!!$ double precision :: f1,f2, dlnA_f1f2
-!!$
-!!$ ! Using Alessia's subroutine
-!!$ ! First the shifted_obs_win vs the synthetic
-!!$ call f1f2_calc(dat_dtw_cc,syn_dtw,nlen,1,nlen,dt, f1,f2,tshift_f1f2,cc_max_f1f2,dlnA_f1f2)
-!!$
-!!$ cc_max = cc_max_f1f2
-!!$ if (OUTPUT_MEASUREMENT_FILES) then
-!!$ open(10,file=trim(filename)//'.quality')
-!!$ write(10,*) '<--------- F1 ------ F2 ---- tshift -- cc_max --- dlnA -->'
-!!$ write(10,"(a,5F10.5)") 'Before',sngl(F1),sngl(F2),sngl(tshift),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
-!!$ endif
-!!$ if (DISPLAY_DETAILS) then
-!!$ write(*,*) '<--------- F1 ------ F2 ---- tshift -- cc_max --- dlnA -->'
-!!$ write(*,"(a,5F10.5)") 'Before',sngl(F1),sngl(F2),sngl(tshift),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
-!!$ endif
-!!$
-!!$ ! Then the obs_win vs the reconstructed obs
-!!$ call f1f2_calc(dat_dtw,syn_dtw_mt,nlen,1,nlen,dt, f1,f2,tshift_f1f2,cc_max_f1f2,dlnA_f1f2)
-!!$
-!!$ if (OUTPUT_MEASUREMENT_FILES) then
-!!$ write(10,"(a,5F10.5)") 'After ',sngl(F1),sngl(F2),sngl(tshift_f1f2),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
-!!$ close(10)
-!!$ endif
-!!$
-!!$ if (DISPLAY_DETAILS) write(*,"(a,5F10.5)") 'After ',sngl(F1),sngl(F2),sngl(tshift_f1f2),sngl(cc_max_f1f2),sngl(dlnA_f1f2)
-!!$
-!!$ end subroutine check_recon_quality
-
-!-------------------------------------------------------------------
-
- subroutine interpolate_syn(syn,t1,dt1,npt1,t2,dt2,npt2)
-
- implicit none
- double precision, dimension(:),intent(inout) :: syn
- integer,intent(in) :: npt1,npt2
- double precision,intent(in) :: t1,dt1,t2,dt2
-
- double precision :: syn1(NDIM), time, tt
- integer i, ii
-
- ! initializes trace holding interpolated values
- syn1(1:npt2) = 0.
-
- ! loops over number of time steps in complete trace
- do i = 1, npt2
-
- ! sets time (in s) at this time step:
- ! t2 : start time of trace
- ! dt2: delta_t of a single time step
- time = t2 + (i-1) * dt2
-
- ! checks if time is within measurement window
- ! t1: start time of measurement window
- ! npt1: number of time steps in measurement window
- ! dt1: delta_t of a single time step in measurement window
- if (time > t1 .and. time < t1 + (npt1-1)*dt1) then
-
- ! sets index of time steps within this window: is 1 at the beginning of window
- ii = floor((time-t1)/dt1) + 1
-
- ! time increment within this single time step to match the exact value of time
- tt = time - ((ii-1)*dt1 + t1)
-
- ! interpolates value of trace for the exact time
- syn1(i) = (syn(ii+1)-syn(ii)) * tt/dt1 + syn(ii)
- endif
- enddo
-
- ! saves interpolated values to output trace
- syn(1:npt2) = syn1(1:npt2)
-
- end subroutine interpolate_syn
-
-!-------------------------------------------------------------------
-
- subroutine taper_start(syn,npt,itmax)
-
- implicit none
- double precision, dimension(:),intent(inout) :: syn
- integer,intent(in) :: npt, itmax
- double precision :: Wt
- integer :: i !,imax
-
- !imax = maxloc(abs(syn),dim=1) ! index of the max value
- !Wt = TWOPI / (2.0*(imax-1)) ! period of the taper
- Wt = TWOPI / (2.0*(itmax-1)) ! period of the taper
-
- if(DISPLAY_DETAILS) print *, 'tapering start of record from index 1 to index ', itmax
-
- ! apply a cosine taper from the start to the max value,
- ! such that the starting point is exactly zero
- do i = 1, itmax
- syn(i) = syn(i) * ( 0.5*(1 - cos(Wt*(i-1))) )
- enddo
-
- end subroutine taper_start
-
-!-------------------------------------------------------------------
-
-
- subroutine read_par_file(fstart0,fend0,tt,dtt,nn,chan)
-
- implicit none
- double precision, intent(out) :: fstart0,fend0,tt,dtt
- integer, intent(out) :: nn
- character(len=10), intent(out) :: chan
- integer :: ios
-
- ! input file MEASUREMENT.PAR -- see write_par_file.pl for details
-
- OUT_DIR = 'OUTPUT_FILES' ! default
-
- open(10,file='MEASUREMENT.PAR',status='old',iostat=ios)
- read(10,*) tt,dtt,nn
- read(10,*) imeas0
- read(10,*) chan
- read(10,*) TLONG, TSHORT
- read(10,*) RUN_BANDPASS
- read(10,*) DISPLAY_DETAILS
- read(10,*) OUTPUT_MEASUREMENT_FILES
- read(10,*) COMPUTE_ADJOINT_SOURCE
- read(10,*) TSHIFT_MIN, TSHIFT_MAX
- read(10,*) DLNA_MIN, DLNA_MAX
- read(10,*) CC_MIN
- read(10,*) ERROR_TYPE
- read(10,*) DT_SIGMA_MIN
- read(10,*) DLNA_SIGMA_MIN
- read(10,*) ITAPER
- read(10,*) WTR,NPI
- read(10,*) DT_FAC
- read(10,*) ERR_FAC
- read(10,*) DT_MAX_SCALE
- read(10,*) NCYCLE_IN_WINDOW
- close(10)
-
- imeas = imeas0
-
- ! check the read-in values
- print *, 'INPUTS FROM MEASUREMENT.PAR :'
- print *, ' tt, dtt, nn : ',tt,dtt,nn
- print *, ' imeas : ',imeas
- print *, ' chan : ',chan
- print *, ' TLONG, TSHORT : ',TLONG, TSHORT
- fstart0 = 1./TLONG ; fend0 = 1./TSHORT
- print *, ' fstart, fend : ', fstart0, fend0
- print *, ' RUN_BANDPASS : ',RUN_BANDPASS
- print *, ' DISPLAY_DETAILS : ',DISPLAY_DETAILS
- print *, ' OUTPUT_MEASUREMENT_FILES : ',OUTPUT_MEASUREMENT_FILES
- print *, ' COMPUTE_ADJOINT_SOURCE : ',COMPUTE_ADJOINT_SOURCE
- print *, ' TSHIFT_MIN, TSHIFT_MAX : ',TSHIFT_MIN, TSHIFT_MAX
- print *, ' DLNA_MIN, DLNA_MAX : ',DLNA_MIN, DLNA_MAX
- print *, ' CC_MIN : ',CC_MIN
- print *, ' ERROR_TYPE : ',ERROR_TYPE
- print *, ' DT_SIGMA_MIN : ',DT_SIGMA_MIN
- print *, ' DLNA_SIGMA_MIN : ',DLNA_SIGMA_MIN
- print *, ' ITAPER : ',ITAPER
- print *, ' WTR, NPI : ',WTR,NPI
- print *, ' DT_FAC : ',DT_FAC
- print *, ' ERR_FAC : ',ERR_FAC
- print *, ' DT_MAX_SCALE : ',DT_MAX_SCALE
- print *, ' NCYCLE_IN_WINDOW : ',NCYCLE_IN_WINDOW
- !stop 'checking PAR file input'
-
- ! old format way..
- ! open(10,file='MEASUREMENT.PAR',status='old',iostat=ios)
- ! read(10,'(a)') out_dir
- ! read(10,*) is_mtm0
- ! read(10,*) wtr,npi
- ! read(10,*) iker0
- ! read(10,*) RUN_BANDPASS
- ! read(10,*) TLONG, TSHORT
- ! read(10,*) tt,dtt,nn
- ! read(10,*) DISPLAY_DETAILS
- ! read(10,*) OUTPUT_MEASUREMENT_FILES
- ! read(10,*) INCLUDE_ERROR
- ! read(10,*) DT_FAC
- ! read(10,*) ERR_FAC
- ! read(10,*) DT_MAX_SCALE
- ! read(10,*) NCYCLE_IN_WINDOW
- ! read(10,*) BEFORE_QUALITY, AFTER_QUALITY
- ! read(10,*) BEFORE_TSHIFT, AFTER_TSHIFT
- ! read(10,*) DT_SIGMA_MIN, DLNA_SIGMA_MIN
- ! close(10)
- !
- ! out_dir = adjustl(out_dir)
- ! iker = iker0
- ! is_mtm = is_mtm0
- !
- ! ! check the read-in values
- ! print *, 'INPUTS FROM MEASUREMENT.PAR :'
- ! print *, ' is_mtm : ',is_mtm
- ! print *, ' wtr, npi : ',wtr,npi
- ! print *, ' iker : ',iker
- ! print *, ' RUN_BANDPASS :',RUN_BANDPASS
- ! print *, ' TLONG, TSHORT : ',TLONG, TSHORT
- ! fstart0 = 1./TLONG ; fend0 = 1./TSHORT
- ! print *, ' fstart, fend :', fstart0, fend0
- ! print *, ' tt, dtt, nn : ',tt,dtt,nn
- ! print *, ' out_dir : ',trim(out_dir)
- ! print *, ' DISPLAY_DETAILS :',DISPLAY_DETAILS
- ! print *, ' OUTPUT_MEASUREMENT_FILES :',OUTPUT_MEASUREMENT_FILES
- ! print *, ' INCLUDE_ERROR :',INCLUDE_ERROR
- ! print *, ' DT_FAC :',DT_FAC
- ! print *, ' ERR_FAC :',ERR_FAC
- ! print *, ' DT_MAX_SCALE :',DT_MAX_SCALE
- ! print *, ' NCYCLE_IN_WINDOW :',NCYCLE_IN_WINDOW
- ! print *, ' BEFORE_QUALITY, AFTER_QUALITY :',BEFORE_QUALITY, AFTER_QUALITY
- ! print *, ' BEFORE_TSHIFT, AFTER_TSHIFT :',BEFORE_TSHIFT, AFTER_TSHIFT
- ! print *, ' DT_SIGMA_MIN, DLNA_SIGMA_MIN :',DT_SIGMA_MIN, DLNA_SIGMA_MIN
- ! !stop 'checking PAR file input'
- ! apply filter (this should EXACTLY match the filter used in the windowing code)
- !trbdndw = 0.3
- !a = 30.
- !iord = 4
- !passes = 2
-
- ! ray density
- if( DO_RAY_DENSITY_SOURCE ) ERROR_TYPE = 0
-
- ! assign additional parameters and stop for certain inconsistencies
- if (fstart0.ge.fend0) then
- print *, 'Check input frequency range of the signal'
- stop
- endif
-
- if (nn > NDIM) then
- print *, 'Error: Change interpolation nn or NDIM'
- stop
- endif
-
- ! for CC kernels, ITAPER must be a single taper (2 or 3)
- if ( (ITAPER==1) .and. ((imeas.ge.3).and.(imeas.le.6)) ) then
- print *, 'Error: Change ITAPER to 2 or 3'
- stop
- endif
-
- if ( (imeas==1).or.(imeas==2) ) then
- is_mtm0 = 0
- elseif ( (imeas.ge.3).and.(imeas.le.6) ) then
- is_mtm0 = ITAPER ! 2 or 3
- elseif ( (imeas==7).or.(imeas==8) ) then
- is_mtm0 = 1 ! multitaper required for MT adjoint source
- else
- print *, 'Error: imeas must by 1-8'
- stop
- endif
-
- is_mtm = is_mtm0
- print *, ' is_mtm :',is_mtm
-
- end subroutine read_par_file
-
-!-------------------------------------------------------------------
-
- subroutine get_sacfile_header(data_file,yr,jda,ho,mi,sec,ntw,sta, &
- comp,dist,az,baz,slat,slon)
-
- implicit none
- character(len=*),intent(in) :: data_file
-
- integer,intent(out):: yr,jda,ho,mi
- double precision,intent(out):: sec,dist,az,baz,slat,slon
- !real*8,intent(out):: sec,dist,az,baz,slat,slon
- character(len=*),intent(out) :: ntw,sta,comp
- !real*8 :: tmp
- real :: tmp
-
- integer :: nsec,msec !,i,klen
- integer :: nerr
-
- ! integer header variables
- call getnhv('nzyear',yr,nerr)
- call getnhv('nzjday',jda,nerr)
- call getnhv('nzhour',ho,nerr)
- call getnhv('nzhour',mi,nerr)
- call getnhv('nzmin',nsec,nerr)
- call getnhv('nzmsec',msec,nerr)
-
- sec=nsec+msec/1000.0
-
- ! string headers
- call getkhv('knetwk',ntw,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: knetwk'
- call exit(-1)
- endif
-
- call getkhv('kstnm',sta,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: kstnm'
- call exit(-1)
- endif
-
- call getkhv('kcmpnm',comp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: kcmpnm'
- call exit(-1)
- endif
-
- ! decimal headers
- call getfhv('dist',tmp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: dist'
- call exit(-1)
- endif
- dist = tmp
-
- call getfhv('az',tmp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: az'
- call exit(-1)
- endif
- az = tmp
-
- call getfhv('baz',tmp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: baz'
- call exit(-1)
- endif
- baz = tmp
-
- call getfhv('stlo',tmp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: stlo'
- call exit(-1)
- endif
- slon = tmp
-
- call getfhv('stla',tmp,nerr)
- if(nerr .ne. 0) then
- write(*,*)'Error reading variable: stla'
- call exit(-1)
- endif
- slat = tmp
-
-!!$ ! integer header variables
-!!$ call saclst_iheader_f(data_file,'nzyear', yr)
-!!$ call saclst_iheader_f(data_file,'nzjday', jda)
-!!$ call saclst_iheader_f(data_file,'nzhour', ho)
-!!$ call saclst_iheader_f(data_file,'nzmin', mi)
-!!$ call saclst_iheader_f(data_file,'nzsec', nsec)
-!!$ call saclst_iheader_f(data_file,'nzmsec', msec)
-!!$
-!!$ sec=nsec+msec/1000.0
-!!$
-!!$ call saclst_kheader_f(data_file,'knetwk',ntw,klen)
-!!$ call saclst_kheader_f(data_file,'kstnm', sta,klen)
-!!$ call saclst_kheader_f(data_file,'kcmpnm',comp,klen)
-!!$
-!!$ call dsaclst_fheader_f(data_file,'dist',dist)
-!!$ call dsaclst_fheader_f(data_file,'az', az)
-!!$ call dsaclst_fheader_f(data_file,'baz', baz)
-!!$ call dsaclst_fheader_f(data_file,'stlo',slon)
-!!$ call dsaclst_fheader_f(data_file,'stla',slat)
-
- end subroutine get_sacfile_header
-
-end module mt_sub
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub2.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub2.f90 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/mt_sub2.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,657 +0,0 @@
-module mt_sub2
-
-
- use mt_constants
-
- implicit none
-
-! TOLERRANCE CONTROL
- double precision, parameter :: TOL=1e-7
-
-contains
-
-!------------------------------------------------------------------
- subroutine fft(n,xi,zzign,dt)
-! Fourier transform
-! This inputs AND outputs a complex function.
-! The convention is FFT --> e^(-iwt)
-! numerical factor for Plancherel theorem: planch_fac = dble(NPT * dt * dt)
-!------------------------------------------------------------------
- complex*16, dimension(*) :: xi
- integer :: n
- double precision :: dt
-
- double precision, parameter :: PI = 3.141592653589793d+00
- complex*16 :: wk, hold, q
- double precision :: m(25)
- double precision :: zzign,zign,flx,v
- integer :: lblock,k,fk,jh,ii,istart
- integer :: l,iblock,nblock,i,lbhalf,j,lx
-
- ! sign must be +1. or -1.
- if(zzign >= 0.) then
- zign = 1.
- else
- zign = -1.
- endif
-
- lx = 2**n
-
- ! checks bounds
- if( lx > NPT ) stop 'error fft increase NPT, or decrease n'
-
-
-
- do 1 i=1,n
- 1 m(i) = 2**(n-i)
- do 4 l=1,n
- nblock = 2**(l-1)
- lblock = lx/nblock
- lbhalf = lblock/2
- k = 0
- do 4 iblock=1,nblock
- fk = k
- flx = lx
-
- v = zign*2.*PI*fk/flx ! Fourier convention
-
- wk = cmplx(cos(v),-sin(v)) ! sign change to -sin(v) 17-Nov-2006
- istart = lblock*(iblock-1)
-
- do 2 i=1,lbhalf
- j = istart+i
- jh = j+lbhalf
- ! checks bounds
- if( jh < 1 .or. jh > NPT ) stop 'error fft bounds'
-
- q = xi(jh)*wk
- xi(jh) = xi(j)-q
- xi(j) = xi(j)+q
- 2 continue
-
- do 3 i=2,n
- ii = i
- if(k < m(i)) go to 4
- 3 k = k-m(i)
- 4 k = k+m(ii)
- k = 0
- do 7 j=1,lx
- if(k < j) go to 5
- hold = xi(j)
- ! checks bounds
- if( k+1 < 1 .or. k+1 > NPT ) stop 'error fft k bounds'
- xi(j) = xi(k+1)
- xi(k+1) = hold
- 5 do 6 i=1,n
- ii = i
- if(k < m(i)) go to 7
- 6 k = k-m(i)
- 7 k = k+m(ii)
-
- ! final steps deal with dt factors
- if(zign > 0.) then ! FORWARD FFT
- do i = 1,lx
- xi(i) = xi(i)*dt ! multiplication by dt
- enddo
-
- else ! REVERSE FFT
- flx = flx*dt
- do i = 1,lx
- xi(i) = xi(i)/flx ! division by dt
- enddo
- endif
-
- end subroutine fft
-
-!------------------------------------------------------------------
- subroutine fftinv(npow,s,zzign,dt,r)
-! inverse Fourier transform -- calls fft
-!------------------------------------------------------------------
-
- !implicit real*8(a-h,o-z)
- !dimension r(4096*4)
- !complex s(4096*4)
-
- complex*16, intent(in) :: s(*)
- double precision, intent(out) :: r(*) ! note this is REAL
-
- double precision :: dt,zzign,zign
- integer :: npow, nsmp, nhalf, i
-
- nsmp = 2**npow
- nhalf = nsmp/2
- call rspec(s,nhalf) ! re-structuring
-
- zign=zzign
- call fft(npow,s,zign,dt) ! Fourier transform
-
- do i = 1,nsmp
- r(i) = real(s(i)) ! REAL part
- enddo
-
- end subroutine fftinv
-
-!------------------------------------------------------------------
- subroutine rspec(s,np2)
-!------------------------------------------------------------------
-
- !implicit real*8(a-h,o-z)
- !complex s(4096*4)
-
- complex*16 :: s(*)
- integer :: np2,n,n1,i
-
- n = 2*np2
- n1 = np2+1
-
- s(n1) = 0.
-! s(1) = 0.
- s(1) = cmplx( real(s(1)),0.)
-
- do i = 1,np2
- s(np2+i) = conjg(s(np2+2-i))
- enddo
-
- end subroutine rspec
-
-!------------------------------------------------------------------
- subroutine staper(nt, fw, nev, v, ndim, a, w)
-!------------------------------------------------------------------
-!$$$$ calls tsturm, root
-! Slepian - Thomson multi-taper procedure
-! Slepian, D. 1978 Bell Sys Tech J v57 n5 1371-1430
-! Thomson, D. J. 1982 Proc IEEE v70 n9 1055-1096
-! nt the number of points in the series
-! fw the time-bandwidth product (number of Rayleigh bins)
-! nev the desired number of tapers
-! v the eigenvectors (tapers) are returned in v(.,nev)
-! a, w work arrays dimensioned at least nt long (nt+1, nt odd)
-! a(1..nev) contains bandwidth retention factors on output.
-! The tapers are the eigenvectors of the tridiagonal matrix sigma(i,j)
-! [see Slepian(1978) eq 14 and 25.] They are also the eigenvectors of
-! the Toeplitz matrix eq. 18. We solve the tridiagonal system in
-! tsturm for the tapers and use them in Slepians eq 18 to get the
-! bandwidth retention factors (i.e. the eigenvalues) Thomson's
-! normalisation is used with no attention to sign.
- !implicit real*8(a-h,o-z)
- !dimension a(*),w(*),v(ndim,*)
- !parameter (pi=3.14159265358979d0,r2=1.414213562373095d0)
-
- integer :: nt, nev, ndim
- double precision :: fw
- double precision :: v(ndim,*), a(*), w(*)
-
- double precision, parameter :: PI = 3.141592653589793d+00
- integer :: i,j,k,m
- integer :: nxi, lh, lp1, neven, nodd, ntot, kk, kmax, nlow, nup
- double precision :: r2,om,com,hn,asav,rbd,dc,sm,s,sn,vmax
-
- !-------------------------
-
- r2 = sqrt(2.)
-
- if(nt < 2) return
- nxi=mod(nt,2)
- lh=(nt/2)+nxi
- lp1=nt+1
- om=2.*PI*fw/nt
- com=cos(om)
- hn=0.5*dble(lp1)
- do 10 i=1,lh
- a(i)=com*(i-hn)**2
- 10 w(i)=0.5*dble(i*(nt-i))
- if(nxi == 0) then
- asav=a(lh)-w(lh)
- a(lh)=a(lh)+w(lh)
- rbd=1./(a(lh)+w(lh-1))
- else
- asav=w(lh-1)
- rbd=1./(w(lh)+w(lh-1))
- w(lh-1)=r2*w(lh-1)
- endif
- do 15 i=1,lh
- a(i+lh)=w(i)*rbd
- w(i)=a(i+lh)**2
- 15 a(i)=a(i)*rbd
- neven=max0((nev+1)/2,1)
- nodd=nev-neven
-! Do the even tapers
- call tsturm(nt,lh,a,a(lh+1),w,neven,v,ndim,w(lh+1),0)
- do 20 i=1,neven
- k=2*i-1
- if(nxi == 1) v(lh,k)=r2*v(lh,k)
- do 20 j=1,lh
- 20 v(lp1-j,k)=v(j,k)
- if(nodd <= 0) goto 34
-! Do the odd tapers
- if(nxi == 0) then
- a(lh)=asav*rbd
- else
- a(nt)=asav*rbd
- w(lh-1)=asav*asav
- endif
- call tsturm(nt,lh-nxi,a,a(lh+1),w,nodd,v,ndim,w(lh+1),1)
- do 30 i=1,nodd
- k=2*i
- if(nxi == 1) v(lh,k)=0.
- do 30 j=1,lh
- 30 v(lp1-j,k)=-v(j,k)
- 34 ntot=neven+nodd
-! Calculate bandwidth retention parameters
- dc=2.*com
- sm=0.
- s=sin(om)
- w(1)=om/PI
- w(2)=s/PI
- do 35 j=3,nt
- sn=dc*s-sm
- sm=s
- s=sn
- 35 w(j)=s/(PI*(j-1))
- do 55 m=1,ntot
- vmax=abs(v(1,m))
- kmax=1
- do 40 kk=2,lh
- if(abs(v(kk,m)) <= vmax) goto 40
- kmax=kk
- vmax=abs(v(kk,m))
- 40 continue
- a(m)=0.
- nlow=kmax-1
- do 45 j=1,nlow
- 45 a(m)=a(m)+w(j+1)*v(nlow+1-j,m)
- nup=nt-nlow
- do 50 j=1,nup
- 50 a(m)=a(m)+w(j)*v(nlow+j,m)
- 55 a(m)=a(m)/v(kmax,m)
- return
-
- end subroutine staper
-
-!------------------------------------------------------------------
- subroutine tsturm(nt,n,a,b,w,nev,r,ndim,ev,ipar)
-!------------------------------------------------------------------
-!$$$$ calls root
-! Uses bisection and Sturm counting to isolate the eigenvalues of the
-! symmetric tridiagonal matrix with main diagonal a(.) and sub/super
-! diagonal b(.). Newton's method is used to refine the eigenvalue in
-! subroutine root then direct recursion is used to get the eigenvector
-! as this is always stable. Note ipar=0 for even tapers =1 for odd
-! tapers
- !implicit real*8(a-h,o-z)
- !parameter (epsi=1.d-15,epsi1=5.d-15)
- !dimension a(*),b(*),ev(*),w(*),r(ndim,*)
-
- double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15
-
- double precision, dimension(ndim) :: a, b, w, ev
- double precision, dimension(ndim,*) :: r
- integer :: nt,n,ndim,nev,ipar
-
- !double precision, dimension(ndim) :: bb
- double precision :: q,el,elam,u,umeps,x,ddot,rnorm
- integer :: i,j,ik,iag,m,jk,jm1
-
- !-------------------------
-
- if(n <= 0.or.nev <= 0) return
- umeps=1.-epsi
- do 5 i=1,nev
- 5 ev(i)=-1.
- u=1.
- do 1000 ik=1,nev
- if(ik > 1) u=ev(ik-1)*umeps
- el=min(ev(ik),u)
- 10 elam=0.5*(u+el)
- if(abs(u-el) <= epsi1) goto 35
- iag=0
- q=a(1)-elam
- if(q >= 0.) iag=iag+1
- do 15 i=2,n
- if(q == 0.) x=abs(b(i-1))/epsi
- if(q /= 0.) x=w(i-1)/q
- q=a(i)-elam-x
- if(q >= 0.) iag=iag+1
- if(iag > nev) goto 20
- 15 continue
- if(iag >= ik) go to 20
- u=elam
- go to 10
- 20 if(iag == ik) go to 30
- m=ik+1
- do 25 i=m,iag
- 25 ev(i)=elam
- el=elam
- go to 10
- 30 el=elam
- call root(u,el,elam,a,b,w,n,ik)
- 35 ev(ik)=elam
- jk=2*ik+ipar-1
- r(1,jk)=1.
- r(2,jk)=-(a(1)-ev(ik))/b(1)
- ddot=1.+r(2,jk)*r(2,jk)
- jm1=2
- do 45 j=3,n
- r(j,jk)=-((a(jm1)-ev(ik))*r(jm1,jk)+b(j-2)*r(j-2,jk))/b(jm1)
- ddot=ddot+r(j,jk)*r(j,jk)
- 45 jm1=j
- rnorm=sqrt(nt/(2.*ddot))
- do 50 j=1,n
- 50 r(j,jk)=r(j,jk)*rnorm
- 1000 continue
- return
-
- end subroutine tsturm
-
-!------------------------------------------------------------------
- subroutine root(u,el,elam,a,bb,w,n,ik)
-!------------------------------------------------------------------
-
- !implicit real*8(a-h,o-z)
- !parameter (epsi = 1.d-15, epsi1 = 5.d-15)
- !dimension a(*),bb(*),w(*)
-
- double precision, parameter :: epsi = 1.d-15, epsi1 = 5.d-15
- double precision :: u,el,elam
- double precision, dimension(*) :: a,bb,w
- integer :: n,ik
-
- double precision :: an,b,bm,bn,del,x
- integer :: i,iag
-
- !----------------------
-
- 5 elam=0.5*(u+el)
- 10 if(abs(u-el) <= 1.5*epsi1) return
- an=a(1)-elam
- b=0.
- bn=-1./an
- iag=0
- if(an >= 0.) iag=iag+1
- do 20 i=2,n
- if(an == 0.) x=abs(bb(i-1))/epsi
- if(an /= 0.) x=w(i-1)/an
- an=a(i)-elam-x
- if(an == 0.) an=epsi
- bm=b
- b=bn
- bn=((a(i)-elam)*b-bm*x-1.)/an
- if(an >= 0.) iag=iag+1
- 20 continue
- if(iag == ik) goto 25
- u=elam
- goto 30
- 25 el=elam
- 30 del=1./bn
- if(abs(del) <= epsi1) del=sign(epsi1,del)
- elam=elam-del
- if(elam >= u.or.elam <= el) goto 5
- goto 10
-
- end subroutine root
-!-------------------------------------------
-
-! -----------------------------------------------------------------
-!
-! Alessia Maggi, May 2005
-!
-! -----------------------------------------------------------------
-! $Id:$
-! -----------------------------------------------------------------
-!
-! Implementation of the Ritsema & van Heijst 2002 quality checking
-! technique.
-! Calculation of two quantities:
-!
-! F1 = sum_t [ d(t) - s(t)]^2 / sum_t [d(t)]^2
-!
-! F2 = min[A1,A2] / max [A1,A2]
-!
-! A1 minimizes : sum_t [ d(t) - A1*s(t)]^2
-! A2 minimizes : sum_t [ (1/A2)*d(t) - s(t)]^2
-!
-! Inputs:
-! -------
-! d : data timeseries array
-! s : synthetic timeseries array
-! npts : number of points in the two timeseries
-
-! Outputs:
-! --------
-! F1, F2,dlnA,cc_max : defined above
-!
-! Calls numerical recipies routines :
-! mnbrak, golden
-!
-! -----------------------------------------------------------------
-
-!!$ subroutine F1F2_calc(d,s,npts,i1,i2,dt,F1,F2,tshift,cc_max,dlnA)
-!!$
-!!$
-!!$ double precision, dimension(*), intent(in) :: d, s
-!!$ integer, intent(in) :: npts,i1,i2
-!!$ double precision, intent (in) :: dt
-!!$ double precision, intent(out) :: F1,F2,tshift,cc_max,dlnA
-!!$
-!!$ double precision, dimension(:), allocatable :: s_cor,d_loc
-!!$
-!!$ double precision :: cr_shift, cc
-!!$ integer :: n_left,n_right,ishift,npts_win, i, j
-!!$
-!!$ real ax,bx,cx,fa,fb,fc,f1_min,f2_min,f1_top,f1_bot,A1,A2
-!!$ real golden !f1,f2
-!!$
-!!$ npts_win=i2-i1+1
-!!$
-!!$! allocate memory for s_cor (the corrected synthetic)
-!!$ allocate(s_cor(npts_win))
-!!$ allocate(d_loc(npts_win))
-!!$
-!!$ d_loc(1:npts_win)=d(i1:i2)
-!!$
-!!$! do cross-correlation:
-!!$ call xcorr_calc(d,s,npts,i1,i2,ishift,cc_max)
-!!$! n_left = int((-1.0) * cr_shift / dt)
-!!$! n_right = int(cr_shift / dt)
-!!$! ishift=0
-!!$! cc_max=0.
-!!$! do i = n_left, n_right
-!!$! cc = 0
-!!$! do j = 1, npts
-!!$! if((j+i).gt.1.and.(j+i).lt.npts) cc = cc + s(j) * d(j+i)
-!!$! enddo
-!!$! if( cc .gt. cc_max) then
-!!$! cc_max = cc
-!!$! ishift = i
-!!$! endif
-!!$! enddo
-!!$ tshift=ishift*dt
-!!$
-!!$! apply time shift to synthetic seismogram
-!!$! write(*,*)'shift synth seismogram by ', tshift, 'seconds'
-!!$ do i = 1, npts_win
-!!$ s_cor(i) = 0
-!!$ if( (i1-1+i-ishift) .gt. 1 .and. (i1-1+i-ishift) .lt.npts ) s_cor(i) = s(i1-1+i-ishift)
-!!$ enddo
-!!$
-!!$! DEBUG: output
-!!$! open(unit=11, file='DEBUG_calcF1F2.dat')
-!!$! do i = 1, npts_win
-!!$! write(11,'(4(e12.4,1x))') b+(i-1)*dt, s_cor(i), s(i1-1+i), d(i1-1+i)
-!!$! enddo
-!!$! close(11)
-!!$
-!!$! calculate dlnA
-!!$ dlnA = sqrt( ( sum( d(i1:i2) * d(i1:i2) )) / (sum( s_cor(1:npts_win) * s_cor(1:npts_win) )) ) - 1
-!!$
-!!$
-!!$! calculate F1, the least squares misfit
-!!$ f1_top=0.0
-!!$ f1_bot=0.0
-!!$ do i = 1,npts_win
-!!$ f1_top=f1_top+(sngl(d_loc(i))-sngl(s_cor(i)))**2
-!!$! f1_bot=f1_bot+sqrt(sngl(d_loc(i))**2*sngl(s_cor(i))**2)
-!!$ f1_bot=f1_bot+sngl(d_loc(i))**2
-!!$ enddo
-!!$ if ( f1_bot .gt. 0.0 ) then
-!!$ F1 = dble(f1_top / f1_bot)
-!!$ else
-!!$ write(*,*) 'Sum d(t)**2 = 0 : empty observed seismogram.'
-!!$ F1=0
-!!$ F2=0
-!!$ return
-!!$ endif
-!!$
-!!$! do fa1 minimization to find A1
-!!$ ax=1e-3
-!!$ bx=1e3
-!!$ call mnbrak(ax,bx,cx,fa,fb,fc,fa1)
-!!$ f1_min=golden(ax,bx,cx,fa1,sngl(tol),A1)
-!!$
-!!$! do fa2 minimization to find A2
-!!$ ax=1e-3
-!!$ bx=1e3
-!!$ call mnbrak(ax,bx,cx,fa,fb,fc,fa2)
-!!$ f2_min=golden(ax,bx,cx,fa2,sngl(TOL),A2)
-!!$
-!!$! calculate F2
-!!$ F2=dble(min(A1,A2)/max(A1,A2))
-!!$
-!!$! Turn F1 around
-!!$ F1=1-F1
-!!$
-!!$ deallocate(s_cor)
-!!$ deallocate(d_loc)
-!!$
-!!$ contains
-!!$
-!!$! -----------------------------------------------------------------
-!!$
-!!$ real function fa1(a1)
-!!$ real a1
-!!$
-!!$ if (abs(a1).lt.TOL) then
-!!$ write(*,*) 'value of a1 close to zero : ', a1
-!!$ stop
-!!$ endif
-!!$
-!!$ fa1=0.0
-!!$ do i = 1,npts_win
-!!$ fa1=fa1+(sngl(d_loc(i))-a1*sngl(s_cor(i)))**2
-!!$ enddo
-!!$
-!!$ end function
-!!$
-!!$! -----------------------------------------------------------------
-!!$
-!!$ real function fa2(a2)
-!!$ real a2
-!!$
-!!$ if (abs(a2).lt.TOL) then
-!!$ write(*,*) 'value of a2 close to zero : ', a2
-!!$ stop
-!!$ endif
-!!$
-!!$ fa2=0.0
-!!$ do i = 1,npts_win
-!!$ fa2=fa2+((1/a2)*sngl(d_loc(i))-sngl(s_cor(i)))**2
-!!$ enddo
-!!$
-!!$ end function
-!!$
-!!$ end subroutine F1F2_calc
-!!$
-!!$! --------------------------------------------------------------------
-!!$
-!!$ subroutine xcorr_calc(d,s,npts,i1,i2,ishift,cc_max)
-!!$
-!!$ ! inputs:
-!!$ ! s(npts) = synthetic
-!!$ ! d(npts) = data (or observed)
-!!$ ! i1, i2 = start and stop indexes of window within s and d
-!!$
-!!$ double precision, dimension(*), intent(in) :: s,d
-!!$ integer, intent(in) :: npts, i1, i2
-!!$
-!!$ ! outputs:
-!!$ ! ishift = index lag (d-s) for max cross correlation
-!!$ ! cc_max = maximum of cross correlation (normalised by sqrt(synthetic*data))
-!!$ integer, intent(out) :: ishift
-!!$ double precision, intent(out) :: cc_max
-!!$
-!!$ ! local variables
-!!$ integer :: nlen
-!!$ integer :: i_left, i_right, i, j
-!!$ double precision :: cc
-!!$
-!!$ ! initialise shift and cross correlation to zero
-!!$ ishift=0
-!!$ cc_max=0
-!!$
-!!$ if (i1.gt.i2 .or. i2.gt.npts) then
-!!$ write(*,*) 'Error with window limits: i1, i2, npts ', i1, i2, npts
-!!$ return
-!!$ endif
-!!$
-!!$ ! length of window (number of points including ends)
-!!$ nlen = i2 - i1 + 1
-!!$
-!!$ ! left and right limits of index (time) shift search
-!!$ i_left=-1*int(nlen/2)
-!!$ i_right=int(nlen/2)
-!!$
-!!$
-!!$ ! i -> shift (to be applied to d in cc search)
-!!$ do i = i_left, i_right
-!!$ cc=0
-!!$ do j = i1, i2
-!!$ if((j+i).ge.1 .and. (j+i).le.npts) cc = cc + s(j)*d(j+i)
-!!$ enddo
-!!$ if (cc .gt. cc_max) then
-!!$ cc_max=cc
-!!$ ishift=i
-!!$ endif
-!!$ enddo
-!!$
-!!$ cc_max=cc_max / sqrt(sum(s(i1:i2)*s(i1:i2)) * sum(d(i1:i2)*(d(i1:i2))))
-!!$
-!!$end subroutine xcorr_calc
-
-
-! ------------------------------------------------------------------
-! subroutine costaper(ipoint, ndata, tas)
-! ------------------------------------------------------------------
- subroutine costaper(ipoint, ndata, tas)
- implicit none
-
- integer ipoint, ndata
- double precision tas(ndata,*)
- double precision sum, pi
- integer i
-
- pi = asin(1.0d0)*2
- sum = 0.
- do i =1,ipoint
- tas(i,1) = 1 - cos( 2*pi*i/ipoint)
- tas(i,1) = tas(i,1) / sqrt(1.5)
- enddo
- return
- end subroutine costaper
-
-! ------------------------------------------------------------------
-! subroutine boxcar(ipoint, ndata, tas)
-! ------------------------------------------------------------------
- subroutine boxcar(ipoint, ndata, tas)
-
- integer ipoint, ndata
- double precision tas(ndata,*)
- integer i
-
- do i =1,ipoint
- tas(i,1) = 1.0
- enddo
- return
- end subroutine boxcar
-
-
-end module mt_sub2
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/mt_variables.f90
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/mt_variables.f90 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/mt_variables.f90 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,56 +0,0 @@
-module mt_variables
-
- use mt_constants
-!
-! multi-taper measurements
-!
-! Ying Zhou: The fit between the recovered data and the data can be improved
-! by either increasing the window width (HWIN above) or by decreasing NPI.
-! In her experience, NPI = 2.5 is good for noisy data.
-! For synthetic data, we can use a lower NPI.
-! number of tapers should be fixed as twice NPI -- see Latex notes
-!
-! See write_par_file.pl and mt_measure_adj.f90
-
- character(len=150) :: OUT_DIR
-
- double precision :: TLONG, TSHORT
- double precision :: WTR, NPI, DT_FAC, ERR_FAC, DT_MAX_SCALE, NCYCLE_IN_WINDOW
- !double precision :: BEFORE_QUALITY, AFTER_QUALITY, BEFORE_TSHIFT, AFTER_TSHIFT
- double precision :: TSHIFT_MIN, TSHIFT_MAX, DLNA_MIN, DLNA_MAX, CC_MIN
- double precision :: DT_SIGMA_MIN, DLNA_SIGMA_MIN
-
- integer :: ntaper, ipwr_t, ipwr_w, ERROR_TYPE
- integer :: imeas0, imeas, itaper, is_mtm0, is_mtm
-
- logical :: DISPLAY_DETAILS,OUTPUT_MEASUREMENT_FILES,RUN_BANDPASS,COMPUTE_ADJOINT_SOURCE
-
-end module mt_variables
-
-
-module mt_weighting
-
-! module for weighting/normalizing measurements
-
- logical,parameter :: DO_WEIGHTING = .false.
-
- ! transverse, radial and vertical weights
- double precision :: weight_T, weight_R, weight_Z
- ! body waves: number of picks on vertical, radial and transverse component
- double precision :: num_P_SV_V,num_P_SV_R,num_SH_T
- ! surface waves: number of pick on vertical, radial and transverse
- double precision :: num_Rayleigh_V,num_Rayleigh_R,num_Love_T
-
- ! typical surface wave speed in km/s, to calculate surface wave arrival times
- ! Love waves faster than Rayleigh
- double precision, parameter :: surface_vel = 4.0
-
- ! wave type pick
- integer, parameter :: P_SV_V = 1
- integer, parameter :: P_SV_R = 2
- integer, parameter :: SH_T = 3
- integer, parameter :: Rayleigh_V = 4
- integer, parameter :: Rayleigh_R = 5
- integer, parameter :: Love_T = 6
-
-end module mt_weighting
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/run_measure_adj.csh (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/run_mt_measure_adj.csh)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/run_measure_adj.csh (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/run_measure_adj.csh 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,19 @@
+\rm -rf PLOTS/SYN
+cp -r SYN PLOTS/SYN
+\rm -rf PLOTS/DATA
+cp -r DATA PLOTS/DATA
+\rm PLOTS/*pdf PLOTS/*jpg PLOTS/*ps
+cp ./MEASUREMENT.WINDOWS PLOTS
+\rm -rf PLOTS/ADJOINT_SOURCES
+ mkdir PLOTS/ADJOINT_SOURCES
+cp OUTPUT_FILES/*adj PLOTS/ADJOINT_SOURCES
+cp OUTPUT_FILES/*recon.cc* PLOTS/RECON
+cp window_chi PLOTS
+\rm -rf ADJOINT_SOURCES
+ mkdir ADJOINT_SOURCES
+prepare_adj_src.pl -m CMTSOLUTION_9818433 -s PLOTS/STATIONS_TOMO -o ADJOINT_SOURCES OUTPUT_FILES/*adj
+cp STATIONS_ADJOINT ADJOINT_SOURCES
+\mv STATIONS_ADJOINT PLOTS
+cd PLOTS
+plot_win_adj_all.pl -l -10/200 -m ../CMTSOLUTION_9818433 -n BH -b 0 -k 7/1 -a STATIONS_ADJOINT -d DATA -s SYN -c RECON -w MEASUREMENT.WINDOWS -i m16 -j 6/30
+cd ..
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/run_mt_measure_adj.csh
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/run_mt_measure_adj.csh 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/run_mt_measure_adj.csh 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,19 +0,0 @@
-\rm -rf PLOTS/SYN
-cp -r SYN PLOTS/SYN
-\rm -rf PLOTS/DATA
-cp -r DATA PLOTS/DATA
-\rm PLOTS/*pdf PLOTS/*jpg PLOTS/*ps
-cp ./MEASUREMENT.WINDOWS PLOTS
-\rm -rf PLOTS/ADJOINT_SOURCES
- mkdir PLOTS/ADJOINT_SOURCES
-cp OUTPUT_FILES/*adj PLOTS/ADJOINT_SOURCES
-cp OUTPUT_FILES/*recon.cc* PLOTS/RECON
-cp window_chi PLOTS
-\rm -rf ADJOINT_SOURCES
- mkdir ADJOINT_SOURCES
-prepare_adj_src.pl -m CMTSOLUTION_9818433 -s PLOTS/STATIONS_TOMO -o ADJOINT_SOURCES OUTPUT_FILES/*adj
-cp STATIONS_ADJOINT ADJOINT_SOURCES
-\mv STATIONS_ADJOINT PLOTS
-cd PLOTS
-plot_win_adj_all.pl -l -10/200 -m ../CMTSOLUTION_9818433 -n BH -b 0 -k 7/1 -a STATIONS_ADJOINT -d DATA -s SYN -c RECON -w MEASUREMENT.WINDOWS -i m16 -j 6/30
-cd ..
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_measure_adj.pl (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_mt_measure_adj.pl)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_measure_adj.pl (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_measure_adj.pl 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,192 @@
+#!/usr/bin/perl -w
+
+#==========================================================
+#
+# prepare_mt_measure_adj.pl
+# Carl Tape
+# 19-Oct-2009
+#
+# This script prepares the data and synthetics for running in the measurement code.
+# At the moment, it is somewhat tailored to the SoCal dataset.
+#
+# INPUT:
+# itest MEASURE_TEST or MEASURE
+# iplot process data and synthetics for plots
+# iwindow grab records from windowing directory
+# Tmin/Tmax bandpass periods for filtering data and synthetics
+#
+# EXAMPLE:
+# prepare_mt_measure_adj.pl m16 0 1 0 6/30 9818433
+#
+#==========================================================
+
+if (@ARGV < 6) {die("Usage: prepare_mt_measure_adj.pl smodel itest iplot iwindow Tmin/Tmax eid\n");}
+($smodel,$itest,$iplot,$iwindow,$Ts,$eid) = @ARGV;
+
+# iwindow: controls where the data, synthetics, and windows files are
+# 1: grab everything from the windowing directory
+# 0: grab everything from a general output directory
+#$iwindow = 0;
+
+# label for directory
+($Tmin,$Tmax) = split("/",$Ts);
+$sTmin = sprintf("T%3.3i",$Tmin);
+$sTmax = sprintf("T%3.3i",$Tmax);
+$Ttag = "${sTmin}_${sTmax}";
+
+if ($itest == 0) {
+ $dir_syn = "SYN"; $dir_data = "DATA"; $dir_meas = "MEASURE";
+} else {
+ $dir_syn = "SYN_TEST"; $dir_data = "DATA_TEST"; $dir_meas = "MEASURE_TEST";
+ if($iwindow==0) {die("Exit: must have iwindow = 1 for TEST option.");}
+}
+
+#============================================
+# USER INPUT
+
+# CMTSOLUTION file
+$dir_cmt = "/home/carltape/results/SOURCES/socal_16/v16_files";
+$cmtfile = "${dir_cmt}/CMTSOLUTION_${eid}";
+if (not -f $cmtfile) {die("check if cmtfile $cmtfile exist or not\n")}
+
+# directories for data, synthetics, and window files : MUST BE CHANGED FOR EACH USER
+if ($iwindow==1) {
+ # windowing code run directory
+ $dir_win_run = "/data2/SVN/seismo/3D/flexwin_run";
+ $dir_win_run_syn = "${dir_win_run}/${dir_syn}";
+ $dir_win_run_data = "${dir_win_run}/${dir_data}";
+ $win_in = "${dir_win_run}/${dir_meas}/MEASUREMENT_WINDOWS";
+ $par_in = "${dir_win_run}/${dir_meas}/PAR_FILE";
+ #$dir_win_run_meas = "${dir_win_run}/${dir_meas}";
+
+} else {
+ $dir0 = "/home/carltape/RUNS/$eid/$smodel";
+
+ $dir1 = "$dir0/WINDOW_${Ttag}";
+ $dir_win_run_syn = "$dir1/SYN";
+ $dir_win_run_data = "$dir1/DATA";
+ $win_in = "$dir1/MEASUREMENT_WINDOWS_${eid}_${Ttag}_${smodel}";
+ $par_in = "$dir1/PAR_FILE";
+
+ #$dir0 = "/net/sierra/raid1/carltape/socal/socal_3D";
+ #$dir_win_run_syn = "$dir0/SYN/model_m0/${eid}/PROCESSED";
+ #$dir_win_run_data = "$dir0/DATA/FINAL/${eid}/PROCESSED";
+ #$dir_win_out = "/net/sierra/raid1/carltape/results/WINDOWS/model_m0/";
+}
+
+#============================================
+
+if (not -e ${dir_win_run_syn}) {die("check if ${dir_win_run_syn} exist or not\n");}
+if (not -e ${dir_win_run_data}) {die("check if ${dir_win_run_data} exist or not\n");}
+if (not -e ${win_in}) {die("check if ${win_in} exist or not\n");}
+if (not -e ${par_in}) {die("check if ${par_in} exist or not\n");}
+
+# directories for measurement code
+$dir_meas_syn = ${dir_syn};
+$dir_meas_data = ${dir_data};
+#$dir_meas_meas = ${dir_meas};
+
+#=============================================
+# write the C-shell script to file
+$cshfile = "prepare_mt_measure_adj.csh";
+print "\nWriting to $cshfile ...\n";
+open(CSH,">$cshfile");
+
+# remove folders in the measurement directory
+print CSH "\\rm -rf ${dir_meas_syn} ${dir_meas_data}\n";
+#print CSH "mkdir ${dir_meas_syn} ${dir_meas_data}\n";
+
+# copy ALL data and synthetics into measurement directory (BHZ,BHR,BHT)
+# NOTE: copy the whole directory, because the list might be too long for using cp
+# Another option is to LINK the data and syn directories to the local run directory.
+print CSH "echo copying files into the measurement directory...\n";
+print CSH "cp -r ${dir_win_run_syn} ${dir_meas_syn}\n sleep 2s\n";
+print CSH "cp -r ${dir_win_run_data} ${dir_meas_data}\n sleep 2s\n";
+#print CSH "cp ${dir_win_run_syn}/* ${dir_meas_syn}\n";
+#print CSH "cp ${dir_win_run_data}/* ${dir_meas_data}\n";
+
+# CMTSOLUTION file
+print CSH "\\rm CMTSOLUTION*\n";
+print CSH "echo $cmtfile\n";
+print CSH "cp $cmtfile .\n";
+
+# process data and synthetics for the PLOTTING figures (NOT required for adjoint sources)
+# We checked that the processing used in the Perl scripts matches what is used in
+# both the windowing code and in the measurement code.
+# NOTE: NO EXTENSION IS PUT ON THE BAND-PASSED VERSIONS
+if ($iplot == 1) {
+ # synthetics
+ $syn_dir_plot = "PLOTS/${dir_syn}";
+ print CSH "\\rm -rf ${syn_dir_plot}\n";
+ print CSH "cp -r ${dir_meas_syn} ${syn_dir_plot}\n";
+ #print CSH "cd ${syn_dir_plot} ; mv_files.pl -x \"*sac*\" \"*sac\" ; cd -\n"; # remove extensions
+ #print CSH "mkdir ${syn_dir_plot}\n";
+ #print CSH "cd ${dir_meas_syn}\n";
+ #print CSH "process_trinet_syn_new.pl -S -t $Ts -d ../${syn_dir_plot} *sac.d\n";
+ #print CSH "cd -\n";
+
+ # data
+ $data_dir_plot = "PLOTS/${dir_data}";
+ print CSH "\\rm -rf ${data_dir_plot}\n";
+ print CSH "cp -r ${dir_meas_data} ${data_dir_plot}\n";
+ #print CSH "cd ${data_dir_plot} ; mv_files.pl -x \"*sac*\" \"*sac\" ; cd -\n"; # remove extensions
+ #print CSH "mkdir ${data_dir_plot}\n";
+ #print CSH "cd ${dir_meas_data}\n";
+ #print CSH "process_cal_data.pl -t $Ts -d ../${data_dir_plot} *sac.d\n";
+ #print CSH "cd -\n";
+
+ # remove any old plots in PLOTS directory
+ print CSH "\\rm PLOTS/*pdf PLOTS/*jpg PLOTS/*ps\n";
+
+# # make a set of SYNTHETIC stations lists sorted by: station, distance, azimuth
+# @tags = ("sta","dist","az");
+# $fall = "${syn_dir_plot}/*";
+# for ($ij = 1; $ij <= 3; $ij = $ij+1) {
+# $tag = $tags[$ij-1];
+# $ofile = "PLOTS/STATIONS_${tag}";
+# print CSH "\\rm -rf $ofile\n";
+# print CSH "saclst kstnm knetwk dist az f $fall | awk '{print \$2\".\"\$3,\$4,\$5}' | uniq | sort -g -k $ij > $ofile\n";
+# }
+
+}
+
+## this version allows for flexibility for the name of the window file
+#if ($iwindow==1) {
+# $win_in = "${dir_win_run_meas}/MEASUREMENT*";
+# @files = glob("${win_in}"); $nfiles = @files;
+# if ($nfiles != 1) {die("check if ${win_in} exist or not\n");}
+# print CSH "\\cp @files ${win_out}\n";
+#}
+
+# check that the number of records matches the first line of the file
+# NOTE: this is important when manually removing windows
+($nseis,undef,undef) = split(" ",`grep DATA ${win_in} | wc`); # number of listed data records
+open(IN,${win_in}); @lines = <IN>; close(IN); $nlist = $lines[0]; chomp($nlist); # header number
+print "$eid -- nlist = $nlist, nseis = $nseis\n";
+if($nlist != $nseis) {
+ print "${win_in}\n";
+ die("check window files\n");
+}
+
+# copy windowing file and PAR file
+$win_out = "./MEASUREMENT.WINDOWS";
+$par_out = "./PAR_FILE";
+print CSH "\\rm ${win_out}\n";
+print CSH "\\cp ${win_in} ${win_out}\n";
+print CSH "\\rm ${par_out}\n";
+print CSH "\\cp ${par_in} ${par_out}\n";
+
+# copy the windows file to PLOTS
+if ($iplot == 1) {print CSH "cp $win_out PLOTS\n"}
+
+# empty the output files directory
+print CSH "\\rm -rf OUTPUT_FILES\n";
+print CSH "mkdir OUTPUT_FILES\n";
+
+# compile the measurement code
+print CSH "make clean\n make\n";
+
+#-----------------------------------------
+close(CSH);
+system("csh -f $cshfile");
+#=================================================================
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_mt_measure_adj.pl
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_mt_measure_adj.pl 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/prepare_mt_measure_adj.pl 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,192 +0,0 @@
-#!/usr/bin/perl -w
-
-#==========================================================
-#
-# prepare_mt_measure_adj.pl
-# Carl Tape
-# 19-Oct-2009
-#
-# This script prepares the data and synthetics for running in the measurement code.
-# At the moment, it is somewhat tailored to the SoCal dataset.
-#
-# INPUT:
-# itest MEASURE_TEST or MEASURE
-# iplot process data and synthetics for plots
-# iwindow grab records from windowing directory
-# Tmin/Tmax bandpass periods for filtering data and synthetics
-#
-# EXAMPLE:
-# prepare_mt_measure_adj.pl m16 0 1 0 6/30 9818433
-#
-#==========================================================
-
-if (@ARGV < 6) {die("Usage: prepare_mt_measure_adj.pl smodel itest iplot iwindow Tmin/Tmax eid\n");}
-($smodel,$itest,$iplot,$iwindow,$Ts,$eid) = @ARGV;
-
-# iwindow: controls where the data, synthetics, and windows files are
-# 1: grab everything from the windowing directory
-# 0: grab everything from a general output directory
-#$iwindow = 0;
-
-# label for directory
-($Tmin,$Tmax) = split("/",$Ts);
-$sTmin = sprintf("T%3.3i",$Tmin);
-$sTmax = sprintf("T%3.3i",$Tmax);
-$Ttag = "${sTmin}_${sTmax}";
-
-if ($itest == 0) {
- $dir_syn = "SYN"; $dir_data = "DATA"; $dir_meas = "MEASURE";
-} else {
- $dir_syn = "SYN_TEST"; $dir_data = "DATA_TEST"; $dir_meas = "MEASURE_TEST";
- if($iwindow==0) {die("Exit: must have iwindow = 1 for TEST option.");}
-}
-
-#============================================
-# USER INPUT
-
-# CMTSOLUTION file
-$dir_cmt = "/home/carltape/results/SOURCES/socal_16/v16_files";
-$cmtfile = "${dir_cmt}/CMTSOLUTION_${eid}";
-if (not -f $cmtfile) {die("check if cmtfile $cmtfile exist or not\n")}
-
-# directories for data, synthetics, and window files : MUST BE CHANGED FOR EACH USER
-if ($iwindow==1) {
- # windowing code run directory
- $dir_win_run = "/data2/SVN/seismo/3D/flexwin_run";
- $dir_win_run_syn = "${dir_win_run}/${dir_syn}";
- $dir_win_run_data = "${dir_win_run}/${dir_data}";
- $win_in = "${dir_win_run}/${dir_meas}/MEASUREMENT_WINDOWS";
- $par_in = "${dir_win_run}/${dir_meas}/PAR_FILE";
- #$dir_win_run_meas = "${dir_win_run}/${dir_meas}";
-
-} else {
- $dir0 = "/home/carltape/RUNS/$eid/$smodel";
-
- $dir1 = "$dir0/WINDOW_${Ttag}";
- $dir_win_run_syn = "$dir1/SYN";
- $dir_win_run_data = "$dir1/DATA";
- $win_in = "$dir1/MEASUREMENT_WINDOWS_${eid}_${Ttag}_${smodel}";
- $par_in = "$dir1/PAR_FILE";
-
- #$dir0 = "/net/sierra/raid1/carltape/socal/socal_3D";
- #$dir_win_run_syn = "$dir0/SYN/model_m0/${eid}/PROCESSED";
- #$dir_win_run_data = "$dir0/DATA/FINAL/${eid}/PROCESSED";
- #$dir_win_out = "/net/sierra/raid1/carltape/results/WINDOWS/model_m0/";
-}
-
-#============================================
-
-if (not -e ${dir_win_run_syn}) {die("check if ${dir_win_run_syn} exist or not\n");}
-if (not -e ${dir_win_run_data}) {die("check if ${dir_win_run_data} exist or not\n");}
-if (not -e ${win_in}) {die("check if ${win_in} exist or not\n");}
-if (not -e ${par_in}) {die("check if ${par_in} exist or not\n");}
-
-# directories for measurement code
-$dir_meas_syn = ${dir_syn};
-$dir_meas_data = ${dir_data};
-#$dir_meas_meas = ${dir_meas};
-
-#=============================================
-# write the C-shell script to file
-$cshfile = "prepare_mt_measure_adj.csh";
-print "\nWriting to $cshfile ...\n";
-open(CSH,">$cshfile");
-
-# remove folders in the measurement directory
-print CSH "\\rm -rf ${dir_meas_syn} ${dir_meas_data}\n";
-#print CSH "mkdir ${dir_meas_syn} ${dir_meas_data}\n";
-
-# copy ALL data and synthetics into measurement directory (BHZ,BHR,BHT)
-# NOTE: copy the whole directory, because the list might be too long for using cp
-# Another option is to LINK the data and syn directories to the local run directory.
-print CSH "echo copying files into the measurement directory...\n";
-print CSH "cp -r ${dir_win_run_syn} ${dir_meas_syn}\n sleep 2s\n";
-print CSH "cp -r ${dir_win_run_data} ${dir_meas_data}\n sleep 2s\n";
-#print CSH "cp ${dir_win_run_syn}/* ${dir_meas_syn}\n";
-#print CSH "cp ${dir_win_run_data}/* ${dir_meas_data}\n";
-
-# CMTSOLUTION file
-print CSH "\\rm CMTSOLUTION*\n";
-print CSH "echo $cmtfile\n";
-print CSH "cp $cmtfile .\n";
-
-# process data and synthetics for the PLOTTING figures (NOT required for adjoint sources)
-# We checked that the processing used in the Perl scripts matches what is used in
-# both the windowing code and in the measurement code.
-# NOTE: NO EXTENSION IS PUT ON THE BAND-PASSED VERSIONS
-if ($iplot == 1) {
- # synthetics
- $syn_dir_plot = "PLOTS/${dir_syn}";
- print CSH "\\rm -rf ${syn_dir_plot}\n";
- print CSH "cp -r ${dir_meas_syn} ${syn_dir_plot}\n";
- #print CSH "cd ${syn_dir_plot} ; mv_files.pl -x \"*sac*\" \"*sac\" ; cd -\n"; # remove extensions
- #print CSH "mkdir ${syn_dir_plot}\n";
- #print CSH "cd ${dir_meas_syn}\n";
- #print CSH "process_trinet_syn_new.pl -S -t $Ts -d ../${syn_dir_plot} *sac.d\n";
- #print CSH "cd -\n";
-
- # data
- $data_dir_plot = "PLOTS/${dir_data}";
- print CSH "\\rm -rf ${data_dir_plot}\n";
- print CSH "cp -r ${dir_meas_data} ${data_dir_plot}\n";
- #print CSH "cd ${data_dir_plot} ; mv_files.pl -x \"*sac*\" \"*sac\" ; cd -\n"; # remove extensions
- #print CSH "mkdir ${data_dir_plot}\n";
- #print CSH "cd ${dir_meas_data}\n";
- #print CSH "process_cal_data.pl -t $Ts -d ../${data_dir_plot} *sac.d\n";
- #print CSH "cd -\n";
-
- # remove any old plots in PLOTS directory
- print CSH "\\rm PLOTS/*pdf PLOTS/*jpg PLOTS/*ps\n";
-
-# # make a set of SYNTHETIC stations lists sorted by: station, distance, azimuth
-# @tags = ("sta","dist","az");
-# $fall = "${syn_dir_plot}/*";
-# for ($ij = 1; $ij <= 3; $ij = $ij+1) {
-# $tag = $tags[$ij-1];
-# $ofile = "PLOTS/STATIONS_${tag}";
-# print CSH "\\rm -rf $ofile\n";
-# print CSH "saclst kstnm knetwk dist az f $fall | awk '{print \$2\".\"\$3,\$4,\$5}' | uniq | sort -g -k $ij > $ofile\n";
-# }
-
-}
-
-## this version allows for flexibility for the name of the window file
-#if ($iwindow==1) {
-# $win_in = "${dir_win_run_meas}/MEASUREMENT*";
-# @files = glob("${win_in}"); $nfiles = @files;
-# if ($nfiles != 1) {die("check if ${win_in} exist or not\n");}
-# print CSH "\\cp @files ${win_out}\n";
-#}
-
-# check that the number of records matches the first line of the file
-# NOTE: this is important when manually removing windows
-($nseis,undef,undef) = split(" ",`grep DATA ${win_in} | wc`); # number of listed data records
-open(IN,${win_in}); @lines = <IN>; close(IN); $nlist = $lines[0]; chomp($nlist); # header number
-print "$eid -- nlist = $nlist, nseis = $nseis\n";
-if($nlist != $nseis) {
- print "${win_in}\n";
- die("check window files\n");
-}
-
-# copy windowing file and PAR file
-$win_out = "./MEASUREMENT.WINDOWS";
-$par_out = "./PAR_FILE";
-print CSH "\\rm ${win_out}\n";
-print CSH "\\cp ${win_in} ${win_out}\n";
-print CSH "\\rm ${par_out}\n";
-print CSH "\\cp ${par_in} ${par_out}\n";
-
-# copy the windows file to PLOTS
-if ($iplot == 1) {print CSH "cp $win_out PLOTS\n"}
-
-# empty the output files directory
-print CSH "\\rm -rf OUTPUT_FILES\n";
-print CSH "mkdir OUTPUT_FILES\n";
-
-# compile the measurement code
-print CSH "make clean\n make\n";
-
-#-----------------------------------------
-close(CSH);
-system("csh -f $cshfile");
-#=================================================================
Copied: seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_measure_adj.pl (from rev 18825, seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_mt_measure_adj.pl)
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_measure_adj.pl (rev 0)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_measure_adj.pl 2011-08-12 23:26:38 UTC (rev 18826)
@@ -0,0 +1,143 @@
+#!/usr/bin/perl -w
+
+#==========================================================
+#
+# run_mt_measure_adj.pl
+# Carl Tape
+# 19-Oct-2009
+#
+# This script runs following prepare_mt_measure.pl.
+# It executes mt_measure_adj and then ouputs a complete set of
+# un-rotated adjoint sources for SPECFEM3D as well as STATIONS_ADJOINT.
+# It also provides the option of making a set of plots by
+# calling plot_win_adj_all.pl.
+#
+# INPUT:
+# smodel index label for model
+# lcut cut times for plotting records
+# itest use DATA_TEST/SYN_TEST or DATA/SYN
+# iplot make plots of data, syn, windows, and adjoint sources
+# iboth plot both MT and CC adjoint sources (=1) or not (=0)
+# ... see write_par_file.pl
+#
+# EXAMPLE (T = [6s, 30s]):
+# run_mt_measure_adj.pl m16 -10/200 0 1 0 -0.585/0.011/18200 7 BH 6/30 0/1/1/1 -5.0/5.0/-1.5/1.5/0.7 1/1.0/0.5 1/0.02/2.5/2.0/2.5/3.5/1.5
+#
+#==========================================================
+
+if (@ARGV < 13) {die("Usage: run_mt_measure_adj.pl xxx\n")}
+($smodel,$lcut,$itest,$iplot,$iboth,$tvec,$imeas,$chan,$Ts,$iparbools,$par1,$par2,$par3) = @ARGV;
+
+$pwd = $ENV{PWD};
+
+$plot_adj_dir = "PLOTS/ADJOINT_SOURCES";
+#$iboth = 0; # option to plot both cross-correlation and multitaper adjoint sources
+
+($Tmin,$Tmax) = split("/",$Ts);
+(undef,undef,undef,$iadj) = split("/",$iparbools);
+
+#$cmtfile = "CMTSOLUTION_9818433";
+#$stafile1 = "EXAMPLE_2/STATIONS_CHT";
+$stafile1 = "STATIONS_TOMO";
+$stafile2 = "STATIONS_ADJOINT";
+
+# a CMTSOLUTION file should have been copied here from prepare_mt_measure_adj.pl
+$cmtfile = glob("CMTSOLUTION_*");
+
+print "\n-- $cmtfile --\n";
+
+if ($itest == 0) {
+ $dir_syn = "SYN"; $dir_data = "DATA"; $dir_meas = "MEASURE"; $dir_recon = "RECON";
+} else {
+ $dir_syn = "SYN_TEST"; $dir_data = "DATA_TEST"; $dir_meas = "MEASURE_TEST"; $dir_recon = "RECON_TEST";
+}
+$plot_recon_dir = "PLOTS/${dir_recon}";
+
+#=============================================
+# write the C-shell script to file
+$cshfile = "run_mt_measure_adj.csh";
+print "\nWriting to $cshfile ...\n";
+open(CSH,">$cshfile");
+
+# empty the output files directory and compile the measurement code
+# (this is done in prepare_mt_measure_adj.pl)
+#print CSH "\\rm -rf OUTPUT_FILES ; mkdir OUTPUT_FILES ; make clean\n make\n";
+
+#----------------------------
+# choose ipar1 based on the values used in the windowing code PAR_FILE (Feb 2009)
+# This is a more sensible option, since you guarantee consistency with FLEXWIN.
+if(1==1) {
+ # Allow for some "loosening" of the parameters, since the exact nature
+ # of the measurement in the measurement code may exclude some input windows.
+ $dt_fac = 0.5; # in seconds
+ $cc_fac = 0.02; # from 0.0 to 1.0
+
+ (undef,undef,$tshift_base) = split(" ",`grep TSHIFT_BASE PAR_FILE`);
+ (undef,undef,$tshift_ref) = split(" ",`grep TSHIFT_REFERENCE PAR_FILE`);
+ (undef,undef,$dlna_base) = split(" ",`grep DLNA_BASE PAR_FILE`);
+ (undef,undef,$dlna_ref) = split(" ",`grep DLNA_REFERENCE PAR_FILE`);
+ (undef,undef,$cc_base) = split(" ",`grep CC_BASE PAR_FILE`);
+
+ $TSHIFT_MIN = $tshift_ref - $tshift_base - $dt_fac;
+ $TSHIFT_MAX = $tshift_ref + $tshift_base + $dt_fac;
+ $DLNA_MIN = $dlna_ref - $dlna_base;
+ $DLNA_MAX = $dlna_ref + $dlna_base;
+ $CC_MIN = $cc_base - $cc_fac;
+ if($CC_MIN < 0) {$CC_MIN = 0}
+
+ $par1_old = $par1;
+ $par1 = "${TSHIFT_MIN}/${TSHIFT_MAX}/${DLNA_MIN}/${DLNA_MAX}/${CC_MIN}";
+ print "Updating values from PAR_FILE:\n";
+ print " old -- $par1_old --\n new -- $par1 --\n";
+}
+#----------------------------
+
+# create MEASUREMENT.PAR file
+#$wtr = 0.02; $npi = 2.5; # "default" values
+#$itaper = 3;
+#print CSH "write_par_file.pl OUTPUT_FILES $ibp $Ts $tvec $itaper $imeas $wtr/$npi $iparbools $par1 $par2 $par3\n";
+print CSH "write_par_file.pl $tvec $imeas $chan $Ts $iparbools $par1 $par2 $par3\n";
+
+#---------------------------------------------
+
+# run the measurement code
+print CSH "mt_measure_adj > run_file\n"; # output to file
+#print CSH "mt_measure_adj\n";
+
+if ($iplot == 1) {
+ # copy adjoint sources into PLOTS
+ if($iboth==0) {print CSH "\\rm -rf ${plot_adj_dir}\n mkdir ${plot_adj_dir}\n";}
+ print CSH "cp OUTPUT_FILES/*adj ${plot_adj_dir}\n";
+
+ # copy reconstructed records into PLOTS
+ print CSH "cp OUTPUT_FILES/*recon.cc* ${plot_recon_dir}\n";
+
+ # copy chi values into PLOTS
+ print CSH "cp window_chi PLOTS\n";
+
+ # convert to SAC files (creates *.sac files)
+ #print CSH "ascii2sac.csh ${plot_adj_dir}*.adj\n";
+}
+
+if ($iadj == 1) {
+ # create adjoint sources and STATIONS_ADJOINT file for SPECFEM3D
+ # prepare_adj_src.pl dumps the ZEN adjoint sources into $adj_dir
+ $adj_dir = "ADJOINT_SOURCES";
+ print CSH "\\rm -rf ${adj_dir}\n mkdir ${adj_dir}\n";
+ print CSH "prepare_adj_src.pl -m $cmtfile -s PLOTS/$stafile1 -o ${adj_dir} OUTPUT_FILES/*adj\n";
+ print CSH "cp STATIONS_ADJOINT ${adj_dir}\n";
+}
+print CSH "\\mv STATIONS_ADJOINT PLOTS\n";
+
+# make plots of (filtered) data, synthetics, windows, and adjoint sources
+if ($iplot == 1) {
+ print CSH "cd PLOTS\n";
+ print CSH "plot_win_adj_all.pl -l $lcut -m ../$cmtfile -n $chan -b $iboth -k $imeas/$iadj -a $stafile2 -d $dir_data -s $dir_syn -c $dir_recon -w MEASUREMENT.WINDOWS -i $smodel -j $Ts\n";
+ print CSH "cd $pwd\n";
+}
+
+#-----------------------------------------
+close(CSH);
+system("csh -f $cshfile");
+
+#=================================================================
Deleted: seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_mt_measure_adj.pl
===================================================================
--- seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_mt_measure_adj.pl 2011-08-12 23:21:10 UTC (rev 18825)
+++ seismo/3D/ADJOINT_TOMO/measure_adj/scripts_tomo/run_mt_measure_adj.pl 2011-08-12 23:26:38 UTC (rev 18826)
@@ -1,143 +0,0 @@
-#!/usr/bin/perl -w
-
-#==========================================================
-#
-# run_mt_measure_adj.pl
-# Carl Tape
-# 19-Oct-2009
-#
-# This script runs following prepare_mt_measure.pl.
-# It executes mt_measure_adj and then ouputs a complete set of
-# un-rotated adjoint sources for SPECFEM3D as well as STATIONS_ADJOINT.
-# It also provides the option of making a set of plots by
-# calling plot_win_adj_all.pl.
-#
-# INPUT:
-# smodel index label for model
-# lcut cut times for plotting records
-# itest use DATA_TEST/SYN_TEST or DATA/SYN
-# iplot make plots of data, syn, windows, and adjoint sources
-# iboth plot both MT and CC adjoint sources (=1) or not (=0)
-# ... see write_par_file.pl
-#
-# EXAMPLE (T = [6s, 30s]):
-# run_mt_measure_adj.pl m16 -10/200 0 1 0 -0.585/0.011/18200 7 BH 6/30 0/1/1/1 -5.0/5.0/-1.5/1.5/0.7 1/1.0/0.5 1/0.02/2.5/2.0/2.5/3.5/1.5
-#
-#==========================================================
-
-if (@ARGV < 13) {die("Usage: run_mt_measure_adj.pl xxx\n")}
-($smodel,$lcut,$itest,$iplot,$iboth,$tvec,$imeas,$chan,$Ts,$iparbools,$par1,$par2,$par3) = @ARGV;
-
-$pwd = $ENV{PWD};
-
-$plot_adj_dir = "PLOTS/ADJOINT_SOURCES";
-#$iboth = 0; # option to plot both cross-correlation and multitaper adjoint sources
-
-($Tmin,$Tmax) = split("/",$Ts);
-(undef,undef,undef,$iadj) = split("/",$iparbools);
-
-#$cmtfile = "CMTSOLUTION_9818433";
-#$stafile1 = "EXAMPLE_2/STATIONS_CHT";
-$stafile1 = "STATIONS_TOMO";
-$stafile2 = "STATIONS_ADJOINT";
-
-# a CMTSOLUTION file should have been copied here from prepare_mt_measure_adj.pl
-$cmtfile = glob("CMTSOLUTION_*");
-
-print "\n-- $cmtfile --\n";
-
-if ($itest == 0) {
- $dir_syn = "SYN"; $dir_data = "DATA"; $dir_meas = "MEASURE"; $dir_recon = "RECON";
-} else {
- $dir_syn = "SYN_TEST"; $dir_data = "DATA_TEST"; $dir_meas = "MEASURE_TEST"; $dir_recon = "RECON_TEST";
-}
-$plot_recon_dir = "PLOTS/${dir_recon}";
-
-#=============================================
-# write the C-shell script to file
-$cshfile = "run_mt_measure_adj.csh";
-print "\nWriting to $cshfile ...\n";
-open(CSH,">$cshfile");
-
-# empty the output files directory and compile the measurement code
-# (this is done in prepare_mt_measure_adj.pl)
-#print CSH "\\rm -rf OUTPUT_FILES ; mkdir OUTPUT_FILES ; make clean\n make\n";
-
-#----------------------------
-# choose ipar1 based on the values used in the windowing code PAR_FILE (Feb 2009)
-# This is a more sensible option, since you guarantee consistency with FLEXWIN.
-if(1==1) {
- # Allow for some "loosening" of the parameters, since the exact nature
- # of the measurement in the measurement code may exclude some input windows.
- $dt_fac = 0.5; # in seconds
- $cc_fac = 0.02; # from 0.0 to 1.0
-
- (undef,undef,$tshift_base) = split(" ",`grep TSHIFT_BASE PAR_FILE`);
- (undef,undef,$tshift_ref) = split(" ",`grep TSHIFT_REFERENCE PAR_FILE`);
- (undef,undef,$dlna_base) = split(" ",`grep DLNA_BASE PAR_FILE`);
- (undef,undef,$dlna_ref) = split(" ",`grep DLNA_REFERENCE PAR_FILE`);
- (undef,undef,$cc_base) = split(" ",`grep CC_BASE PAR_FILE`);
-
- $TSHIFT_MIN = $tshift_ref - $tshift_base - $dt_fac;
- $TSHIFT_MAX = $tshift_ref + $tshift_base + $dt_fac;
- $DLNA_MIN = $dlna_ref - $dlna_base;
- $DLNA_MAX = $dlna_ref + $dlna_base;
- $CC_MIN = $cc_base - $cc_fac;
- if($CC_MIN < 0) {$CC_MIN = 0}
-
- $par1_old = $par1;
- $par1 = "${TSHIFT_MIN}/${TSHIFT_MAX}/${DLNA_MIN}/${DLNA_MAX}/${CC_MIN}";
- print "Updating values from PAR_FILE:\n";
- print " old -- $par1_old --\n new -- $par1 --\n";
-}
-#----------------------------
-
-# create MEASUREMENT.PAR file
-#$wtr = 0.02; $npi = 2.5; # "default" values
-#$itaper = 3;
-#print CSH "write_par_file.pl OUTPUT_FILES $ibp $Ts $tvec $itaper $imeas $wtr/$npi $iparbools $par1 $par2 $par3\n";
-print CSH "write_par_file.pl $tvec $imeas $chan $Ts $iparbools $par1 $par2 $par3\n";
-
-#---------------------------------------------
-
-# run the measurement code
-print CSH "mt_measure_adj > run_file\n"; # output to file
-#print CSH "mt_measure_adj\n";
-
-if ($iplot == 1) {
- # copy adjoint sources into PLOTS
- if($iboth==0) {print CSH "\\rm -rf ${plot_adj_dir}\n mkdir ${plot_adj_dir}\n";}
- print CSH "cp OUTPUT_FILES/*adj ${plot_adj_dir}\n";
-
- # copy reconstructed records into PLOTS
- print CSH "cp OUTPUT_FILES/*recon.cc* ${plot_recon_dir}\n";
-
- # copy chi values into PLOTS
- print CSH "cp window_chi PLOTS\n";
-
- # convert to SAC files (creates *.sac files)
- #print CSH "ascii2sac.csh ${plot_adj_dir}*.adj\n";
-}
-
-if ($iadj == 1) {
- # create adjoint sources and STATIONS_ADJOINT file for SPECFEM3D
- # prepare_adj_src.pl dumps the ZEN adjoint sources into $adj_dir
- $adj_dir = "ADJOINT_SOURCES";
- print CSH "\\rm -rf ${adj_dir}\n mkdir ${adj_dir}\n";
- print CSH "prepare_adj_src.pl -m $cmtfile -s PLOTS/$stafile1 -o ${adj_dir} OUTPUT_FILES/*adj\n";
- print CSH "cp STATIONS_ADJOINT ${adj_dir}\n";
-}
-print CSH "\\mv STATIONS_ADJOINT PLOTS\n";
-
-# make plots of (filtered) data, synthetics, windows, and adjoint sources
-if ($iplot == 1) {
- print CSH "cd PLOTS\n";
- print CSH "plot_win_adj_all.pl -l $lcut -m ../$cmtfile -n $chan -b $iboth -k $imeas/$iadj -a $stafile2 -d $dir_data -s $dir_syn -c $dir_recon -w MEASUREMENT.WINDOWS -i $smodel -j $Ts\n";
- print CSH "cd $pwd\n";
-}
-
-#-----------------------------------------
-close(CSH);
-system("csh -f $cshfile");
-
-#=================================================================
More information about the CIG-COMMITS
mailing list