subroutine phs2cnss (card, ounit, eunit, shdo, shadow, 2 cmag, amag, zmag, lmag, wmag, ioyear, iomonth, ioday, iohour, 3 iomin, osec, y2k, ierr, ncode, cal_name, cal_net, cal_usgs, 4 cal_seed, cal_loc, typmag, date1, date2) c c reformat NCSN phase, shadow cards into CNSS unified format c ref cnss_v1.0.3.format c implicit none integer npr ! number of allowable data source codes parameter (npr = 36) real afix ! Nominal coda amplitude in coda duration calc real afree ! Free amplitude in coda duration calc real amag ! Eaton amplitude magnitude real amp ! amplitude real ampmag ! magnitude for this amplitude reading real ampres ! amplitude magnitude residual character*1 amptyp ! type of amplitude magnitude (ampmag) character*7 amp_uncer ! amplitude uncertainty (undefined) character*4 ampunit ! type of amplitude units integer iaz ! azimuth character*5 cal_name(ncode) ! station name character*2 cal_net(ncode) ! network code character*3 cal_usgs(ncode) ! usgs channel character*3 cal_seed(ncode) ! seed channel character*2 cal_loc(ncode) ! location code character*(*) card ! hypoinverse phase card real cmag ! Eaton coda magnitude character*3 usgscod ! usgs channel name character*7 cod_uncer ! coda duration uncertainty (undefined) character*4 cod_desc ! Reported 4-letter phase descriptor of coda reading character*4 codunit ! type of coda duration units real crms ! RMS of L1 fit to coda duration amplitude windows character*8 date ! date of observation character*8 date1(ncode) ! calsta2000 usage date string character*8 date2(ncode) ! calsta2000 usage date string character*1 datsrc ! source of data (2=cusp, R/P/O=rtp, W=Earthworm, etc) real dist ! epicentral distance real dur ! coda duration real durmag ! magnitude for this coda duration real durres ! duration magnitude residual integer idur_time ! Duration time (seconds) as measured directly (i.e., not recalculated) character*1 durtyp ! type of duration magnitude (durmag) integer iang ! angle of emergence integer eunit ! error unit # character*1 fm ! first motion direction character*7 freq ! 1/period integer i ! loop index integer iamp(6) ! Amplitude for coda/amp pair in counts integer iampmeas ! Amplitude measurement: 0 = peak-to-peak, 1 = zero-to-peak integer iawt ! assigned amplitude weight integer icwt ! assigned coda weight integer iday ! day integer iday_sv ! day integer ierr ! error return flag integer ihour ! hour integer ihour_sv ! hour integer imin ! minute integer imin_sv ! minute integer imonth ! month integer imonth_sv ! month integer ioday ! day of origin time integer iohour ! hour of origin time integer iomin ! minute of origin time integer iomonth ! month of origin time integer ios ! I/O error return flag integer ioyear ! year of origin time character*1 iprmk ! P phase remark (eg., E or I) integer ipwt ! assigned P weight integer ipwt ! assigned P weight integer irtp ! datasource flag: (1=cusp, 2=rtp/EW, 0=other) character*1 isrmk ! S phase remark (eg., E or I) integer iswt ! assigned P weight integer itime(6) ! Time for coda/amp pair in sec integer iyear ! year integer iyear_sv ! year real lmag ! WA magnitude character*2 loccod ! location code character*2 magtype ! magnitude type real mwt_in(10) ! amp/coda uncertainties corresponding to reading weights integer ncode ! number of usgs/seed channel codes character*2 netcod ! network code integer nwin ! # of (averaged) amplitude windows for coda duration real osec ! sec of origin time integer ounit ! output unit # real pdel ! p delay real per ! period at which amp read character*1 pphs ! P phase (P) real pimport ! p importance real pres ! p residual real psec ! p second real psec_sv ! p second real pwt_out ! output p weight used in hypoinverse solution real qfix ! fixed decay in coda duration calc real qfree ! Free decay in coda duration calc character*1 rmk ! phase remark real sdel ! s delay character*1 sources(npr) ! allowable data source codes character*3 src ! data source real sres ! s residual character*1 sphs ! S phase (S) real ssec ! s second character*3 seedcod ! seed channel name character*(*) shadow ! shadow card logical shdo ! flag:t(f)=do(not) read shadow card real simport ! s importance real ssec ! s second character*5 stat ! station name character*4 stat4 ! first 4-letters of station name character*1 stat5 ! 5th letter of station name real swt_out ! output s weight used in hypoinverse solution character*3 typamp ! amplitude type (table 12 of cnss format) character*2 typmag ! CNSS magnitude type real uncert(10) ! timing uncertainties corresponding to reading weights real twt_in(10) ! timing uncertainties corresponding to reading weights real wmag ! Moment mag logical y2k ! y2k format found for hypoinverse file real zmag ! Hirshorn Z coda mag data (uncert(i), i = 1, 10)/0.02, 0.10, 0.20, 0.30, 0.00, 1 0.02, 0.10, 0.20, 0.30, 0.00/ data (mwt_in(i), i = 1, 10)/1.00, 0.75, 0.50, 0.25, 0.00, 1 0.00, 0.00, 0.00, 0.00, 0.00/ data (twt_in(i), i = 1, 10)/1.00, 0.50, 0.20, 0.10, 0.00, 1 0.00, 0.00, 0.00, 0.00, 0.00/ data (sources(i), i = 1, npr)/ 1 '1', '2', 'E', 'F', 'W', 'R', 'P', 'O', 'A', 'H', 2 'J', 'U', 'B', 'T', '3', '4', '5', '6', '7', '8', 3 'C', 'M', 'Y', 'G', 'V', 'L', 'D', 'S', '?', 'N', 4 'I', 'X', 'Q', 'Z', 'K', ' '/ save uncert, mwt_in, twt_in, sources if (.not. y2k) then read (card, 100, iostat = ios, end = 1000) 1 stat4, iprmk, pphs, fm, ipwt, iyear, imonth, iday, ihour, imin, 2 psec, pres, pwt_out, ssec, isrmk, sphs, iswt, sres, amp, swt_out, 3 pdel, sdel, dist, iang, iawt, icwt, per, rmk, dur, iaz, durmag, 4 ampmag, pimport, simport, datsrc, durtyp, amptyp, stat5, usgscod, 5 netcod 100 format (a4, a1, a1, a1, i1, 1x, i2, i2, i2, i2, i2, 2 f5.2, f4.2, f3.2, f5.2, a1, a1, 1x, i1, f4.2, f3.0, f3.2, 3 f4.2, f4.2, f4.1, i3, i1, i1, f3.2, a1, f4.0, i3, f2.1, 4 f2.1, f4.3, f4.3, 1x, a1, a1, a1, a1, a3, 5 a2) stat = stat4//stat5 if (iyear .gt. 0 .and. iyear .lt. 67) then iyear = 2000 + iyear else iyear = 1900 + iyear endif iampmeas = -999 else read (card, 105, iostat = ios, end = 1000) 1 stat, netcod, usgscod, iprmk, pphs, fm, ipwt, iyear, imonth,iday, 2 ihour, imin, 3 psec, pres, pwt_out, ssec, isrmk, sphs, iswt, sres, amp, 4 iampmeas, swt_out, 5 pdel, sdel, dist, iang, iawt, icwt, per, rmk, dur, iaz, durmag, 6 ampmag, pimport, simport, datsrc, durtyp, amptyp 105 format ( 1 a5, a2, 2x, a3, 1x, 3a1, i1, i4, 2i2, 2 t26, 2i2, 3 t30, f5.2, f4.2, f3.2, f5.2, a1, a1, 1x, i1, f4.2, f7.2, 4 t62, i2, f3.2, 5 t67, f4.2, f4.2, f4.1, i3, i1, i1, f3.2, a1, f4.0, i3, f3.2, 6 t98, f3.2, f4.3, f4.3, a1, a1, a1) endif if (ios .ne. 0) then write (eunit, '(a)') 'Cannot decode phase card' ierr = 1 return endif c find equivalent SEED code write (date, '(i4, 2i2.2)') iyear, imonth, iday do i = 1, ncode - 1 if (stat .eq. cal_name(i) .and. netcod .eq. cal_net(i) .and. 1 usgscod .eq. cal_usgs(i) .and. date .ge. date1(i) .and. 2 date .le. date2(i)) then seedcod = cal_seed(i) loccod = cal_loc(i) goto 110 endif end do write (eunit, '(a)') 'cannot map component to SEED; '// 1 'channel not found in calsta2000.loc' ierr = 1 return c endif 110 continue c find data source code do i = 1, npr if (datsrc .eq. sources(i)) then c cusp data if (i .lt. 5) then src = 'NC ' irtp = 1 c rtp or earthworm data elseif (i .gt. 4 .and. i .lt. 9) then src = 'NC ' irtp = 2 c other data sources without useful shadow card else irtp = 0 if (datsrc .eq. 'B') then src = 'BK ' elseif (datsrc .eq. 'T') then src = 'TER' elseif (datsrc .eq. 'U') then src = 'NN ' elseif (datsrc .eq. '4' .or. (datsrc .eq. '8')) then src = 'CI ' elseif (datsrc .eq. 'Y') then if (iyear .gt. 2003) then src = 'BG ' else src = 'WCC' endif else src = 'NC ' endif endif goto 120 endif end do write (eunit, '(a)') 'Unknown data source' ierr = 1 return 120 continue iyear_sv = iyear imonth_sv = imonth iday_sv = iday ihour_sv = ihour imin_sv = imin psec_sv = psec c $pic, $add$pic lines if (pphs .eq. 'P') then call datenm (iyear, imonth, iday, ihour, imin, psec) if (psec .lt. 0. .or. psec .ge. 60.) then write (eunit, '(a)') 'psec <0 or. >= 60' ierr = 1 return endif write (ounit, 200) iyear, imonth, iday, ihour, imin, psec, 1 stat, netcod, src, seedcod, usgscod, 2 datsrc, loccod, pphs, iprmk, fm, dist, iaz, iang, pres, pimport, 3 float(mod(ipwt, 5)), uncert(ipwt + 1), twt_in(ipwt + 1), pwt_out, 4 rmk 200 format ('$pic', i4, 4i2.2, f7.4, 1 a5, a2, a3, a3, a3, 2 a1, 7x, a2, a1, 7x, a1, a1, f10.1, i3, i3, f7.2, f7.3, 3 f7.0, 3f7.2, 4 a1) endif if (sphs .eq. 'S') then iyear = iyear_sv imonth = imonth_sv iday = iday_sv ihour = ihour_sv imin = imin_sv call datenm (iyear, imonth, iday, ihour, imin, ssec) if (ssec .lt. 0. .or. ssec .ge. 60.) then write (eunit, '(a)') 'ssec <0 or. >= 60' ierr = 1 return endif write (ounit, 200) iyear, imonth, iday, ihour, imin, ssec, 1 stat, netcod, src, seedcod, usgscod, 2 datsrc, loccod, sphs, isrmk, fm, dist, iaz, iang, sres, simport, 3 float(mod(iswt, 5)), uncert(iswt + 1), twt_in(iswt + 1), swt_out, 4 rmk endif c $cod, $add$cod lines. Must have a legit P time magtype = ' ' cod_uncer = ' ' if (durmag .ne. 0. .and. (icwt .ne. 4 .and. icwt .ne. 9)) then if (durtyp .eq. 'D') then if (cmag .eq. 0.) then if (icwt .lt. 4) then write (eunit,'(a)') 1 'durres undefined because durmag is zero; skipping $cod line' ierr = 1 goto 430 endif endif durres = cmag - durmag magtype = 'd ' elseif (durtyp .eq. 'Z') then if (zmag .eq. 0.) then if (icwt .lt. 4) then write (eunit, '(a)') 1 'durres undefined because zmag is zero; skipping $cod line' ierr = 1 goto 430 endif endif durres = zmag - durmag magtype = 'z ' else c unknown coda write (eunit,'(3a)') 1 'station has a coda mag with an unknown coda type (= ', durtyp, 2 ') ; skipping $cod line' ierr = 1 goto 430 endif iyear = iyear_sv imonth = imonth_sv iday = iday_sv ihour = ihour_sv imin = imin_sv psec = psec_sv call datenm (iyear, imonth, iday, ihour, imin, psec) if (psec .lt. 0. .or. psec .ge. 60.) then write (eunit, '(a)') 'psec <0 or. >= 60' ierr = 1 return endif write (ounit, 300) iyear, imonth, iday, ihour, imin, psec, 1 stat, netcod, src, seedcod, usgscod, 2 datsrc, loccod, dur, 'P ', dist, iaz, durmag, durres, magtype, 3 float(mod(icwt, 5)), cod_uncer, mwt_in(icwt +1), mwt_in(icwt +1), 4 rmk 300 format ('$cod', i4, 4i2.2, f7.4, 1 a5, a2, a3, a3, a3, 2 a1, 7x, a2, f6.0, a3, f10.1, i3, f5.2, f5.2, a2, 3 f7.0, a5, 2f7.2, 4 a1) c read shadow cards with information if (shdo) then if (irtp .ne. 0) then c first part of card is same for cusp and rtp codunit = 'c ' read (shadow, 400, iostat = ios, end = 1000) nwin, afix, 1 qfix, afree, qfree, crms, cod_desc, idur_time 400 format (2x, i3, 5f5.2, 1x, a4, i5) if (ios .ne. 0) then write (eunit, '(a)') 'error reading shadow card' ierr = 1 return endif if (irtp .eq. 1) then write (ounit, 410) afix, afree, qfix, qfree, nwin, crms, 1 cod_desc, idur_time, codunit 410 format ('$add$cod', 4f5.2, i3, f5.2, 1 a4, i5, a4, 6(i4, i10)) c rtp shadow else if (irtp .eq. 2) then read (shadow, 420, iostat = ios, end = 1000) 1 (itime(i), iamp(i), i = 1, 6) 420 format (t51, 6(i3, i4)) if (ios .ne. 0) then write (eunit, '(a)') 'error reading shadow card' ierr = 1 return endif write (ounit, 410) afix, afree, qfix, qfree, nwin, crms, 1 cod_desc, idur_time, codunit, (iamp(i), itime(i), i = 1, 6) endif endif endif endif c $amp line. 430 if (ampmag .ne. 0. .and. (iawt .ne. 4 .and. iawt .ne. 9)) then magtype = ' ' c if (amptyp .eq. 'X' .or. amptyp .eq. 'A' .or. c 1 (amptyp .eq. ' ' .and. netcod .eq. 'NC')) then if (amptyp .eq. 'X' .or. amptyp .eq. 'A') then if (amag .eq. 0.) then write (eunit,'(a)') 1 'ampres undefined because amag is zero; skipping $amp line' ierr = 1 return endif ampres = amag - ampmag c This is really equivalent mm on a develocorder, which records velocity. c Since the instrument response is not removed, we report mm. magtype = 'a ' ampunit = 'mmun' typamp = 'PGV' if (iampmeas .eq. -999) iampmeas = 0 c if (amptyp .eq. ' ' .and. netcod .eq. 'NC') then c write (eunit,'(a)') 'assuming amptyp = X' c write (eunit, '(a)') card c endif elseif (amptyp .eq. 'L') then if (lmag .eq. 0.) then write (eunit,'(a)') 1 'ampres undefined because lmag is zero; skipping $amp line' ierr = 1 return endif ampres = lmag - ampmag c Same for UCB in our catalog. They read mm on a WA c NCSN imports UCB values by multiplying by 2 to get peak-to-peak. magtype = typmag ampunit = 'mmun' typamp = 'WA ' if (iampmeas .eq. -999) iampmeas = 0 else write (eunit,'(3a)') 1 'station has an amp mag with an unknown amp type (= ', amptyp, 2 ') ; skipping $amp line' ierr = 1 return endif if (per .eq. 0.) then freq = ' ' else if (1./per .gt. 99.99) then freq = '100.000' else write (freq, '(f7.3)') 1./per endif endif amp_uncer = ' ' if (amp .lt. 1000.) then write (ounit, 500) ioyear, iomonth, ioday,iohour,iomin,osec, 1 stat, netcod, src, seedcod, usgscod, datsrc, 2 loccod, amp, typamp, ampunit, iampmeas, dist, iaz, freq, ampmag, 3 ampres, magtype, float(mod(iawt, 5)), amp_uncer, mwt_in(iawt +1), 4 mwt_in(iawt + 1), rmk 500 format ('$amp', i4, 4i2.2, f7.4, 1 t24, a5, a2, a3, a3, a3, a1, 7x, 2 t48, a2, f6.2, a3, a4, i1, f10.1, i3, a7, f5.2, 3 t89, f5.2, a2, f7.0, a7, f7.2, 4 t117, f7.2, a1) else if (amp .lt. 10000.) then write (ounit,600) ioyear,iomonth,ioday,iohour,iomin,osec, 1 stat, netcod, src, seedcod, usgscod, datsrc, 2 loccod, amp, typamp, ampunit, iampmeas, dist, iaz, freq, ampmag, 3 ampres, magtype, float(mod(iawt, 5)), amp_uncer, mwt_in(iawt +1), 4 mwt_in(iawt + 1), rmk 600 format ('$amp', i4, 4i2.2, f7.4, 1 t24, a5, a2, a3, a3, a3, a1, 7x, 2 t48, a2, f6.1, a3, a4, i1, f10.1, i3, a7, f5.2, 3 t89, f5.2, a2, f7.0, a7, f7.2, 4 t117, f7.2, a1) else if (amp .lt. 100000.) then write (ounit,700) ioyear,iomonth,ioday,iohour,iomin,osec, 1 stat, netcod, src, seedcod, usgscod, datsrc, 2 loccod, amp, typamp, ampunit, iampmeas, dist, iaz, freq, ampmag, 3 ampres, magtype, float(mod(iawt, 5)), amp_uncer, mwt_in(iawt +1), 4 mwt_in(iawt + 1), rmk 700 format ('$amp', i4, 4i2.2, f7.4, 1 t24, a5, a2, a3, a3, a3, a1, 7x, 2 t48, a2, f6.0, a3, a4, i1, f10.1, i3, a7, f5.2, 3 t89, f5.2, a2, f7.0, a7, f7.2, 4 t117, f7.2, a1) else if (amp .lt. 1000000.) then write (ounit,800) ioyear,iomonth,ioday,iohour,iomin,osec, 1 stat, netcod, src, seedcod, usgscod, datsrc, 2 loccod,int(amp),typamp,ampunit,iampmeas,dist,iaz,freq,ampmag, 3 ampres, magtype, float(mod(iawt, 5)), amp_uncer, mwt_in(iawt +1), 4 mwt_in(iawt + 1), rmk 800 format ('$amp', i4, 4i2.2, f7.4, 1 t24, a5, a2, a3, a3, a3, a1, 7x, 2 t48, a2, i6, a3, a4, i1, f10.1, i3, a7, f5.2, 3 t89, f5.2, a2, f7.0, a7, f7.2, 4 t117, f7.2, a1) else write (eunit, '(a)') 'Amplitude is too large!' ierr = 1 return endif endif return 1000 write (eunit, '(a)') 'unexpected end of file' ierr = 1 return end