program velest c c seisan changes: c delaz renamed to delaz_velest, does not seem to be used c c version 3.3 E.Kissling, Institute of Geophysics, ETH Zurich c c 21. August 1998 c c this version is running as: c c - velest.f for SUN-Unix c - velestUNIXhp.f for HP-Unix c c c the program is based on the version 3.0 HRM,UK,EK,and W.Ellsworth c of 28.oct93, and on version 3.1 EK 21April95. c (see PhD thesis by U.Kradolfer 1989, and by H.R. Maurer 1993 c at Institute of Gephysics, ETH Zurich, Switzerland) c c ********************************************************************* c c This version of VELEST can be used to simultaneously invert a large c number of earthquake travel time data for hypocentral and velocity c model (P and S velocities) parameters. Alternatively (isingle=1) it c may also be used as a single event location program. c c This version may read from input data file in the converted (*.cnv) c format (ised=0), in a velest-archive type (*arcvel) format (ised=1), c and in the new SED (Swiss Seismological Service) format (ised=2). c VELEST optionally writes output data files in converted and summary c card format and in singleevent mode writes a location file for c archive purposes (print output file). c c cEK addition to 3.0: c 9.nov93 version 3.01 added subr. inputarcvel (ised=1) c 10.nov93 modified subr. inputparam for model file c 10.nov93 modified " " for print ouput in c single event location mode c 15.nov93 modified in subr. traveltime no calls to c routines rejectobs and reviveobs c 16. nov93 modified in subr. gapcalc to avoid division c zero by zero for call to atan2 c 23. nov93 modified subr inputcnv to recognize end of file c c 28. nov93 testing singleevent and multievent mode and c corrections for print output in subr. inputparam c c 30. nov93 corrected error in inputparam for isingle and c no of eqs .ne.0: neqs and legs MUST be one c for isingle=1 c c implemented dez 1994 EK: read rotate angle of coordinate system c as in earlier versions c subr. inputparam read neqs,nshots,rotate c c also dez94 EK: if ifx(i)=0 normally c =1 to inhibit adjustement of (rotated) c y coordinate (see subr. MATRIX) c (i.e. dtdr(2)=0.0 if ifx(i)=1) c c c EK version 3.3 as of 21August1998: implemented and improved display of c P and S phase usage and station delays c cEK still to be implemented: flat Earth approximation c cEK c c *vel.out file for STATIS written in subr. STATISLOUT c c------------------------------------------------------------------------------ c-----START OF SOURCE-CODE OF PROGRAM VELEST (MAIN PROGRAM) ------------------- c------------------------------------------------------------------------------ c c implicit none include 'vel_com.f' c integer i4enabletest integer juliam integer nittc,istopflag,k,j,i,l,iresflag,ii integer ier,iminold,itime real damp,xlat,xlon,cpmintot,d1,d2 real ggti_v(16),gtg_v(16) logical better c character cline*80 c character*20 ctime real cpusec c integer errx,erry,errz c c-------------------------------------------- c c reset internal cpu-timer: c call CPUTIMER(cpusec) c c test to AVOID runs of velest with compilation-option NOi4 i4enabletest=1234567890 c end of this 'mini-test' c c save report of this VELEST-run (write it ev. to file16 in subr. INPUTPARAM c call DATETIMEX(ctime) ! get date&time from system write(headerline(1),'(1x,''>>> Start of program VELEST at '',a20, & '' <<<'')') ctime write(6,'(1x,''>>> Start of program VELEST at '',a20, & '' <<<'')') ctime write(6,*) c write(headerline(2),*)'::::::::::::::::::::::::::::::::::::::' write(headerline(3),*)' V E L E S T - Version : January 3, 1995' c c reset... c nitt=0 ! number of iterations made nittc=0 ! " " for wich CPU is calculated nvar=0 ! number of unknowns to solve for istopflag=0 c c input control-parameters, model and stations c call INPUTPARAM if(.not.single_turbo) write(16,*)'~~~ input parameters read.' c c if a file containing all the raypaths (ray-points) of all events c is desired, open the file (unit=13): c if(irayout.eq.1) open(13,file=rayfile, & status='unknown') if(idrvout.eq.1) open(21,file=drvfile, & status='unknown') c c file07 - final hypocenters and travel times ( *.CNV format, for next it.) c file11 - summary cards of final hypocenters (for plotting) c if(icnvout.eq.1) open(7,file=cnvfile, & status='unknown') if(ismpout.eq.1) open(11,file=smpfile, & status='unknown') if(isingle.ne.0) open(2,file=velfile, & status='unknown') ! statisL-compatible output if(ialeout.eq.1) open(75,file=alefile, & status='unknown') ! x,y, ALE of all events if(idspout.eq.1) open(76,file=dsprfile, & status='unknown') ! x,y, DSPR of all events if(irflout.eq.1) open(77,file=rflfile, & status='unknown') ! x,y, resid. of reflected ray if(irfrout.eq.1) open(78,file=rfrfile, & status='unknown') ! x,y, resid. of refracted ray if(iresout.eq.1) open(79,file=resfile, & status='unknown') ! dist, residual of ray c k=0 ccc call getsymbol('zirvax') ! not used in this version c 1080 continue ! START OF THE LOOP OVER O N E E V E N T FOR SINGLE-TASK ! c if(k.eq.-1)then ! means: end of input-file detected !!! close(2) cek c no smp-file for single_event_mode since smp only in SED special format c use *.cnv file for plotting etc. cek if(ismpout.eq.1.and.isingle.eq.1) close(11) call DATETIMEX(ctime) ! get date&time from system call CPUTIMER(cpusec) if(.not.single_turbo)then write(16,'(x,''>>> End of program VELEST at '',a20, & '' <<<'','' [ CPU-sec : '',f7.1,'']'')') ctime,cpusec endif write(6,'(x,''>>> End of program VELEST at '',a20, & '' <<<'','' [ CPU-sec : '',f7.1,'']'')') ctime,cpusec stop'...end...(VELEST was running in SINGLE-EVENT-OPTION)' endif c c---------------------------------------------------------------------------- c c do forward problem first: c nitt=0 c c do scaling of damping-factors (and determine ICOUNT): c if(.not.single_turbo) & write(16,*)'~~~ set units for first iteration ...' c 1 --> so icount will not be 0 !!! call SETUNT(1,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) c c determine nr of unknowns NVAR & nr of equations LIP to be solved : c if(.not.single_turbo) & write(16,*)'~~~ determine number of unknowns ...' call DETNOFUNKNOWNS c c reset G-matrix and RHT-vector : c if(.not.single_turbo) write(16,*)'~~~ reset G and RHT ...' do j=1,kvar g(j)=0.0 enddo do k=1,nvar rht(k)=0.0 enddo c c for each event do: reset avres&rms, input of the data, c raytracing and accumulate normal equations c ( = setup of matrix G and vector RHT ) : c if(irayout.eq.1) rewind(13) ! rewind file (if desired) with raypaths if(idrvout.eq.1) rewind(21) ! rewind file (if desired) with raypaths if(.not.single_turbo) & write(16,*)'~~~ input data, raytracing, setup G ...' if(.not.single_turbo)then write(16,'(/////)') write(16,'('' I N P U T - D A T A '',/)') if(nsp.eq.2) then write(16,'(1x,'' eq origin-time latitude longitude '', & ''depth x y z mag ifxOBStot obsP obsS'')') else write(16,'(1x,'' eq origin-time latitude longitude '', & ''depth x y z mag ifxOBS'')') endif endif do i=1,legs avres(i)=0. rms(i)=0. c it's the starting: input trial hypocenter and phase-data call INPUTDATA(i) k=knobs(i) if(k.eq.-1)then goto 1080 ! means: end of input-file (data) detected endif c c for each arrival do raytracing, residual-calc. and setup G & RHT : c do l=1,k call TRAVELTIME(i,l,iresflag) call SETUPMATRIXG(i,l) enddo if(isingle.ne.0)then if( (knobs(i)-nobswithw0) .lt. nvar )then iabort=1 if(.not.single_turbo)then write(16,*)'knobs(i)-nobswithw0 < nvar !!!' write(16,'('' knobs(i)='',i4,'' nobswithw0='',i4, + '' nvar='',i2)') knobs(i),nobswithw0,nvar write(16,*)'Event cannot be located!!!' endif write(6,*)'knobs(i)-nobswithw0 < nvar !!!' write(6,'('' knobs(i)='',i4,'' nobswithw0='',i4, + '' nvar='',i2)') knobs(i),nobswithw0,nvar write(6,*)'Event cannot be located!!!' goto 98989 endif if(.not.single_turbo)then write(16,*)'~~~ compute singular values of G ...' endif call SINGULARVALUES(i) endif enddo c c now all the events are read-in; now check, how many stations c appear in the input-data (= nofstainput) c call ACTUALSTATIONS c c save selected columns of g for resolution calculations c if(.not.single_turbo)then write(16,*) write(16,*)'~~~ store parts of G ...' endif do k=1,4 call STOREG(k,k) enddo if(scale(6).ne.0.0)then i=4*neqs+nshot+1 j=i+nltot-1 ii=4 do k=i,j ii=ii+1 call STOREG(k,ii) enddo endif c c all events: raytracing done, residuals calculated c and normal equations accumulated c c calculate rms & data variance for all events: c if(.not.single_turbo) write(16,*)'~~~ compute RMS and DATVAR ...' call RMSDATVAR c if(ittmax.eq.0)then if(.not.single_turbo)then write(16,*)'WARNING: ITTmax=0 --> no iteration is made' endif write(6,*)'WARNING: ITTmax=0 --> no iteration is made' goto 9999 endif c c calculate GAP, average-residuals of ray-types and check, c whether variance/msqrd res have decreased (this is c always the case if NITT=0 !) or not (in the c latter case do hypocenter/model backup): c if(.not.single_turbo) write(16,*)'~~~ save initial datvar ...' call CHECKSOLUTION(istopflag,better) c c 10 continue ! START OF THE LOOP FOR ONE I T E R A T I O N c c reset CPU-timer for this iteration c call DATETIMEX(ctime) ! get date&time from system call CPUTIMER(cpusec) if(isingle.eq.0)then write(6,'(1x,'' finished Iteration #'',i3,'' at'', & 3x,a20,5x,''CPU-sec = '',f7.1)') & nittc,ctime,cpusec endif nittc=nittc+1 c c nitt=nitt+1 c c print header of this iteration : c cline='----------------------------------------' & //'----------------------------------------' if(.not.single_turbo)then write(16,'(///,a,///)') cline write(16,'(11x,''ITERATION no '',i2,/)') nitt endif c c do scaling of damping-factors (and determine ICOUNT) for this iteration: c if(.not.single_turbo)then write(16,*)'~~~ set units for this iteration ...' endif call SETUNT(nitt,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) c c set nr of unknowns back to nr for this iteration c if(.not.single_turbo)then write(16,*)'~~~ determine number of unknowns for this iter. ...' endif call DETNOFUNKNOWNS c c print out the damping-factors to be used in this iteration : c if(isingle.eq.0)then if(.not.single_turbo)then write(16,*)'Damping factors to be used in this iteration:' write(16,'(1x,'' Othet='',f8.3,'' XYthet ='',f8.3, & '' Zthet='',f7.3)') othet,xythet,Zthet write(16,'(1x,''STAthet='',f8.3,'' Vthet ='',f8.3,/)') & stathet,vthet endif endif c c apply damping to diagonal elements of G-matrix : c if(.not.single_turbo) write(16,*)'~~~ damp G ...' call DAMPG c c copy right-hand-side of normal equations (RHT=At*RES) to vector B : c do k=1,nvar b(k)=rht(k) enddo c c c Cholesky-decomposition of matrix G : c if(.not.single_turbo) write(16,*)'~~~ solve G * b = RHT ...' call LUDECP(g,g,nvar,d1,d2,ier) if(ier.ne.0)then ! matrix not positive definit !!! if(.not.single_turbo)then write(16,'('' WARNING: error in ludecp ier='',i5)')ier endif write(6,'('' WARNING: error in ludecp ier='',i5)')ier STOP'error in (damped) matrix G !!!' endif c c solve normal equations (simple elimination; G is now lower triangular) : c call LUELMP(g,b,nvar,b) c c put solution into proper units : c if(.not.single_turbo) write(16,*)'~~~ fix units ...' call FIXUNT(b,neqs,nshot,nltot,ksta,scale, & vdamp,itotmodels,inltot,nplay(1)) c c check velocity-change; c if large, apply step-length-damping to adjustment-vector ! c if(.not.single_turbo)then write(16,*)'~~~ apply eventually step-length damping ...' endif call STEPLENGTHDAMP(damp) c c adjust hypocenters, velocities & stationcorrections : c if(.not.single_turbo)then write(16,*)'~~~ adjust model (hypocenters, stacorr & veloc.) ...' endif call ADJUSTMODEL(damp) c c calculate total step-length of this iteration and print it out: c if(.not.single_turbo)then write(16,*)'~~~ compute effective step-length ...' endif call STEPLENGTHCALC c c 1010 continue ! come here, if backup has been performed ! c c do forward problem for solution of iteration# NITT: c c c do scaling of damping-factors (and determine ICOUNT) for NEXT iteration: c if(ibackups.lt.4)then if(.not.single_turbo)then write(16,*)'~~~ set units for next iteration ...' endif call SETUNT(nitt+1,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) else if(.not.single_turbo)then write(16,*)'~~~ set units for this iteration ...' endif call SETUNT(nitt,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) endif c c determine nr of unknowns NVAR & nr of equations LIP to be solved for NEXT: c if(.not.single_turbo)then if(ibackups.lt.4)then write(16,*)'~~~ determine number of unknowns for next iter. ...' else write(16,*)'~~~ determine number of unknowns for this iter. ...' endif endif call DETNOFUNKNOWNS c c reset G-matrix and RHT-vector : c if(.not.single_turbo) write(16,*)'~~~ reset G and RHT ...' do j=1,kvar g(j)=0.0 enddo do k=1,nvar rht(k)=0.0 enddo c c for each event do: reset avres&rms, input (if 1st iteration), c raytracing and accumulate normal equations c ( = setup of matrix G and vector RHT ) : c if(irayout.eq.1) rewind(13) ! rewind file (if desired) with raypaths if(idrvout.eq.1) rewind(21) ! rewind file (if desired) with raypaths if(.not.single_turbo) write(16,*)'~~~ raytracing, setup G ...' do i=1,legs avres(i)=0. rms(i)=0. k=knobs(i) c c for each arrival do raytracing, residual-calc. and setup G & RHT : c do l=1,k call TRAVELTIME(i,l,iresflag) call SETUPMATRIXG(i,l) c chrm Calculate the matrix G for the data resolution matrix if(isingle.ne.0)then gg2(l,1) = 1 * w(l,1) gg2(l,2) = dtdr(1) * w(l,1) gg2(l,3) = dtdr(2) * w(l,1) gg2(l,4) = dtdr(3) * w(l,1) endif enddo c if(isingle.ne.0)then if( (knobs(i)-nobswithw0) .lt. nvar )then iabort=1 if(.not.single_turbo)then write(16,*)'knobs(i)-nobswithw0 < nvar !!!' write(16,*)'Event cannot be located!!!' endif write(6,*)'knobs(i)-nobswithw0 < nvar !!!' write(6,*)'Event cannot be located!!!' goto 98989 endif if(.not.single_turbo)then write(16,*)'~~~ compute singular values of G ...' endif call SINGULARVALUES(i) endif enddo c c save selected columns of g for resolution calculations c c Store parts of matrix G here (valid for next iteration), before SETUNT c for this iteration! c if(.not.single_turbo) write(16,*)'~~~ store parts of G ...' do k=1,4 call STOREG(k,k) enddo if(scale(6).ne.0.0)then i=4*neqs+nshot+1 j=i+nltot-1 ii=4 do k=i,j ii=ii+1 call STOREG(k,ii) enddo endif c c do scaling of damping-factors (and determine ICOUNT) for CURRENT iter.: c if(.not.single_turbo)then write(16,*)'~~~ set units back for current iteration ...' endif call SETUNT(nitt,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) c c set nr of unknowns back to nr for this iteration c if(.not.single_turbo)then write(16,*)'~~~ determine number of unknowns for this iter. ...' endif call DETNOFUNKNOWNS c c all events: raytracing done, residuals calculated c and normal equations accumulated c c calculate rms & data variance for all events: c if(.not.single_turbo)then write(16,*)'~~~ compute RMS and DATVAR ...' endif call RMSDATVAR c c calculate GAP, average-residuals of ray-types and check, c whether variance/msqrd res have decreased (this is c always the case if NITT=1 !) or not (in the c latter case do hypocenter/model backup): c if(.not.single_turbo)then write(16,*)'~~~ check solution (better? worse?) ...' endif call CHECKSOLUTION(istopflag,better) c c better=.false. if variance inc'd and residual inc'd, so do readjustments c if backup was done, but less than 4 times, do forward problem again !! c if(ibackups.lt.4)then if(better)then if(ibackups.lt.4) ibackups=0 else if(ibackups.eq.0)then if(.not.single_turbo)then call NITTOUTPUT(damp) endif endif if(ibackups.lt.4)then if(.not.single_turbo)then write(16,'('' msqrd res increased'', & '' --> hypocenter and model backup.'')') write(16,*)'~~~ solution is worse --> backup ...' endif call BACKUP ibackups=ibackups+1 call STEPLENGTHCALC goto 1010 endif endif else if(.not.single_turbo)then write(16,*)'4 times backup made!' endif endif c c come here, if no backup made or 4 backups made c if(.not.single_turbo)then write(16,*)'~~~ iteration done; output results ...' endif if(.not.single_turbo) call NITTOUTPUT(damp) c if(.not.single_turbo) write(16,*)'~~~ another iteration? ...' c c IF 4 TIMES 'HALF ADJUSTMENTS MADE', SOLUTION IS FINAL --> STOP ITERATIONS c if(ibackups.eq.4)then if(.not.single_turbo)then write(16,*)'4 TIMES BACKUP MADE --> sTOP ITERATIONS.' endif goto 9999 endif c c IF STEP-LENGTH < DELMIN ( MINIMUM STEP-LENGTH ) --> STOP ITERATIONS : c if(steplen.gt.0)then ! otherwise we are during backups... if(steplen.lt.delmin)then if(.not.single_turbo)then write(16,*)'STEP-LENGTH < DELMIN --> stop iterations.' endif goto 9999 endif endif c c IF #ITERATIONS = ITTMAX --> STOP ITERATIONS : c if(nitt.eq.ittmax)then if(.not.single_turbo)then write(16,*)'NITT = ITTMAX --> stop iterations.' endif goto 9999 endif c c SINGLE-EVENT-MODE: IF CHANGES IN DATVAR < 1.E-6 --> STOP ITERATIONS : c if(isingle.ne.0.and.istopflag.eq.1)then if(.not.single_turbo)then write(16,*)'Changes in datvar < 1.e-6 --> stop iterations.' endif goto 9999 endif c c DO NEXT ITERATION : c ibackups=0 GOTO 10 c c---------------------------------------------------------------------------- c c FINAL solution reached! output final solution of all events, c all residuals and station-corrections: c 9999 continue c call CPUTIMER(cpusec) if(isingle.eq.0)then write(6,'(1x,'' finished Iteration #'',i3,'' at'', & 3x,a20,5x,''CPU-sec = '',f7.1)') & nittc,ctime,cpusec endif nittc=nittc+1 c if(.not.single_turbo)then write(16,*)'~~~ final solution reached ...' write(16,*) if(iresolcalc.gt.0)then else write(16,*)'~~~ damp G & Chol.-Decomp.: NOT made '// & '(switch iresolcalc is NOT set !)' endif endif if(iresolcalc.gt.0)then c c G was calculated for next iteration, so compute nvar, kvar etc. for c next iteration as well: if(.not.single_turbo) & write(16,*)'~~~ set units for next iteration ...' call SETUNT(nitt+1,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) if(.not.single_turbo) & write(16,'(a)')' ~~~ determine number of unknowns '// & 'for next iter. ...' call DETNOFUNKNOWNS c if(.not.single_turbo) & write(16,*)'~~~ damp G ...' call DAMPG ! necessary for subr. RESOLCOVAR !!! if(.not.single_turbo)then write(16,*)'~~~ Cholesky decomposition of G ...' endif call LUDECP(g,g,nvar,d1,d2,ier) ! necessary for subr. RESOLCOVAR ! if(ier.ne.0)then ! matrix not positive definit !!! if(.not.single_turbo)then write(16,'('' WARNING: error in ludecp ier='',i5)')ier endif write(6,'('' WARNING: error in ludecp ier='',i5)')ier STOP'error in (damped) matrix G !!!' endif endif c if(isingle.ne.0.and.icoordsystem.eq.2)then if(.not.single_turbo)then write(16,*)'~~~ compute magnitude ...' endif do i=1,legs if(iyr(i).lt.100)then iminold=JULIAM(iyr(i)+1900,imo(i),iday(i),ihr(i),imin(i)) else iminold=JULIAM(iyr(i),imo(i),iday(i),ihr(i),imin(i)) endif call TIMECLEAR(iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i), & itime) do j=1,knobs(i) pt(j,i)=pt(j,i)+(iminold-itime)*60. enddo call MAGNITUDE(i,itime) emag(i)=xmagnitude c standard-deviation of emag(i)=sdxmagnitude c the magnitudes for each station are now stored on XMAGNI(1...nobs) enddo endif c if(.not.single_turbo)then write(16,*) if(isingle.ne.0)then write(16,*)'Damping factors to be used in this iteration:' write(16,'(1x,'' Othet='',f8.3,'' XYthet ='',f8.3, & '' Zthet='',f8.3)') othet,xythet,Zthet write(16,'(1x,''STAthet='',f8.3,'' Vthet ='',f8.3)') & stathet,vthet write(16,*) write(16,*)'Final solution of event#',isingle write(16,*)'------------------------------------' else ! print final rms-values of all the events write(16,59) (rms(i),i=1,legs) 59 format(' Final rms values: ',10f5.2,/,(19x,10f5.2)) write(16,'(//)') endif endif c if(isingle.ne.0)then if(icoordsystem.eq.2)then call REGION(1,-e(2,1),e(3,1),regionname,nreg, & regnamfile,regkoordfile) else call SDC(e(2,1),e(3,1),xlat,xlon,1) ! calc. LAT/LON call REGION(2,xlat,-xlon,regionname,nreg, & regnamfile,regkoordfile) ! Subr. REGION needs LON E endif ! as input (E = positive) endif if(.not.single_turbo)then write(16,*)'~~~ output final hypocenters ...' endif call FINALHYPOCOUT if(.not.single_turbo)then if(isingle.ne.0)then write(16,'('' Singular values: '',4f10.4,5x,''ALE ='',f7.3)') & (SV(j),j=1,4) , ale(1) write(16,'(1x,''data variance = '',f10.6)') davar1 endif endif c if(.not.single_turbo)then write(16,*)'~~~ output final station residuals ...' call FINALSTARESI endif if(iresolcalc.gt.0)then if(.not.single_turbo)then write(16,*)'~~~ output resolution- & covariance matrices ...' endif call RESOLCOVAR(davar1) endif c if (s(2).gt.99.9) then c errx = 999 c else c endif c if (s(3).gt.99.9) then c erry = 999 c else c erry = nint(s(3)*10.) c endif c if (s(4).gt.99.9) then c errz = 999 c else c errz = nint(s(4)*10.) c endif c write(smpline(46:54),'(3i3)'),errx,erry,errz cek if(isingle.eq.0) then cek write(11,'(a80)') smpline cek endif if(ialeout.eq.1)then write(75,'(2x,''ALE'',3f10.4,'' .1'')') & -e(2,1),e(3,1), ale(1) endif if(idspout.eq.1)then write(76,'(2x,''DSP'',3f10.4,'' .1'')') & -e(2,1),e(3,1), spread endif c c output all the statistics-stuff... c if(isingle.eq.0)then write(16,*)'~~~ output statistics ...' call STATISTICSOUT endif c c close output-files: c if(iturbo.eq.0)then close(7) cek if(ismpout.eq.1.and.isingle.eq.0) close(11) endif if(irayout.eq.1)then close(13) close(21) endif c c output cpu-statistics for whole VELEST-run: c if(.not.single_turbo) write(16,*) call CPUTIMER(cpusec) if(isingle.eq.0)then write(16,*)'CPU - statistics:' write(16,*) endif if(.not.single_turbo)then cpmintot=cpusec/60. write(16,'(1x,''TOTAL CPU-sec '',3x,'' ='',f7.1,5x, & ''(CPU-minutes:'',f7.3,'')'')') cpusec,cpmintot write(16,*) endif c if(isingle.eq.0)then call DATETIMEX(ctime) ! get date&time from system write(16,'(x,''>>> End of program VELEST at '',a20, & '' <<<'','' [ CPU-sec : '',f7.1,'']'')') ctime,cpusec write(6,'(1x,''>>> End of program VELEST at '',a20, & '' <<<'','' [ CPU-sec : '',f7.1,'']'')') ctime,cpusec endif c c c in case of 'single-event-mode' output NITT, GAP, c SPREAD of resolution and final hypocenter in c statisL-compatible c 98989 continue ! return address for 'insufficient data' !!! if(isingle.gt.0)then call DATETIMEX(ctime) ! get date&time from system if(iabort.ne.1) & write(6,'(1x,''GAP = '',i3,'' NITT = '',i2, & '' D-Spread ='',f5.2)')igap(1),nitt,spread write(6,*) if(.not.single_turbo)then write(16,*)'end of event# ',isingle write(16,*) write(16,*) endif c c output statisL/SED-compatible summary in file02 ( *.VEL ) c if(.not.single_turbo)then write(16,*)'~~~ output solution in HYPO71-compatible format...' endif c chrm Calculation of the data resolution matrix c gg2 = Matrix G c ggt = G transposed c gtg = G * G transposed c ggti = Inverse of gtg c ggg = Generalized inverse c drm = data resolution matrix c chrm Setup ggt c call matrtran(gg2,maxobsperevent,4,ggt) c chrm Setup gtg c call matrmult(ggt,4,maxobsperevent,gg2,maxobsperevent,4,gtg,4,4) c chrm Damping of gtg ... c gtg(1,1) = gtg(1,1) + othet gtg(2,2) = gtg(2,2) + xythet gtg(3,3) = gtg(3,3) + xythet gtg(4,4) = gtg(4,4) + zthet c chrm Convert gtg to a vectorized form c do i=1,4 do k=1,4 gtg_v((i-1)*4 + k) = gtg(i,k) enddo enddo call matrinv(4,gtg_v,ggti_v) c chrm Reconvert the vectorized matrix ggti_v to a 4 x 4 matrix c do i=1,4 do k=1,4 ggti(i,k) = ggti_v((i-1)*4 + k) enddo enddo c chrm Calculate the generalized inverse c call matrmult(ggti,4,4,ggt,4,maxobsperevent,ggg,4, & maxobsperevent) c chrm Calculate the data resolution matrix c call matrmult(gg2,maxobsperevent,4,ggg,4,maxobsperevent,drm, & maxobsperevent,maxobsperevent) c chrm Data resolution matrix calculation finished! c cek print output *out.VEL for singleevent locations written by c subr. STATISLOUT: c call STATISLOUT c c reset parameters... c iabort=0 isingle=isingle+1 nitt=0 nvar=0 icount=0 istopflag=0 iresflag=0 nittc=0 ibackups=0 ale(1)=0.0 do i=1,3 isconstrain(i)=0 enddo iconstrain(1)=0 emag(1)=0.0 nmag=0 do i=1,knobs(1) xmagni(i)=0.0 amx(i)=0.0 ! not necessary in this version; prx(i)=0.0 ! just in case, AMX&PRX will be used for *.CNV files also istm(i,1)=0 enddo ifixsolution=0 zmin=zmininput goto 1080 ! goto NEXT EVENT (SINGLE-EVENT-MODE !) endif c c come here if NOT 'single-event-mode' to terminate program... c close(8) ! close data-input-file ( *.CNV ) c goto 99999 c 998 call OPENERROR('main program','data-input-file FOR008') c 99999 continue END c c******** E N D O F M A I N P R O G R A M **************** c cek begin of vel_io.f c subroutine INPUTPARAM ! old name was: INPUT1 ; c ! this subr. needs another input-format !! c c reads in the control-file (type VELEST.CMN) which contains all the c control-parameters for a VELEST-run c implicit none include 'vel_com.f' real olat,olon,avelo,z,dx,dy,dz,rotate integer ifil,j,ifl,mode,icc,ml,jndex,k c integer trimlen, i,n character*1 reflch, cns,cew character*40 titl character*80 card,line(32), titleline logical lexist c c Open control-inputfile: c inquire(file='velest.cmn',exist=lexist) if(.not.lexist)then stop'INPUTPARAM>>> control file `velest.cmn` not found!' endif cVMS open(10,file='velest.cmn',status='old',err=9910,readonly) open(10,file='velest.cmn',status='unknown',err=9910) c c input center of coordinate system c i=0 111 read(10,'(a)',end=222) card if(card(1:1).eq.'*') goto 111 i=i+1 if(i.gt.32) stop'INPUTPARAM>>> control-file not correct!' line(i)=card goto 111 222 continue if(.NOT.(i.eq.24.or.i.eq.32.)) & stop'INPUTPARAM>>> control-file not correct!' read(line(1),'(a)') titleline read(line(2),*) olat,olon,icoordsystem,zshift,itrial,ztrial,ised read(line(3),*) neqs,nshot,rotate read(line(4),*) isingle, iresolcalc read(line(5),*) dmax,itopo,zmininput,veladj,zadj,lowveloclay read(line(6),*) nsp, swtfac,vpvs, nmod read(line(7),*) othet,xythet,zthet,vthet,stathet read(line(8),*) nsinv,nshcor,nshfix, iuseelev,iusestacorr read(line(9),*) iturbo, icnvout,istaout,ismpout read(line(10),*) irayout,idrvout,ialeout,idspout, & irflout,irfrout,iresout read(line(11),*) delmin,ittmax,invertratio read(line(12),'(a)') modelfilename read(line(13),'(a)') stationfilename read(line(14),'(a)') seismofilename read(line(15),'(a)') regnamfile read(line(16),'(a)') regkoordfile read(line(17),'(a)') topo1file read(line(18),'(a)') topo2file read(line(19),'(a)') phasefile read(line(20),'(a)') shotfile c Output files: read(line(21),'(a)') outfile if(outfile.eq.' ') outfile='vel.out' read(line(22),'(a)') velfile if(velfile.eq.' ') velfile='velout.vel' read(line(23),'(a)') cnvfile if(cnvfile.eq.' ') cnvfile='velout.cnv' read(line(24),'(a)') stafile if(stafile.eq.' ') stafile='velout.sta' c c the next few ouputfiles are not very often used, therefore c either all or none of them have to be specified in the controlfile: c if(i.eq.32)then read(line(25),'(a)') smpfile if(smpfile.eq.' ') smpfile='velout.smp' read(line(26),'(a)') rayfile if(rayfile.eq.' ') rayfile='velout.ray' read(line(27),'(a)') drvfile if(drvfile.eq.' ') drvfile='velout.drv' read(line(28),'(a)') alefile if(alefile.eq.' ') alefile='velout.ale' read(line(29),'(a)') dsprfile if(dsprfile.eq.' ') dsprfile='velout.dspr' read(line(30),'(a)') rflfile if(rflfile.eq.' ') rflfile='velout.rfl' read(line(31),'(a)') rfrfile if(rfrfile.eq.' ') rfrfile='velout.rfr' read(line(32),'(a)') resfile if(resfile.eq.' ') resfile='velout.res' endif c single_turbo=.false. if(isingle.eq.1.and.iturbo.eq.1) single_turbo=.true. c c open the main-output-file: c if(.not.single_turbo)then cVMS open(16,file=outfile,status='new',carriagecontrol='list') open(16,file=outfile,status='unknown') write(16,'(a)') headerline(1) write(16,*) write(16,'(a)') headerline(2) write(16,'(a)') headerline(3) write(headerline(3),*)' (Authors: see source code)' write(16,'(a)') headerline(3) write(16,'(a)') headerline(2) write(16,*) write(16,*) write(16,*)'Title of this VELEST run:' write(16,*) n=trimlen(titleline) write(16,*) titleline(1:n) do i=1,n titleline(i:i)='-' enddo write(16,*) titleline(1:n) write(16,*) write(16,*) write(16,*)'Current array-dimensions of program VELEST:' write(16,*) write(16,'('' Max. number of '', & ''EARTHQUAKES for simult. inversion IEQ = '',i3)') & ieq write(16,'('' Max. number of '', & ''SHOTS for simult. inversion INSHOT = '',i3)') & inshot write(16,'('' Max. number of '', & ''(different) 1D-MODELS ITOTMODELS = '',i3)') & itotmodels write(16,'('' Max. number of '', & ''LAYERS per one 1D-model INLTOT = '',i3)') & inltot write(16,'('' Max. number of '', & ''STATIONS in stationlist IST = '',i3)') & ist write(16,'('' Max. number of '', & ''OBSERVATIONS per event MAXOBSPEREVENT = '',i3)') & maxobsperevent write(16,*) write(16,*) endif c cek 210495: check for reasonable switch combinations nmod,nsp c if(nsp.lt.1) nsp=1 if(nsp.gt.3) nsp=3 c nsp=1 P-model and p-data only c nsp=2 P-model (+data) and S-model (+data) independently used c nsp=3 P-model (+data) and S-model dependent on P-model (vpvs-factor used) if(nsp.eq.2) then nmod=2 else nmod=1 endif c cek 210495 c c print the input-parameters c if(.not.single_turbo)then write(16,'(///)') write(16,*)' INPUT - P A R A M E T E R S :' write(16,'(//)') write(16,'(a)')'***' write(16,'(a)')'*** olat olon icoordsystem '// & 'zshift itrial ztrial ised' write(16,'(1x,f10.6,f11.6,6x,i1,10x,f7.3,7x,i1,3x,f6.2,6x,i1)') & olat,olon,icoordsystem,zshift,itrial,ztrial,ised write(16,'(a)')'***' write(16,'(a)')'*** neqs nshot rotate' write(16,'(1x,i6,1x,i6,3x,f6.1)') neqs,nshot,rotate write(16,'(a)')'***' write(16,'(a)')'*** isingle iresolcalc' write(16,'(7x,i1,10x,i1)') isingle, iresolcalc write(16,'(a)')'***' write(16,'(a)')'*** dmax itopo zmin'// & ' veladj zadj lowveloclay' write(16,'(2x,f7.2,5x,i1,4x,f6.2,6x,f5.2,3x,f5.2,7x,i1)') & dmax,itopo,zmininput,veladj,zadj,lowveloclay write(16,'(a)')'***' write(16,'(a)')'*** nsp swtfac vpvs nmod' write(16,'(5x,i1,5x,f5.2,3x,f6.3,7x,i2)') nsp, swtfac, vpvs, nmod write(16,'(a)')'***' write(16,'(a)')'*** othet xythet zthet vthet stathet' write(16,'(4x,5(f7.2,2x))') othet,xythet,zthet,vthet,stathet write(16,'(a)')'***' write(16,'(a)')'*** nsinv nshcor nshfix'// & ' iuseelev iusestacorr' write(16,'(7x,3(i1,7x),4x,i1,12x,i1)') nsinv, nshcor, nshfix, & iuseelev,iusestacorr write(16,'(a)')'***' write(16,'(a)')'*** iturbo icnvout istaout ismpout' write(16,'(7x,i1,9x,i1,9x,i1,9x,i1)') iturbo, & icnvout,istaout,ismpout write(16,'(a)')'***' write(16,'(a)')'*** irayout idrvout ialeout idspout'// & ' irflout irfrout iresout' write(16,'(7x,i1,6(9x,i1))') irayout,idrvout,ialeout,idspout, & irflout,irfrout,iresout write(16,'(a)')'***' write(16,'(a)')'*** delmin ittmax invertratio' write(16,'(3x,f6.3,6x,i2,9x,i2)') delmin, ittmax, invertratio write(16,'(a)')'***' write(16,'(a)')'*** Modelfile:' write(16,'(a)') modelfilename(1:trimlen(modelfilename)) write(16,'(a)')'***' write(16,'(a)')'*** Stationfile:' write(16,'(a)') stationfilename(1:trimlen(stationfilename)) write(16,'(a)')'***' write(16,'(a)')'*** Seismofile:' write(16,'(a)') seismofilename(1:trimlen(seismofilename)) write(16,'(a)')'***' write(16,'(a)')'*** File with region names:' write(16,'(a)') regnamfile(1:trimlen(regnamfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with region coordinates:' write(16,'(a)') regkoordfile(1:trimlen(regkoordfile)) write(16,'(a)')'***' write(16,'(a)')'*** File #1 with topo data:' write(16,'(a)') topo1file(1:trimlen(topo1file)) write(16,'(a)')'***' write(16,'(a)')'*** File #2 with topo data:' write(16,'(a)') topo2file(1:trimlen(topo2file)) write(16,'(a)')'***' write(16,'(a)')'*** DATA INPUT files:' write(16,'(a)')'***' write(16,'(a)')'*** File with Earthquake data:' write(16,'(a)') phasefile(1:trimlen(phasefile)) write(16,'(a)')'***' write(16,'(a)')'*** File with Shot data:' write(16,'(a)') shotfile(1:trimlen(shotfile)) write(16,'(a)')'***' write(16,'(a)')'*** OUTPUT files:' write(16,'(a)')'***' write(16,'(a)')'*** Main print output file:' write(16,'(a)') outfile(1:trimlen(outfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with single event locations:' write(16,'(a)') velfile(1:trimlen(velfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with final hypocenters in *.cnv format:' write(16,'(a)') cnvfile(1:trimlen(cnvfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with new station corrections:' write(16,'(a)') stafile(1:trimlen(stafile)) write(16,'(a)')'***' write(16,'(a)')'*** File with summary cards (e.g. for plotting):' write(16,'(a)') smpfile(1:trimlen(smpfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with raypoints:' write(16,'(a)') rayfile(1:trimlen(rayfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with derivatives:' write(16,'(a)') drvfile(1:trimlen(drvfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with ALEs:' write(16,'(a)') alefile(1:trimlen(alefile)) write(16,'(a)')'***' write(16,'(a)')'*** File with Dirichlet spreads:' write(16,'(a)') dsprfile(1:trimlen(dsprfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with reflection points:' write(16,'(a)') rflfile(1:trimlen(rflfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with refraction points:' write(16,'(a)') rfrfile(1:trimlen(rfrfile)) write(16,'(a)')'***' write(16,'(a)')'*** File with residuals:' write(16,'(a)') resfile(1:trimlen(resfile)) write(16,'(a)')'***' write(16,'(///)') endif c c remarks concerning OLAT & OLON: c Both olat and olon are input in decimal-degrees. c For LAT N(orth) and LON W(est) their values are positive. c For LAT S(outh) and LON E(ast) their values must be negative! c c For more details see comments on top of this program-source! c zmin=zmininput c if(.not.single_turbo)then write(16,*)'Origin of cartesian coordinates:' if(olon.le.0.0)then write(16,'(6x,f10.5,2hN ,f11.5,1hE)')olat,-olon else write(16,'(6x,f10.5,2hN ,f11.5,1hW)')olat,olon endif if(olon.eq.0.0.and.olat.eq.0.0)then write(16,*)'Origin BERNE is taken!' write(16,*)'OLAT=46.95240 n OLON=7.439583 e' endif write(16,*) write(16,*)' X,Y-AXES rotated clockwise from North' write(16,*)' Rotation angle (rotate):' write(16,'(12x,7hrotate=,1x,f6.1,1x,5hdegr.)')rotate write(16,*) c if(itrial.gt.0)then write(16,*) write(16,*)' ============================================' write(16,*)' trial epicenter ~ earliest station' write(16,*)' trial depth = ztrial = ',ztrial write(16,*)' ============================================' write(16,*) endif c if(icoordsystem.eq.2)then write(16,*)'SWISS COORDINATES will be used instead of the', & ' short distance conversion!' write(16,*)'origin BERNE: x=600.km, y=200.km' write(16,*)'x is positive towards east,', & ' y is positive towards north' ccc write(16,*)'---> no rotation can be performed !!!' else write(16,*)'icoordsystem = ',icoordsystem write(16,*)'normal SHORT DISTANCE CONVERSION will be made' write(16,*)'x is positive towards west,', & ' y is positive towards north' endif endif c c use setorg to set up coordinate system c ifil=0 if(.not.single_turbo) ifil=16 c if(icoordsystem.ne.2) call SETORG(olat,olon,rotate,ifil) c c now origin is setup. c 4 format(f5.2,i5,4f5.2,f6.2,3i1,5f6.2) c if(dmax.eq.0.)then if(.not.single_turbo)then write(16,*)'WARNING: dmax was zero ! ... set to 150 km !' endif dmax=150. endif c rmsmin=0.0 if(invertratio.le.0) invertratio=999 ! do not invert for sta-corr & model if(.not.single_turbo)then if(iuseelev.eq.0)then write(16,*) write(16,*)'Station-elevations internally set to ZERO !' write(16,*)'(but correctly printed in file12)' write(16,*) endif if(iusestacorr.eq.0)then write(16,*) write(16,*)'Station-corrections set to ZERO !' write(16,*)'(if you do NOT invert for station-corrections,' write(16,*)' then these 0.0-values are printed in file12 !)' write(16,*) endif endif c*** nsinv= 0 no inversion for station corrections c*** 1 inversion for station corrections c c*** legs is the total number of shots and quakes cek cek legs and neqs MUST be 1 in single_event mode c if(isingle.ne.1) then legs=neqs+nshot else legs=1 neqs=1 nshot=0 endif c if(.not.single_turbo)then write(16,'(///)') write(16,*)' INPUT - M O D E L :' write(16,'(//)') write(16,*)'Model(s) read from file :' write(16,*) modelfilename write(16,*) endif close(10) c c *********** c NOW READ model file c *********** c cVMS open(10,file=modelfilename,status='old',err=9911,readonly) open(10,file=modelfilename,status='old',err=9911) c ireflector=0 cek if(nsp.eq.3) then write(16,7788) 7788 format(//,2x,'attention nsp=3! >s-data used for p-model too!',//) endif c cek modifications for new model file read(10,'(a40)') titl if(.not.single_turbo) write(16,'(a)') + ' model file title: ',titl cek read(10,*) (nplay(j),j=1,nmod) 8 format(10i5) do 14 i=1,nmod if(.not.single_turbo)then write(16,17) i 17 format(1x,'Velocity structure for model',i4,' :') write(16,*) write(16,11) 11 format(1h ,'layer vel depth vdamp reflector') endif titl=' ' read(10,'(i3)') nplay(i) do 9 j=1,nplay(i) if(j.eq.1)then read(10,1212) vp(i,j),hp(i,j),vdamp(i,j),reflch,titl 1212 format(f5.2,5x,f7.2,2x,f7.3,3x,a1,1x,a40) else read(10,12) vp(i,j),hp(i,j),vdamp(i,j),reflch 12 format(f5.2,5x,f7.2,2x,f7.3,3x,a1) endif if(reflch.ne.' ')then if(reflch.eq.'m'.or.reflch.eq.'M')then reflchar=reflch ireflector=j if(.not.single_turbo)then if(vp(i,ireflector).gt.8.0)then write(16,*)'WARNING ::: velocity ABOVE reflector is', & ' greater than 8.0 km/s .....' write(6,*)'WARNING ::: velocity ABOVE reflector is', & ' greater than 8.0 km/s .....' write(6,*) endif endif else if(.not.single_turbo)then write(16,*)'WARNING:' write(16,*)'Reflector indicated in velocity-model is', & ' marked with a : ',reflch write(16,*)'Only m or M are allowed!' write(16,*)'Reflected phases will be ignored (wrong mark)' write(6,*)'Reflected phases will be ignored (wrong mark)' write(6,*) endif endif endif if(j.eq.1)then if(.not.single_turbo)then write(16,'(2x,i2,3x,2f7.2,1x,f7.2,1x,a1,1x,a40)') j, & vp(i,j),hp(i,j),vdamp(i,j),reflch,titl endif titl=' ' else if(.not.single_turbo)then write(16,13) j,vp(i,j),hp(i,j),vdamp(i,j),reflch 13 format(2x,i2,3x,2f7.2,1x,f7.2,1x,a1) endif endif c if(j.gt.1.and.hp(i,j).lt.0.0)then write(6,*)'WARNING:' write(6,*)'Only top of the first layer can be negative !!' write(6,*) if(.not.single_turbo)then write(16,*)'WARNING:' write(16,*)'Only top of the first layer can be negative !!' endif endif c 9 continue c c calculate and print average velocities of the model i : c if(.not.single_turbo)then ifl=1 write(16,*) write(16,*)'Calculation of average velocity starts at layer # ', & ifl avelo=0 do j=ifl+1,nplay(i) avelo=avelo + ( hp(i,j)-hp(i,j-1) ) * vp(i,j-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(i,j-1),hp(i,j),vp(i,j-1),avelo/(hp(i,j)-hp(i,ifl)), & hp(i,j) enddo write(16,*) c ifl=2 write(16,*) write(16,*)'Calculation of average velocity starts at layer # ', & ifl avelo=0 do j=ifl+1,nplay(i) avelo=avelo + ( hp(i,j)-hp(i,j-1) ) * vp(i,j-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(i,j-1),hp(i,j),vp(i,j-1),avelo/(hp(i,j)-hp(i,ifl)), & hp(i,j) enddo write(16,*) write(16,*) endif c 14 continue i f (ireflector.ne.0) t h e n if(.not.single_turbo)then write(16,*) write(16,'(1x,''Phases in the input-phaselist marked with a '', & a1,/,'' are treated as reflections from the bottom '', & ''of layer nr. '',i2)') reflchar,ireflector if(lowveloclay.eq.1)then write(16,*)'Switch LOWVELOCLAY is set to 1, but'// & ' reflected phases are allowed to occur' write(16,*)'This is improper (no low velocity-layers '// & 'allowed for reflected waves!!)' lowveloclay=0 write(16,*)'LOWVELOCLAY now set to 0 ' write(6,*)'Switch LOWVELOCLAY is set to 1, but'// & ' reflected phases are allowed to occur' write(6,*)'This is improper (no low velocity-layers '// & 'allowed for reflected waves!!)' write(6,*)'LOWVELOCLAY now set to 0 ' endif endif e n d i f c c c *********** c NOW READ station file c *********** c c read in station data: c if(.not.single_turbo)then write(16,'(///)') write(16,*)' INPUT - S T A T I O N S :' write(16,'(//)') write(16,*)'Station-parameters read from file :' write(16,*) stationfilename write(16,*) endif close(10) cVMS open(10,file=stationfilename,status='old',err=9912,readonly) open(10,file=stationfilename,status='old',err=9912) read(10,1) fm 1 format(a80) if(.not.single_turbo)then write(16,*) write(16,2) 2 format(1h ,3x,' stn latitude longitude elev', & 3x,'x y z',5x,'ptcor stcor model icc') endif nsta=0 c 10 nsta=nsta+1 read(10,fm) stn(nsta),xla(nsta),cns,xlo(nsta),cew, & ielev(nsta),mode,icc, & ptcor(nsta),stcor(nsta) call CASEFOLD(cns) call CASEFOLD(cew) if(cns.eq.'S') xla(nsta)=-xla(nsta) if(cew.eq.'E') xlo(nsta)=-xlo(nsta) c if(stn(nsta).eq.' ') goto 41 cek if(mode.eq.0) mode=1 mode=1 c if(nsp.eq.2) then model(2*nsta-1)=mode model(2*nsta)=mode+1 else model(nsta)=mode endif z=-ielev(nsta)/1000. if(icoordsystem.eq.2)then call GEOKO(dx,dy,xla(nsta),-xlo(nsta),-1) ! calc. cart. coord. dx=-dx else call SDC(dx,dy,xla(nsta),xlo(nsta),-1) ! calc. cart. coord. endif dz=z x(nsta,1)=dx x(nsta,2)=dy if(iuseelev.eq.1)then x(nsta,3)=dz else x(nsta,3)=0. ! station-elevation not used ! endif if(iusestacorr.eq.0)then ptcor(nsta)=0.0 ! initial (from input) station-corrections not used ! stcor(nsta)=0.0 ! " " " " " endif if(.not.single_turbo)then if(icoordsystem.eq.2) dx=-dx if(cns.eq.'S') xla(nsta)=-xla(nsta) if(cew.eq.'E') xlo(nsta)=-xlo(nsta) write(16,27) nsta,stn(nsta),xla(nsta),cns,xlo(nsta),cew, & ielev(nsta),dx,dy,dz, & ptcor(nsta),stcor(nsta),mode,icc 27 format(1x,i3,1x,a4,f7.4,a1,f8.4,a1,1x,i5,3f7.2,1x,2f6.2,2i4) if(cns.eq.'S') xla(nsta)=-xla(nsta) if(cew.eq.'E') xlo(nsta)=-xlo(nsta) endif c c an icc of 0 holds the station delay fixed. c the highest nonzero icc station has its p delay c held fixed but its s delay is allowed to float. c map1(nsta)=icc goto 10 41 continue close(10) ! stationfile c c read in seismo data (seismometer-specifications and so on): c if(.not.single_turbo)then if(seismofilename.ne.' ')then write(16,*) write(16,*)'Seismo-parameters read from file :' write(16,*) seismofilename write(16,*) write(16,*)'This file contains station-informations which' write(16,*)'are used for magnitude-determination' write(16,*)'(seismometer-constant,filterparameters, etc.)' write(16,*) write(16,*) else write(16,*) write(16,*)'NO Seismo-parameter-file specified' write(16,*)'--> NO magnitudes calculated!' write(16,*) write(16,*) write(16,*) endif endif if(seismofilename.ne.' ') cVMS &open(10,file=seismofilename,status='old',err=9913,readonly) &open(10,file=seismofilename,status='old',err=9913) c the seismo-parameters will be read in later; we must know the eventtime c before we can pick the time-dependent (!) seismo-parameters !!! c c*** nsta is the number of stations read in nsta=nsta-1 c call MAXII(nsta,map1,ml,jndex) ! determine MAX (=ml) of map1 (icc-values) c*** ksta is the number of total station corrections c*** to invert for ksta=0 if(nsinv.ne.0)then ! invert for station corrections c the last station for p will be held fixed. ksta=ml-1 if(nsp.eq.2) ksta=2*ksta + 1 endif c c find the total number of layers c c** laysum(i) is an index for the location of the first c*** layer of model i laysum(1)=1 laysum(2)=nplay(1)+1 if(nmod.lt.3) goto 50 do 42 i=3,nmod 42 laysum(i)=laysum(i-1)+nplay(i-1) 50 continue c*** nltot is the total number of velocity layers c*** to invert for nltot=0 do 18 i=1,nmod nltot=nltot+nplay(i) 18 continue c if(.not.single_turbo)then write(16,*) write(16,19) neqs,nshot,nltot endif 1619 format(10x,3i20) 19 format(3x,'neqs=',i5,' nshot=',i5,' nltot=',i5,/) c do 25 i=1,itotmodels ! max. number of 1D-models do 25 j=1,inltot ! max. number of layers per model 25 thkp(i,j)=0.0 do 22 i=1,nmod if(nplay(i).eq.1) goto 22 k=nplay(i)-1 do 23 j=1,k 23 thkp(i,j)=hp(i,j+1)-hp(i,j) 22 continue RETURN c 9910 call OPENERROR('inputparam','control-input-file FOR010') return 9911 call OPENERROR('inputparam','model-input-file (FOR010)') return 9912 call OPENERROR('inputparam','station-input-file (FOR010)') return 9913 call OPENERROR('inputparam','seismo-input-file (FOR010)') return c end ! of subr. inputparam c c subroutine INPUTDATA(i) ! old name: INPUT2 c c reads in the phaselists with the earthquake and/or shot data c implicit none include 'vel_com.f' c integer i integer nobs,ntobs,jj,nobsread,i1,i2,i3,icc,jjmin1,jk, & jjmin,jshot,j,k,iunit,ll,itest,ie,iphaseteststopflag, & l,nobsp,nobss real wsum,xlat,xlon,alon,depth,z,ss1 real xxlat,aalon,xxx character*1 sc,ss,cphase(maxobsperevent) character*1 rmk1(maxobsperevent), rmk2(maxobsperevent), & eventtype, cns,cew character*4 sta(maxobsperevent) integer ipwt(maxobsperevent) real sec(maxobsperevent) c SAVE iphaseteststopflag ! forget never that error was detected! c data sc,ss/'s','S'/ c c input phase list and set-up initial trial hypocenter iunit=8 if(i.eq.1)then if(neqs.gt.0) open(iunit,file=phasefile, cVMS & status='old',err=998,readonly) & status='old',err=998) if(nshot.gt.0) open(9,file=shotfile, cVMS & status='old',err=999,readonly) & status='old',err=999) endif cek cek re-entry for reading next event if first event has less cek than three observations 10001 continue cek nobs=0 nobswithw0=0 ntobs=0 wsum= 0.0 c if(i.le.neqs)then iunit=8 ! EQS else iunit=9 ! SHOTS endif c xlat=0.0 xlon=0.0 do jj=1,maxobsperevent cphase(jj)=' ' enddo c cek i1-switch is dummy i1=0 c cek EQS: i1=ifx(i) ! no longer in use !!! cek SHOTS: i1=icc c if(ised.eq.0)then call INPUTCNV(iunit,nobsread, & sta,iyr(i),imo(i),iday(i),ihr(i),imin(i),sec, & rmk1,rmk2,cphase,ipwt,amx,prx, & xlat,alon,emag(i),depth,e(1,i), & i1,i2,i3,eventtype) endif if(ised.eq.1)then call INPUTARCVEL(iunit,nobsread, & sta,iyr(i),imo(i),iday(i),ihr(i),imin(i),sec, & rmk1,rmk2,cphase,ipwt,amx,prx, & xlat,alon,emag(i),depth,e(1,i), & i1,i2,i3,eventtype) endif if(ised.eq.2)then call INPUTSED_NEW(iunit,nobsread, & sta,iyr(i),imo(i),iday(i),ihr(i),imin(i),sec, & rmk1,rmk2,cphase,ipwt,amx,prx, & xlat,alon,emag(i),depth,e(1,i), & i1,ifixsolution,i3,eventtype,itrial) endif if(nobsread.eq.-1)then knobs(i)=-1 ! means: end of input-file detected! RETURN endif if(.NOT.(ised.eq.0.or.ised.eq.1.or.ised.eq.2)) & stop'INPUTDATA: ised flag has no supported value!' cek cek check for events with less than three observations cek if(isingle.ne.0) then if(nobsread.lt.3) then write(6,'(1x,''Event #'',i4)') i write(6,*) ' skipped because it has fewer than 3 obs.' goto 10001 endif endif if(isingle.ne.0)then write(2,'(''1 E V E N T N R . '',i6, & '' '', & '' 0 0'')') & isingle write(6,'(1x,''Event #'',i6)') & isingle endif c if(i.le.neqs)then cEK Dez94 next statement put in effect (ek: i1 set to zero, see above) ifx(i)=i1 cEK Dez94 next statement put out of use: cEK ifx(i)=0 ! NO ROTATION; do not set dtdr(2) to 0.0 UK87 else icc=i1 endif c c if ITRIAL = 1 take first station as trial epicenter and c ztrial as trial depth c Do the same, if no hypocenter has been read from input !!! c if(itrial.gt.0.or. & (xlat.eq.0.0.and.alon.eq.0.0))then c c find first station: c if(itrial.gt.0)then jjmin1=1 do jj=1,nobsread if(ipwt(jj).lt.5)then do jk=1,nsta if(sta(jj).eq.stn(jk)) goto 22222 enddo goto 2222 ! jj-th station not on station-list !!! 22222 jjmin1=jj goto 222 endif 2222 continue enddo 222 jjmin=jjmin1 ! first station in data which is on station-list!! do jj=jjmin1,nobsread if(ipwt(jj).lt.5)then if(sec(jj).lt.sec(jjmin1))then jjmin=jj endif endif enddo cc write(16,'('' first station is '',a4)') sta(jjmin) jjmin1=0 do jj=1,nsta if(sta(jjmin).eq.stn(jj))then jjmin1=jj goto 11111 endif enddo endif 11111 continue ! jj is the first station c If no first station found, take 1st in station-list !! : cuk if(smn(jj,i).eq.' ') jj=1 ! is wrong!! if(jjmin1.eq.0) jj=1 if(ifixsolution.ne.9)then xlat=xla(jj)+0.001 alon=xlo(jj)+0.001 if(ifixsolution.ne.1)then depth=ztrial else if(.not.single_turbo) write(16,*)'DEPTH fixed !!!' write(6,*) 'DEPTH fixed !' endif else if(.not.single_turbo) write(16,*)'HYPOCENTER fixed !!!' write(6,*)'HYPOCENTER fixed !' if(icoordsystem.eq.2.and.alon.gt.0.) alon=-alon ! fixed LAT endif ! was given in LON E endif c c in case the analyst has fixed the depth to less/equal 0.0, he probably c wanted to fix it at the surface... set depth to 3km above sea-level; c program VELEST will set it properly to the surface! c if(ifixsolution.ne.0.and.itopo.gt.0.and.depth.le.0.0) depth=-3.0 if(i.gt.neqs)then jshot=i-neqs ! SHOTS map2(jshot)=icc z=depth else z=depth+zshift ! EQS endif c c now do transformation 'LAT/LON --> Xkm/Ykm' for trial hypocenter: c if(icoordsystem.eq.2)then call GEOKO(e(2,i),e(3,i),xlat,-alon,-1) ! calc. cart. coord. e(2,i)=-e(2,i) else call SDC(e(2,i),e(3,i),xlat,alon,-1) ! calc. cart. coord. endif e(4,i)=z depthsofinput(i)=z c do 15 j=1,nobsread c if(isingle.eq.0)then if(ipwt(j).ge.4)then ! do not accept phase-weights >= 4 !!! goto 15 endif else if(ipwt(j).ge.6)then ! do not accept phase-weights >= 6 !!! goto 15 ! but take 4's & 5's for magnitude-calculation endif ! and 4's also for residual-computation !!! endif if(nsp.eq.1.and.cphase(j).eq.'s') goto 15 if(nsp.eq.1.and.cphase(j).eq.'S') goto 15 if(nsp.eq.1.and.cphase(j).eq.'-') goto 15 ! skip also s-p phases c c if cphase(j).ne. 's' or 'S', a P-phase is assumed, so it's not necessary c to check, whether it's a real P or a reflected P ( 'm' or 'M'). c But if no reflections should be assumed (e.g. ireflector.eq.0), c do NOT use any phases marked with 'm' or 'M' ! if(cphase(j).ne.'p'.and.cphase(j).ne.'P'.and.ipwt(j).lt.5)then if(cphase(j).ne.'s'.and.cphase(j).ne.'S')then if(cphase(j).ne.'-')then if(cphase(j).ne.'m'.and.cphase(j).ne.'M')then if(.not.single_turbo)then write(16,*)'WARNING:' write(16,*)'what phase is this ? ', & cphase(j),' ???' endif write(6,*)'what phase is this ? ',cphase(j),' ???' write(6,*) if(isingle.gt.0)then write(2,'('' DELETED: '',a4, & '' unknown phase is: '',a1)') & sta(j),cphase(j) goto 15 endif ! if .ne. M else ! here, if phase is a reflected one! if(ireflector.eq.0)then i f (.not.single_turbo) t h e n write(16,*)'WARNING:' write(16,*)'subr. INPUTDATA >>> Phase is : ', & cphase(j) write(16,*)'but ireflector is: ',ireflector write(16,*)'Phase therefore neglected !!' e n d i f ! single_turbo write(6,*)'subr. INPUTDATA >>> Phase is : ', & cphase(j) write(6,*)'but ireflector is: ',ireflector write(6,*)'Phase therefore neglected !!' write(6,*) goto 15 endif ! if ireflector endif ! else endif ! if s-p endif ! if s endif ! if p c do 16 k=1,nsta if(sta(j).eq.stn(k)) goto 17 16 continue if(.not.single_turbo)then if(isingle.eq.0) write(16,*)'WARNING: Event # ',i if(isingle.gt.0) write(16,*)'WARNING: Event # ',isingle write(16,'('' WARNING: Station: >>>'',a4, & ''<<< not found in stationlist!'')') sta(j) write(16,*)'Phase therefore skipped' endif cc write(6,*)'Event # ',i write(6,'('' WARNING: Station: >>>'',a4, & ''<<< not found in stationlist!'')') sta(j) write(6,*)'Phase therefore skipped' write(6,*) if(isingle.gt.0) write(2,'('' DELETED: '',a4, & '' not on station-list'')') sta(j) goto 15 17 continue ss1=sqrt( (x(k,1)-e(2,i))**2 + (x(k,2)-e(3,i))**2) if(ss1.gt.dmax)then if(.not.single_turbo)then write(16,*)'WARNING:' write(16,'('' epicentral distance:'',f6.1, & '' > dmax ('',f6.1,'') ==> skipping phase !'')') & ss1,dmax endif if(isingle.ne.0)then write(6,'('' epicentral distance:'',f6.1, & '' > dmax ('',f6.1,'') ==> skipping phase !'')') & ss1,dmax write(2,'('' DELETED: '',a4, & '' epicentral-distance too large'')') sta(j) endif goto 15 endif c c test for only one p-reading of same station per event c if(ipwt(j).eq.5) goto 888 ! dont test for "weight 5" phases c do ll=1,j-1 itest=9 i f (nsp.eq.1.and.(cphase(j).eq.'s'.or.cphase(j).eq.'S'))then continue e l s e if(k.eq.istm(ll,i).and.ipwt(ll).lt.4)then if(cphase(j).eq.'p')itest=0 if(cphase(j).eq.'P')itest=0 if(cphase(j).eq.'s')itest=1 if(cphase(j).eq.'S')itest=1 if(cphase(j).eq.'m')itest=-1 if(cphase(j).eq.'M')itest=-1 if(cphase(j).eq.'-')itest=2 if(sphase(ll,i).eq.itest)then ! twice the same phase in this event if(isingle.eq.0) ie=i if(isingle.gt.0) ie=isingle if(.not.single_turbo)then write(16,*)'WARNING:' write(16,*)'PHASETEST: POSSIBLE ERROR in phaselist !!' write(16,'(1x,''---> '',3i2.2,1x,2i2.2)') & iyr(i),imo(i),iday(i),ihr(i),imin(i) write(16,*)'Event=',ie,' Obs-nr. = ',j,' >>> Station ', & sta(j),' & Phase = ',cphase(j), & ' already occured!' endif write(6,*)'PHASETEST: POSSIBLE ERROR in phaselist !!' write(6,'(1x,''---> '',3i2.2,1x,2i2.2)') & iyr(i),imo(i),iday(i),ihr(i),imin(i) write(6,*)'Event=',ie,' Obs-nr. = ',j,' >>> Station ', & sta(j),' & Phase = ',cphase(j), & ' already occured!' write(6,*) if(isingle.eq.0)then if(.not.single_turbo)then write(16,*)'subr. INPUTDATA >>> program will stop' write(16,*) endif iphaseteststopflag=1 else if(.not.single_turbo)then write(16,*)'INPUTDATA>>> nevertheless, ' & //'program continues' write(16,*) endif endif c iphaseteststopflag is SAVED at beginning of subr. inputdata c ! forget never that error was detected! c stop'PHASE-TEST: FATAL ERROR in phaselist !' endif endif e n d i f enddo c c arrive here, if station on stationlist and phase is accepted by all tests: c 888 nobs=nobs+1 amx(nobs)=amx(j) prx(nobs)=prx(j) ! added 18.9.91 / uk if(isingle.gt.0)then if(ised.eq.2)then prmk(nobs,1)=rmk1(j) prmk(nobs,2)=rmk2(j) else prmk(nobs,1)=' ' prmk(nobs,2)=' ' endif endif do 66 l=1,3 66 d(nobs,l,i)=x(k,l) pt(nobs,i)=sec(j) kpwt(nobs,i)=ipwt(j) istm(nobs,i)=k smn(nobs,i)=sta(j) c*** kpwt(nobs,i) - p or s weight for observation nobs, event i c*** istm(nobs,i) - station number for observation c*** smn(nobs,i) - station name for observation c** iphase(nobs,i) gives the model number for the observation if(nsp.eq.2) goto 21 c c iphase(nobs,i)=model(1) c c*** sphase(nobs,i) is 0. for a p observation c*** 1. for an s observation cuk* -1. for a reflected P observation chrm 2. for a S-P phase c sphase(nobs,i)=0. if(cphase(j).eq.sc.or.cphase(j).eq.ss) sphase(nobs,i)=1.0 if(cphase(j).eq.'m'.or.cphase(j).eq.'M') sphase(nobs,i)=-1.0 if(cphase(j).eq.'-') sphase(nobs,i)=2.0 c c *** w(nobs,i) is an observation weighting factor : c w(nobs,i)=1.0/(2**(ipwt(j)*2)) c if(cphase(j).eq.sc.or.cphase(j).eq.ss.or.cphase(j).eq.'-') & w(nobs,i)=swtfac*w(nobs,i) if(ipwt(j).gt.4)then w(nobs,i)=0.0 ! necessary for single-event-mode !!! nobswithw0=nobswithw0+1 endif wsum=wsum+w(nobs,i) goto 15 21 continue !nsp=2 if(cphase(j).eq.sc.or.cphase(j).eq.ss) goto 22 ! s-phase if(cphase(j).eq.'-') goto 22 ! s-p phase sphase(nobs,i)=0. if(cphase(j).eq.'m'.or.cphase(j).eq.'M') sphase(nobs,i)=-1.0 ! refl. P iphase(nobs,i)=model(1) c iphase(nobs,i)=model(2*k-1) w(nobs,i)=1.0/(2**(ipwt(j)*2)) if(ipwt(j).ge.4)then w(nobs,i)=0.0 ! necessary for single-event-mode !!! nobswithw0=nobswithw0+1 endif wsum=wsum+w(nobs,i) goto 15 22 continue sphase(nobs,i)=1. if(cphase(j).eq.'-') sphase(nobs,i)=2.0 ! s-p phase c c For s-p phases the model parameter is set to the s-wave model c c iphase(nobs,i)=model(2) w(nobs,i)=swtfac*1.0/(2**(ipwt(j)*2)) if(ipwt(j).ge.4)then w(nobs,i)=0.0 ! necessary for single-event-mode !!! nobswithw0=nobswithw0+1 endif wsum=wsum+w(nobs,i) 15 continue c c one event is read-in now : c 14 continue knobs(i)=nobs cek list P and S obs separateley: if(nsp.eq.2) then nobsp=0 nobss=0 do j=1,nobs if(sphase(j,i).eq.0.0) nobsp=nobsp+1 if(sphase(j,i).eq.1.0) nobss=nobss+1 enddo endif if(.not.single_turbo)then if(xlat.lt.0.0)then cns='S' xxlat=-xlat else cns='N' xxlat=xlat endif if(alon.lt.0.0)then cew='E' aalon=-alon else cew='W' aalon=alon endif if(icoordsystem.eq.2)then xxx=-e(2,i) else xxx=e(2,i) endif if(i.le.neqs)then cek print P and S number of obs if(nsp.eq.2) then write(16,'(1x,i3,1x,3i2.2,1x,2i2.2,1x,f5.2,1x,f7.4,a1, & 1x,f8.4,a1,1x,f6.2,3f7.2,f5.2,i2,i4,3x,2i5)') & i,iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i), & xxlat,cns,aalon,cew,depth,xxx,(e(j,i),j=3,4), & emag(i),ifx(i),knobs(i)-nobswithw0,nobsp,nobss else write(16,'(1x,i3,1x,3i2.2,1x,2i2.2,1x,f5.2,1x,f7.4,a1, & 1x,f8.4,a1,1x,f6.2,3f7.2,f5.2,i2,i4)') & i,iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i), & xxlat,cns,aalon,cew,depth,xxx,(e(j,i),j=3,4), & emag(i),ifx(i),knobs(i)-nobswithw0 endif endif if(i.gt.neqs)then !shots write(16,'(1x,i3,1x,3i2.2,1x,2i2.2,1x,f5.2,1x,f7.4,a1, & 1x,f8.4,a1,1x,f6.2,3f7.2,f5.2,i2,i4)') & i,iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i), & xxlat,cns,aalon,cew,depth,xxx,(e(j,i),j=3,4), & emag(i),map2(i-neqs),knobs(i)-nobswithw0 endif endif c c No more active (format 1607) c 1607 format(1x,i3,1x,3i2.2,1x,2i2.2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,1x, c & f6.2,3f7.2,f5.2,i2,i4) c c normalize weights: c if(isingle.gt.0)then if( (knobs(i)-nobswithw0) .lt. nvar ) RETURN if(wsum.le.0.0) RETURN endif do j=1,nobs w(j,i)=w(j,i)*(nobs-nobswithw0)/wsum enddo c if(iphaseteststopflag.eq.1.and.i.eq.(neqs+nshot))then stop'INPUTDATA >>> PHASE-TEST: FATAL ERROR in phaselist !' endif RETURN c 80 continue if(.not.single_turbo)then write(16,85) c---- read past end of data 85 format(' ***** end of data encountered *****') write(16,*)'WARNING: subr. INPUTDATA >>> end of data encountered' endif write(6,*)'WARNING:' stop'subr. INPUTDATA >>> error: end of data!' c 998 call OPENERROR('inputdata','EQ-data-input-file FOR008') 999 call OPENERROR('inputdata','SHOT-data-input-file FOR009') return c end ! of subr. inputdata c subroutine STATISTICSOUT c c output the statistics done in this VELEST run c implicit none include 'vel_com.f' c integer i,ii,irefr,isour,itotal,nhit,iavgap,lesseq1 integer mge6,nobslesseq1,nobsmge6,mag,mge5l,mge5i integer irefl,idepi,idepl,ntot,i1,i2,i3,i4 real depthi,depthl,res0,res1,res2,res3,res4 real tot real rlen,err,mini,maxi,xmag integer magnr(49), nobsnr(49) integer depthnri(105), depthnrl(105) character cstari*51, cstarl*51 c do i=1,105 depthnri(i)=0 depthnrl(i)=0 enddo do i=1,49 magnr(i)=0 nobsnr(i)=0 enddo c do i=1,neqs do ii=1,nltot-1 if(e(4,i).ge.h(ii).and.e(4,i).lt.h(ii+1))then ihypoclayer(ii)=ihypoclayer(ii)+1 endif enddo if(e(4,i).ge.h(nltot)) ihypoclayer(nltot)=ihypoclayer(nltot)+1 enddo rlen=0.0 do i=1,nltot rlen=rlen+refraylen(i) ! rlen will be total refr.raylength [km] enddo do i=1,nltot chrm The next if else statement seems to be neccessary to avoid chrm floating point exceptions in case of rlen = 0 if (rlen.gt.0.00001) then refraylen(i)=100.*refraylen(i)/rlen else refraylen(i) = 0.0 endif if(hitlay(i,1).ge.1)then hitlay(i,2)=hitlay(i,2)/hitlay(i,1) ! average horiz. km in layer i hitlay(i,3)=hitlay(i,3)/hitlay(i,1) ! average verti. km in layer i endif enddo ! hitlay(i,1) = nofHITS of layer i write(16,*) write(16,*) write(16,*) write(16,*) write(16,*)'RAY-STATISTICS FOR L A S T ITERATION' write(16,*)'--------------------------------------' write(16,*) write(16,*)'NHYP : nr of hypocenters in this layer' write(16,*)'NREF : nr of headwaves in this layer' write(16,*)'%len : % of "refracted km" in this layer ' write(16,*)' with respect to all refracted kilometers' write(16,*)'NHIT : nr of rays passed thru this layer' write(16,*)'xy-km: average horizontal ray length [km] in layer' write(16,*)'z-km : average vertical ray length [km] in layer' write(16,*)'RFLX : number of reflections at bottom of this layer' write(16,*) write(16,'(a)')' nlay top ..... bottom velocity '// & 'NHYP NREF %len NHIT xy-km z-km RFLX' write(16,*) irefr=0 isour=0 irefl=0 do i=1,nltot-1 nhit=NINT(hitlay(i,1)) write(16,'(2x,i2,3x,f6.2,''...'',f6.2,'' km '', & f5.2,'' km/s'',2(1x,i4),1x,f5.1,1x,i5,2(1x,f5.1),2x,i4)') & i,h(i),h(i)+thk(i), & v(i),ihypoclayer(i),irefrlayer(i),refraylen(i), & nhit,hitlay(i,2),hitlay(i,3),irefllayer(i) irefr=irefr+irefrlayer(i) isour=isour+ihypoclayer(i) irefl=irefl+irefllayer(i) enddo nhit=NINT(hitlay(nltot,1)) write(16,'(2x,i2,3x,f6.2,''...'',5x,'' km '', & f5.2,'' km/s'',2(1x,i4),1x,f5.1,1x,i5,2(1x,f5.1))') & nltot,h(nltot), & v(nltot),ihypoclayer(nltot),irefrlayer(nltot), & refraylen(nltot), nhit,hitlay(nltot,2),hitlay(nltot,3) irefr=irefr+irefrlayer(nltot) isour=isour+ihypoclayer(nltot) irefl=irefl+irefllayer(nltot) c write(16,*) write(16,'('' Total nr of events was '',i4)') isour write(16,*) write(16,'('' Total nr of refracted rays = '',i5)') irefr write(16,'('' Total nr of reflected rays = '',i5)') irefl write(16,'('' Total nr of other rays = '',i5)') noheadwave itotal=noheadwave+irefr+irefl write(16,'('' ------'')') write(16,'('' Total nr of all rays = '',i5)') itotal write(16,*) write(16,*)'Average (absolute) error of the raytracers:' err=0.0 if(noheadwave.gt.0) err=(sterr+direrr)/noheadwave write(16,'(1x,'' Straight and direct rays : '',f7.2,'' meters'')') & err err=0.0 if(irefr.gt.0) err=refrerr/irefr write(16,'(1x,'' Refracted rays : '',f7.2,'' meters'')') & err err=0.0 if(irefl.gt.0) err=reflerr/irefl write(16,'(1x,'' Reflected rays : '',f7.2,'' meters'')') & err write(16,*) write(16,*) avhraylen=avhraylen/itotal write(16,*)'ALL RAYS TOGETHER:' write(16,'(1x,''Average horizontal ray length = '', & f6.1,'' km (Hypocenter --> Station) '')') & avhraylen avvraylen=avvraylen/itotal write(16,'(1x,''Average vertical ray length = '', & f6.1,'' km (Deepest ray-point --> Station)'')') & avvraylen write(16,*) c write(16,*) write(16,*) write(16,*)'... and some more STATISTICS ' write(16,*)'---------------------------- ' write(16,*)' GAP of final epicenters:' write(16,*) write(16,'(5('' Event# -> GAP''))') write(16,'(5(5x,i3,'' -> '',i3))') (i,igap(i),i=1,neqs) write(16,*) mini=361 maxi=-1 iavgap=0 do i=1,neqs if(igap(i).gt.maxi) maxi=igap(i) if(igap(i).lt.mini) mini=igap(i) iavgap=iavgap+igap(i) enddo iavgap=NINT(float(iavgap)/float(neqs)) write(16,'(1x,''GAPs were between '',i3,'' and '',i3)') & nint(mini),nint(maxi) write(16,'('' (average GAP was '',i3,'')'')') iavgap write(16,*) c write(16,*) write(16,*) write(16,*)' MAGNITUDES of INPUT-DATA:' write(16,*) write(16,*)'Magnitude (# of events) ***average number of obs***' write(16,*) lesseq1=0 mge6=0 nobslesseq1=0 nobsmge6=0 do i=1,neqs mag=NINT(emag(i)*10.) if(mag.le.10)then nobslesseq1=nobslesseq1+knobs(i) lesseq1=lesseq1+1 endif if(mag.gt.10.and.mag.lt.60)then magnr(mag-10)=magnr(mag-10)+1 nobsnr(mag-10)=nobsnr(mag-10)+knobs(i) endif if(mag.ge.60)then mge6=mge6+1 nobsmge6=nobsmge6+knobs(i) endif enddo cstari='*********1*********2*********3*********4*********5>' if(lesseq1.gt.0) nobslesseq1= & NINT(float(nobslesseq1)/float(lesseq1)) if(nobslesseq1.gt.50)nobslesseq1=51 if(nobslesseq1.gt.0)then write(16,'(1x,''MAG<= 1.0 '',''('',i3,'') '',a)') & lesseq1,cstari(1:nobslesseq1) else write(16,'(1x,''MAG<= 1.0 '',''('',i3,'') '',a)') & lesseq1,' ' endif do i=1,49 xmag=(10.+i)/10. if(magnr(i).gt.0) nobsnr(i)= & NINT(float(nobsnr(i))/float(magnr(i))) if(nobsnr(i).gt.50)nobsnr(i)=51 if(nobsnr(i).gt.0)then write(16,'(1x,''MAG = '',f3.1,'' ('',i3,'') '',a)') & xmag,magnr(i),cstari(1:nobsnr(i)) else write(16,'(1x,''MAG = '',f3.1,'' ('',i3,'') '',a)') & xmag,magnr(i),' ' endif enddo if(mge6.gt.0) nobsmge6=NINT(float(nobsmge6)/float(mge6)) if(nobsmge6.gt.50)nobsmge6=51 if(nobsmge6.gt.0)then write(16,'(1x,''MAG>= 6.0 '',''('',i3,'') '',a)') & mge6,cstari(1:nobsmge6) else write(16,'(1x,''MAG>= 6.0 '',''('',i3,'') '',a)') & mge6,' ' endif write(16,*) write(16,*) write(16,*) c write(16,*) write(16,*) write(16,*)' DEPTHs of INPUT-DATA and of LAST ITERATION:' write(16,*)' ===========================================' write(16,*) write(16,*)' Depth # of events ' write(16,*) lesseq1=0 mge6=0 mge5l=0 mge5i=0 do i=1,neqs idepi=NINT(depthsofinput(i)) if(idepi.lt.100)then depthnri(idepi+5)=depthnri(idepi+5)+1 endif if(idepi.ge.100)then mge5i=mge5i+1 endif idepl=NINT(e(4,i)) if(idepl.lt.100)then depthnrl(idepl+5)=depthnrl(idepl+5)+1 endif if(idepl.ge.100)then mge5l=mge5l+1 endif enddo cstari='.........1.........2.........3.........4.........5>' cstarl='*********1*********2*********3*********4*********5>' do i=1,105 depthi=i-5 depthl=i-5 if(depthnri(i).gt.50) depthnri(i)=51 if(depthnrl(i).gt.50) depthnrl(i)=51 if(depthnri(i).gt.0)then write(16,'(1x,''DEPTH ( input ) = '',f4.0,'' km : '',a)') & depthi,cstari(1:depthnri(i)) else write(16,'(1x,''DEPTH ( input ) = '',f4.0,'' km : '',a)') & depthi,' ' endif if(depthnrl(i).gt.0)then write(16,'(1x,''DEPTH (last_IT) = '',f4.0,'' km : '',a)') & depthl,cstarl(1:depthnrl(i)) else write(16,'(1x,''DEPTH (last_IT) = '',f4.0,'' km : '',a)') & depthl,' ' endif cc write(16,*) enddo if(mge5i.gt.50)mge5i=51 if(mge5l.gt.50)mge5l=51 if(mge5i.gt.0)then write(16,'(1x,''DEPTH ( input ) > 100. '',''km : '',a)') & cstari(1:mge5i) else write(16,'(1x,''DEPTH ( input ) > 100. '',''km : '',a)') & ' ' endif if(mge5l.gt.0)then write(16,'(1x,''DEPTH (last_IT) > 100. '',''km : '',a)') & cstarl(1:mge5l) else write(16,'(1x,''DEPTH (last_IT) > 100. '',''km : '',a)') & ' ' endif write(16,*) write(16,*) c write(16,*)'Residuals of the stations according to the azimuth:' write(16,*)'(RES = total average residual at station)' write(16,*)'(RES1 = average residual of rays from 1st quadrant)' write(16,*)'(RES2 = average residual of rays from 2nd quadrant)' write(16,*)'(RES3 = average residual of rays from 3rd quadrant)' write(16,*)'(RES4 = average residual of rays from 4th quadrant)' write(16,*) write(16,'(1x,''Stn# Stn RES RES1 '', & '' RES2 RES3 RES4'')') do i=1,nsta res0=0.0 res1=0.0 res2=0.0 res3=0.0 res4=0.0 if(stnazires(i,2).gt.0) res1=stnazires(i,1)/stnazires(i,2) if(stnazires(i,4).gt.0) res2=stnazires(i,3)/stnazires(i,4) if(stnazires(i,6).gt.0) res3=stnazires(i,5)/stnazires(i,6) if(stnazires(i,8).gt.0) res4=stnazires(i,7)/stnazires(i,8) tot=stnazires(i,2)+stnazires(i,4)+stnazires(i,6)+stnazires(i,8) if(tot.gt.0.0) res0=( & stnazires(i,2)*res1 & +stnazires(i,4)*res2 & +stnazires(i,6)*res3 & +stnazires(i,8)*res4) / tot if(tot.gt.0.0)then ntot=NINT(tot) i1=NINT(stnazires(i,2)) i2=NINT(stnazires(i,4)) i3=NINT(stnazires(i,6)) i4=NINT(stnazires(i,8)) write(16,'(1x,i3,3x,a4,1x,5(f7.2,''('',i4,'')''))') & i,stn(i),res0,ntot,res1,i1, & res2,i2,res3,i3,res4,i4 else write(16,'(1x,i3,3x,a4,1x,''-.-'')') i,stn(i) endif enddo write(16,*) write(16,*) c RETURN end ! of subr. statisticsout c subroutine STATISLOUT c c print location-output in file *.VEL , compatible for program STATISL c cek implemented print output of studentized residuals (studres) cek 29.3.95 implemented print output of station name for all phases c (incl. S) c c principally studentized res = residual/(sigma * sqrt(1.-diagofhat)) c c here we print out studres= residual/sqrt(1.-diag of hat matrix) cek 281093 c implicit none include 'vel_com.f' c real sec,xlat,xlon,aar,ofd,tfd real erh,studres real erx,ery,erz real xstn,ystn,xhyp,yhyp,azi,tobs,tcorr integer nin,idmin,k,js,jd,no,jav,knobs1,i,in,kk,iazi integer iamx,iprisecondcard character ctime*20, card*90 character*1 clay, char1, cns,cew character*1 q,qs,qd c character*1 class(4) data class/'A','B','C','D'/ c if( (knobs(1)-nobswithw0) .lt. nvar .and.iabort.eq.0)then iabort=1 if(.not.single_turbo)then write(16,*)'knobs(i)-nobswithw0 < nvar !!!' write(16,*)'Event cannot be located!!!' endif write(6,*)'knobs(i)-nobswithw0 < nvar !!!' write(6,*)'Event cannot be located!!!' endif if(iabort.eq.1)then write(2,'('' ERROR: insufficient data to locate the quake!'')') RETURN endif c if(ifixsolution.eq.0)then write(2,'(''0 DATE ORIGIN TIME LAT LON DEPTH '', & '' MAG NO DM GAP RMS ALE D-SPR'')') endif if(ifixsolution.eq.1)then write(2,'(''0 DATE ORIGIN TIME LAT LON *DEPTH*'', & '' MAG NO DM GAP RMS ALE D-SPR'')') endif if(ifixsolution.eq.9)then write(2,'(''0 DATE ORIGIN TIME *LAT* *LON* *DEPTH*'', & '' MAG NO DM GAP RMS ALE D-SPR'')') endif c sec=e(1,1) nin=imin(1) if(sec.lt.0.)then sec=sec+60. nin=nin-1 endif if(sec.gt.60.)then sec=sec-60. nin=nin+1 endif if(nin.lt.0)then ! U.K. 3.Feb.87 nin=nin+60 ihr(1)=ihr(1)-1 endif c c convert hypocenter into degrees: c if(icoordsystem.eq.2)then call GEOKO( -e(2,1), e(3,1), xlat, xlon , 1 ) ! calc. LAT/LON xlon=-xlon else call SDC( e(2,1), e(3,1), xlat, xlon , 1 ) ! calc. LAT/LON endif if(xlat.lt.0.0)then cns='S' xlat=-xlat else cns='N' endif if(xlon.lt.0.0)then cew='E' xlon=-xlon else cew='W' endif c idmin=999 ! minimum distance (epicenter --> receiver) aar=0.0 ! absolute average weighted residual do k=1,knobs(1) delta=SQRT( (e(2,1)-d(k,1,1))**2 & + (e(3,1)-d(k,2,1))**2 ) idelta(k)=NINT(delta) if(w(k,1).gt.0.0)then if(idelta(k).lt.idmin) idmin=idelta(k) aar=aar+ABS(res(k,1))*w(k,1) endif enddo aar=aar/(knobs(1)-nobswithw0) c c write first line of summary card: c write(2,'(1x,3i2.2,1x,i2,'':'',i2,'':'',f6.3,1x & f7.4,a1,f8.4,a1,1x,f7.3,2x, & f3.1,2x,i2,1x,i3,1x,i3,f5.2,f6.2, & 1x,f5.2)') & iyr(1),imo(1),iday(1),ihr(1),nin,sec, & xlat,cns,xlon,cew,e(4,1), & emag(1),knobs(1)-nobswithw0,idmin,igap(1),rms(1),ale(1), & spread write(2,'(''0 ERX ERY ERZ Q SQD ADJ IN NR '', & ''AVR AAR NM AVXM SDXM IT'')') c c standard deviations : c (square-root of diagonalelements of UNIT covariance matrix c erh=sqrt(s(2)**2 + s(3)**2) erx=s(2) ery=s(3) erz=s(4) JS=4 IF((RMS(1).LT.1.00).AND.(ERH.LE.15.0))JS=3 IF((RMS(1).LT.0.60).AND.(ERH.LE.8.0).AND.(erz.LE.15.0))JS=2 IF((RMS(1).LT.0.30).AND.(ERH.LE.2.0).AND.(erz.LE.6.0)) JS=1 JD=4 no=knobs(1)-nobswithw0 OFD=e(4,1) ! focal depth TFD=2.*e(4,1) IF(OFD .LT.10.) OFD=10. IF(TFD .LT. 30.) TFD=30. IF((iGAP(1).LE.180).OR.(NO.GE.4).AND.(iDMIN.LE.100)) JD=3 IF((iGAP(1).LE.135).OR.(NO.GE.5).AND.(iDMIN.LE.TFD )) JD=2 IF((iGAP(1).LE. 90).OR.(NO.GE.6).AND.(iDMIN.LE.OFD )) JD=1 JAV=(JS+JD+1)/2 Q=class(JAV) QS=class(JS) QD=class(JD) knobs1=0 do i=1,knobs(1) if(kpwt(i,1).ge.5) knobs1=knobs1+1 enddo knobs1=knobs(1)-knobs1 ! # of obs with weight less 5 !!! IN=0 c c write second line of summary card c write(2,'(1x,f5.1,f5.1,f5.1,1x,a1,1x,a1,''/'',a1,f6.2,1x, & i2,i3,2f6.2, & i3,2x,f3.1,2x,f3.1,1x,i3)') & erx,ery,erz,q,qs,qd,steplen,IN, & knobs1,avres(1),AAR, & nmag,xmagnitude,sdxmagnitude,nitt if(icoordsystem.eq.2)then if(nreg.ge.1000)then write(2,'(''0 L+T NR:'',i4,1x,a32,''CH-COORD.:'', & f9.3,'' /'',f9.3, '' KM'')') nreg,regionname,-e(2,1),e(3,1) else write(2,'(''0 F-E NR:'',i4,1x,a32,''CH-COORD.:'', & f9.3,'' /'',f9.3, '' KM'')') nreg,regionname,-e(2,1),e(3,1) endif else write(2,'(''0 F-E NR:'',i4,1x,a32)') nreg,regionname endif write(2,'(''0 STN DIST AZM AIN PRMK HRMN P-SEC TPOBS TPCAL '', & '' -TSCOR P-RES P-WT IMP STURES'')') write(2,'('' AMX PRX SRMK XMAG S-SEC TSOBS TSCAL '', & '' -TSCOR S-RES S-WT IMP STURES'')') c k=0 c c DO LOOP for EACH OBSERVATION c do kk=1,knobs(1) k=k+1 c c station# are stored in array ISTM(iobs,ievent) c stn(stn#) is the station-name (a4) c smn(iobs,iev) is the station-name c sphase(nobs,iev) : 0 for P, 1 for S, -1 for reflected P (M-phase) c and 2 for an s-p phase c clay=' ' if(sphase(k,1).eq.0) char1='P' if(sphase(k,1).eq.1) char1='S' if(sphase(k,1).eq.2) char1='-' if(sphase(k,1).eq.-1)then char1='P' clay='M' endif c Azimuth (stn --> hypoc) = 57.296*ATAN2(xhyp-xstn,yhyp-ystn) xstn=d(k,1,1) ystn=d(k,2,1) xhyp=e(2,1) yhyp=e(3,1) azi=57.296*ATAN2(xhyp-xstn,yhyp-ystn) if(azi.lt.0) azi=azi+360. c Azimuth (hypoc --> stn) = Azimuth (stn --> hypoc) + 180 deg azi=azi+180. azi=MOD(azi,360.) iazi=NINT(azi) c tobs=pt(k,1)-e(1,1) ! P observed travel time cek cek correct time for minuite change as previously done for origin time cek (see above) cek this correction added by ek 2.May1996 c if(tobs.lt.0.)then pt(k,1)=pt(k,1)+60. endif if(tobs.gt.60.)then pt(k,1)=pt(k,1)-60. endif c tobs=pt(k,1)-e(1,1) ! P observed travel time c if(tcalc(k).lt.0.)then tcalc(k)=tcalc(k)+60. endif if(tcalc(k).gt.60.)then tcalc(k)=tcalc(k)-60. endif c c station corrections: tcorr=ptcor(istm(k,1)) if(nsp.eq.2.and.sphase(k,1).eq.1.0) tcorr=stcor(istm(k,1)) if(nsp.eq.3.and.sphase(k,1).eq.1.0) tcorr=tcorr*vpvs if(sphase(k,1).eq.2) tcorr= 0.0 c card=' ' studres=res(k,1)/sqrt(1.-drm(k,k)) if(studres.gt.999.) studres=999.999 c cek print P card (or S-card if no P obs for this station available c iprisecondcard=0 write(card,'(2X,A4,1x,2i4,I4,1X,3A1,I1,a1,2I2,3F7.3,F7.3,1x, & f7.3,1x,f6.2,1x,f6.4,f7.3)') & smn(k,1),idelta(k),iazi,iain(k),prmk(k,1),char1,prmk(k,2), & kpwt(k,1), & clay,ihr(1),nin,pt(k,1),tobs,tcalc(k), & tcorr,res(k,1),w(k,1),drm(k,k),studres cek if(w(k,1).eq.0.0) write(card(61:61),'(''*'')') if(kpwt(k,1).eq.5)then card(21:80)=' ' ! there is no P arrival! if(k.lt.knobs(1))then if(smn(k+1,1).eq.smn(k,1))then write(card(16:19),'(i4)') iain(k+1) ! angle of next phase (S) !! write(2,'(a)') card !next card will be an S endif else goto 99 endif else write(2,'(a)') card endif iamx=NINT(amx(k)) card=' ' if(xmagni(k).ne.-13.)then ! a magnitude was calculated for this observ.! write(card(1:15),'(2x,4x,i5,f4.1)') iamx, prx(k) write(card(26:28),'(f3.1)') xmagni(k) endif if(k.lt.knobs(1))then chrm? Must anything changed here for s-p phases? c c NOW PRINT S-PHASE c if(smn(k+1,1).eq.smn(k,1))then if(sphase(k+1,1).eq.1)then iprisecondcard=1 k=k+1 c char1='S' clay=' ' tobs=pt(k,1)-e(1,1) cek cek correct time for minuite change as previously done for origin time cek (see above) cek this correction added by ek 2.May1996 c if(tobs.lt.0.)then pt(k,1)=pt(k,1)+60. endif if(tobs.gt.60.)then pt(k,1)=pt(k,1)-60. endif c tobs=pt(k,1)-e(1,1) ! S observed travel time c if(tcalc(k).lt.0.)then tcalc(k)=tcalc(k)+60. endif if(tcalc(k).gt.60.)then tcalc(k)=tcalc(k)-60. endif c tcorr=ptcor(istm(k,1)) if(nsp.eq.2.and.sphase(k,1).eq.1.0) then tcorr=stcor(istm(k,1)) endif if(nsp.eq.3.and.sphase(k,1).eq.1.0) then tcorr=tcorr*vpvs endif cek NOW write a following card (second phase) for same station cek 29.3.95 write(card(3:6),'(a4)') smn(k-1,1) !write station name for S write(card(21:25),'(3a1,i1,a1)') & prmk(k,1),char1,prmk(k,2),kpwt(k,1),clay studres=res(k,1)/sqrt(1.-drm(k,k)) if(studres.gt.999.) studres=999.999 write(card(30:),'(3F7.3,F7.3,1x,f7.3,1x,F6.2,1x,f6.4, & f7.3)') & pt(k,1),tobs,tcalc(k), & tcorr,res(k,1),w(k,1),drm(k,k),studres cek if(w(k,1).eq.0.0) write(card(61:61),'(''*'')') endif endif endif cek next statements may95 if(iprisecondcard.eq.1) then write(2,'(a)') card endif cek if(kpwt(k,1).lt.5) write(2,'(a)') card 2022 continue if(k.eq.knobs(1)) goto 99 enddo c 99 continue call DATETIMEX(ctime) ! get date&time from system write(2,'('' $$$ '',2x,''VELEST-Version ETH-11FEB92'', & '' located at: '',a20)') ctime write(2,*) write(2,*) c return end ! of subr. statislout c subroutine NITTOUTPUT(damp) c c output the results of iteration NITT: c implicit none real damp include 'vel_com.f' c real avdt,avdx,avdy,avdz,aavdt,aavdx,aavdy,aavdz real avelo integer i,j2,j1,j,k,k2,j11,j22,kj,jjj,ifl,ksta1,k1,kk1 integer ksta2 real cc(ist) character*1 reflch c c output hypocenters of this iteration: c avdt=0.0 avdx=0.0 avdy=0.0 avdz=0.0 aavdt=0.0 aavdx=0.0 aavdy=0.0 aavdz=0.0 write(16,*) write(16,'(4h eq, 7x, 2hot, 5x, 1hx, 6x, 1hy, 6x, 1hz, 6x,3hrms, & 4x,5havres,'' dot dx dy dz'' )') c do 29 i=1,legs c c print constrain-info if necessary: c if(isingle.ne.0)then if(isconstrain(1).eq.1)then write(16,*)' *** nitt<2 --> ', & 'depth-adjustment := 0.0 for event ',i endif if(isconstrain(2).eq.1)then write(16,*)' *** igap>250 --> ', & 'depth-adjustment := 0.0 for event ',i endif if(isconstrain(3).eq.1)then write(16,*)' *** depth-adjustment constrained for event ',i endif endif if(iconstrain(i).eq.1)then write(16,'('' ***** depth constrained for event '',i5)') i endif c c output new hypocenter-results got in this iteration: c j2=4*i j1=j2-3 if(i.gt.neqs)then ! for shots j1=3*neqs+i j2=j1 endif if(icoordsystem.eq.2)then write(16,37) i,e(1,i),-e(2,i),(e(j,i),j=3,4),rms(i),avres(i), & b(j1), -b(j1+1), +b(j1+2), b(j1+3) ! dot dx dy dz else write(16,37) i,(e(j,i),j=1,4),rms(i),avres(i), & (b(j),j=j1,j2) ! dot dx dy dz endif 37 format (1x,i4,3x,6f7.2,2x,4f7.3) avdt=avdt+b(j1) avdx=avdx+b(j1+1) avdy=avdy+b(j1+2) avdz=avdz+b(j1+3) aavdt=aavdt+ABS(b(j1)) aavdx=aavdx+ABS(b(j1+1)) aavdy=aavdy+ABS(b(j1+2)) aavdz=aavdz+ABS(b(j1+3)) c 29 continue ! loop over all events (printout) c if(icoordsystem.eq.2) avdx=-avdx avdt=avdt/float(legs) avdx=avdx/float(legs) avdy=avdy/float(legs) avdz=avdz/float(legs) aavdt=aavdt/float(legs) aavdx=aavdx/float(legs) aavdy=aavdy/float(legs) aavdz=aavdz/float(legs) write(16,*) write(16,'('' A V E R A G E of ADJUSTMENTS :'',19x,4f7.3)') & avdt,avdx,avdy,avdz write(16,'('' A V E R A G E of ABSOLUTE ADJUSTMENTS :'',10x, & 4f7.3)') aavdt,aavdx,aavdy,aavdz write(16,*) c c all new hypocenters printed out now. c if(damp.ne.1.0)then write(16,124) damp 124 format(/,' Step length damping of ',f7.5,' was applied.',/) else write(16,'(/,''NO step length damping applied'',/)') endif c c print velocity adjustments and velocity-model here: c if(scale(6).eq.0.0) goto 44 ! no velocity-adjustments... j1=4*neqs+nshot+1 j2=j1+nltot-1 k=0 write(16,*) write(16,40) 40 format(' Velocity adjustments:') write(16,41) 41 format(5x,'vp dvp hp reflector') c c do it for all velocity-models c do i=1,nmod write(16,71) i 71 format(1x,'Velocity model',i4) k2=laysum(i) j11=j1+k2-1 j22=j11+nplay(i)-1 kj=1 c c do it for all layers in this model ( = i ) c do jjj=j11,j22 if(kj.eq.ireflector)reflch=reflchar if(kj.ne.ireflector)reflch=' ' write(16,63) vp(i,kj),b(jjj),hp(i,kj),reflch 63 format(1x,2f7.3,2x,f7.3,5x,a1) kj=kj+1 enddo c c calculate and print average velocities of the model i : c ifl=1 write(16,*) write(16,*)'Calculation of average velocity starts at layer #', & ifl avelo=0 do kj=ifl+1,nplay(i) avelo=avelo + ( hp(i,kj)-hp(i,kj-1) ) * vp(i,kj-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(i,kj-1),hp(i,kj),vp(i,kj-1), & avelo/(hp(i,kj)-hp(i,ifl)),hp(i,kj) enddo write(16,*) c ifl=2 write(16,*) write(16,*)'Calculation of average velocity starts at layer #', & ifl avelo=0 do kj=ifl+1,nplay(i) avelo=avelo + ( hp(i,kj)-hp(i,kj-1) ) * vp(i,kj-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(i,kj-1),hp(i,kj),vp(i,kj-1), & avelo/(hp(i,kj)-hp(i,ifl)),hp(i,kj) enddo write(16,*) write(16,*) enddo ! loop over all models c c each velocity-model and its changes printed out now. c c print p- & s- station-corrections here: c 44 if(scale(5).eq.0.0) goto 72 ! no station-correction adjustments... write(16,*) write(16,'('' Adjusted station corrections:'')') write(16,48) 48 format(2x,' stn ptcor dpcor ') k1=4*neqs+nshot+nltot+1 ksta1=ksta if(nsp.eq.2) ksta1=ksta/2 k2=k1+ksta1-1 c c print p-correction for all stations: c do j=1,nsta cc(j)=0. if(map1(j).eq.0) goto 49 if(map1(j).gt.ksta1) goto 49 kk1=k1-1+map1(j) cc(j)=b(kk1) ! STATION-CORRECTION- cccc ptcor(j)=ptcor(j)+cc(j) ! ADJUSTMENT !!! (p-correction) 49 continue enddo write(16,50) (stn(j),ptcor(j),cc(j),j=1,nsta) 50 format(4(2x,a4,2f7.3)) if(nsp.ne.2) goto 72 write(16,'('' Adjusted station corrections:'')') write(16,73) 73 format(2x,' stn stcor dscor ') k1=4*neqs+nshot+nltot+1+ksta1 ksta2=ksta-ksta1 k2=k1+ksta2-1 c c print s-correction for all stations: c do j=1,nsta cc(j)=0. if(map1(j).eq.0) goto 74 if(map1(j).gt.ksta2) goto 74 kk1=k1-1+map1(j) cc(j)=b(kk1) ! STATION-CORRECTION- ccc stcor(j)=stcor(j)+cc(j) ! ADJUSTMENT !!! (s-correction) 74 continue enddo write(16,50) (stn(j),stcor(j),cc(j),j=1,nsta) c 72 continue write(16,*) c RETURN c end ! of subr. nittoutput c subroutine FINALHYPOCOUT c c output all the final hypocenters, print output simultaneous mode c and *cnv format c implicit none include 'vel_com.f' c real zero,xlat,xlon,xxx,sec integer izero,i,nin,j real tt(ist) character*1 phzz(ist), cns,cew parameter (zero=0.0,izero=0) integer year19,sec10,lat1000,lon1000,xout,yout,dep10 integer mag10,rms100,idmin,aa real dist,dmin,xsta,ysta c if(.not.single_turbo) write(16,*) if(isingle.ne.0)then if(.not.single_turbo) write(16,1111) write(6,1111) else if(.not.single_turbo)then write(16,11) endif endif do 12 i=1,legs c c convert hypocenter into degrees: c if(icoordsystem.eq.2)then call GEOKO( -e(2,i), e(3,i), xlat, xlon , 1 ) ! calc. LAT/LON xlon=-xlon xxx=-e(2,i) else call SDC( e(2,i), e(3,i), xlat, xlon , 1 ) ! calc. LAT/LON xxx=e(2,i) endif if(xlat.lt.0.0)then cns='S' xlat=-xlat else cns='N' endif if(xlon.lt.0.0)then cew='E' xlon=-xlon else cew='W' endif c sec=e(1,i) nin=imin(i) 23 if(sec.lt.0.) goto 13 15 if(sec.lt.60.) goto 14 sec=sec-60. nin=nin+1 goto 15 13 sec=sec+60. nin=nin-1 goto 23 11 format(1h ,4x,' date origin latitude longitude ', ! file016 & ' depth mag no rms x y z') 1111 format(' date origin latitude longitude', ! screen (unit=6) & ' depth mag no rms x y z') c c output summary information c 14 continue if(nin.lt.0)then ! U.K. 3.Feb.87 nin=nin+60 ihr(i)=ihr(i)-1 endif c call GAPCALC(i) c if(.not.single_turbo)then write(16,'(1x,i3,1x,3i2.2,1x,2i2.2,f6.2, & 1x,f7.4,a1,1x,f8.4,a1,1x & f6.2,f5.2,i4,f6.3,1x,3f7.2)') & i,iyr(i),imo(i),iday(i),ihr(i),nin,sec, & xlat,cns,xlon,cew,e(4,i), & emag(i),knobs(i)-nobswithw0,rms(i), & xxx,(e(j,i),j=3,4) endif c if(isingle.ne.0)then write(6,'(1x,3i2.2,1x,2i2.2,f6.2, & 1x,f7.4,a1,1x,f8.4,a1,1x, & f6.2,f5.2,i4,f6.3,2f7.2,f6.2)') & iyr(i),imo(i),iday(i),ihr(i),nin,sec, & xlat,cns,xlon,cew,e(4,i), & emag(i),knobs(i)-nobswithw0,rms(i), & xxx,(e(j,i),j=3,4) endif c if(ismpout.eq.1)then year19 = iyr(i) + 1900 sec10 = nint(sec * 10.) lat1000 = nint(xlat * 1000.) lon1000 = nint(xlon * 1000.) xout = nint(xxx) yout = nint(e(3,i)) dep10 = nint(e(4,i)) if (dep10.lt.0.0) then dep10 = 0.0 endif mag10 = nint(emag(1) * 10.) if (mag10.lt.0.0) then mag10 = 0.0 endif rms100 = nint(rms(i) * 100.) c c Calculating dmin c dmin = 9999 do aa=1,knobs(i) if (kpwt(i,aa).lt.4) then xsta = -x(istm(aa,i),1) ysta = x(istm(aa,i),2) dist = sqrt((xxx-xsta)**2 + (e(3,i) - ysta)**2) if (dist.lt.dmin) then dmin = dist endif endif enddo idmin = nint(dmin) write(smpline,'(i4,4i2.2,i3.3,i5.5,a1,i6.6,a1, & i3.3,i2.2,''Ml'',i4.4,2i3,''000000000SEDL'', & 2i3,i4.4,i2)') & year19,imo(i),iday(i),ihr(i),nin,sec10, & lat1000,cns,lon1000,cew, & dep10,mag10,nreg,xout,yout, & rms100,igap(i),idmin,knobs(i)-nobswithw0 endif c chrm If running in single mode, the diagonal elements of the covariance matrix chrm will also added to the smpline. In the simultaneous mode the line will be chrm written to the file here. c cek cek this option turned off for single event mode since smp-file only in cek SED special format cek if(isingle.eq.0.and.ismpout.eq.1) then write(11,'(a80)') smpline endif ccc if(.not.single_turbo) write(16,*) if(isingle.ne.0)then if(.not.single_turbo)then write(16,'(1x,''Event# '',i3,'' GAP = '',i3)') & isingle,igap(i) endif if(icoordsystem.eq.2.and.nreg.ge.1000)then if(.not.single_turbo)then write(16,'(1x,a32,'' L+T Nr.: '',i4)') & regionname,nreg endif write(6,'(1x,a32,'' L+T Nr.: '',i4)') & regionname,nreg else if(.not.single_turbo)then write(16,'(1x,a32,'' F-E Nr.: '',i4)') & regionname,nreg endif write(6,'(1x,a32,'' F-E Nr.: '',i4)') & regionname,nreg endif endif if(icnvout.eq.0) goto 12 ! do NOT write on file07 c c---- output final hypocenters and travel times to file07 c cek write(7,'(3i2,1x,2i2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,2f7.2)') cek & iyr(i),imo(i),iday(i),ihr(i),nin,sec, cek & xlat,cns,xlon,cew, cek & e(4,i),emag(i) cek cek next statement changed by E.Kissling, 21.12.90: cek added output of gap and rms of event to converted format cek write(7,'(3i2,1x,2i2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,2f7.2, & 4x,i3,5x,f5.2)') & iyr(i),imo(i),iday(i),ihr(i),nin,sec, & xlat,cns,xlon,cew, & e(4,i),emag(i),igap(i),rms(i) c imin(i)=nin do 18 j=1,knobs(i) 18 tt(j)=pt(j,i)-e(1,i) E(1,I)=SEC c do j=1,knobs(i) phzz(j)='P' if(sphase(j,i).eq.1.) phzz(j)='S' if(sphase(j,i).eq.-1.) phzz(j)='M' if(sphase(j,i).eq.2.) phzz(j)='-' enddo write(7,19) (smn(j,i),PHZZ(j),kpwt(j,i),tt(j),j=1,knobs(i)) write(7,*) 19 format(6(a4,a1,i1,f6.2)) c 12 continue if(.not.single_turbo) write(16,*) c RETURN end ! of subr. finalhypocout c subroutine OPENERROR(subr,char) c implicit none include 'vel_com.f' c character*(*) subr,char write(6,*)'WARNING:' write(6,*)'SUBROUTINE :',subr,' ERROR OPENING FILE: ',char if(.not.single_turbo)then write(16,*)'WARNING:' write(16,*)'SUBROUTINE :',subr,' ERROR OPENING FILE: ',char endif stop'Openerror; program VELEST stopped !' end ! of subr. openerror c subroutine STINP(itime,stn,sfreq,isper,iscon,isdmp,isamp,scor,ier) c tabelle fuer stationen im input file c itime= eventtime in minuten c c ifilt(l)= sfreq c iseis(l)= isper c sconst(l)=float(iscon)/10. c sdampf(l)= float(isdmp)/10. c voltgain(l)= isamp c cormag(l)= float(iscor)/1000. c implicit none c integer isper,iscon,isdmp,isamp,ier real scor integer ifirstcall,ilin,ierr,isyr1,ismo1,isdy1,ishr1,ismin1 integer isyr2,ismo2,isdy2,ishr2,ismin2,iscor character*2 sfreq chrm character*4 snam,stn character*4 stn cNEW!!: character*6 snam6,stn6 integer itime,istime1,istime2,juliam c character*80 stlin(600) ! file STLIST.DAT contains currently 600 lines integer maxstlin save stlin save maxstlin, ifirstcall c c for the first time in this subr. --> read seismo-file into STLIN : c if(ifirstcall.ne.10000001)then ifirstcall=10000001 maxstlin=1 1000 read(10,'(a)',end=2000) stlin(maxstlin) maxstlin=maxstlin+1 if(maxstlin.eq.600) stop'STINP>>> array stlin too small!!' goto 1000 2000 maxstlin=maxstlin-1 endif c stn6=stn ilin=0 ierr=0 1 ilin=ilin+1 if(ilin.gt.maxstlin) goto 40 read(stlin(ilin),'(a6)') snam6 !!!!NEW if(snam6(1:4).ne.stn6(1:4)) goto 1 20 ilin=ilin+1 if(ilin.gt.maxstlin) goto 40 read(stlin(ilin),11)isyr1,ismo1,isdy1,ishr1,ismin1, & isyr2,ismo2,isdy2,ishr2,ismin2, & sfreq,isper,iscon,isdmp,isamp,scor 11 format(4x,2(i4,4i2,1x),a2,i2,2i3,i6,f6.2) if(isyr1.ne.0) then istime1=juliam(isyr1,ismo1,isdy1,ishr1,ismin1) istime2=juliam(isyr2,ismo2,isdy2,ishr2,ismin2) if(itime.lt.istime1.or.itime.gt.istime2) then goto 20 else 30 ilin=ilin+1 if(ilin.gt.maxstlin) goto 40 read(stlin(ilin),11) isyr1 if(isyr1.ne.0) goto 30 endif endif iscor= scor*1000 return c c if station not found in stationfile with seismometer-parameters: c 40 continue ierr= -6 return end ! of subr. stinp c subroutine INPUTCNV(iunit,nobs, & sta,iyr,imo,iday,ihr,imin,sec, & rmk1,rmk2,cphase,iwt,amx,prx, & xlat,xlon,xmagni,depth,origtime, & i1,i2,i3,eventtype) c c on Output: c --------- c EQS: i1=ifx(i) c SHOTS: i1=icc c implicit none c integer maxobsperevent parameter (maxobsperevent=180) integer nobs character*4 sta(maxobsperevent) integer*4 itime real sec(maxobsperevent) character*1 rmk1(maxobsperevent),rmk2(maxobsperevent), & cphase(maxobsperevent) integer iunit,iwt(maxobsperevent) real amx(maxobsperevent), prx(maxobsperevent), & xlat,xlon real xmagni, depth, origtime real ttime(maxobsperevent) character*1 eventtype integer i1,i2,i3 character*1 cns,cew c character*80 cline integer iyr,imo,iday,ihr,imin integer j,j1,j2 c 1 eventtype='L' j2=-1 nobs=0 c 2 read(iunit,'(a)',end=99) cline if(cline.eq.' ') goto 2 cek search for end of *.cnv file, marked by 9999 if(cline.eq.'9999') goto 999 c cek next line adjusted by EK 3.12.90 read(cline,'(3i2,1x,2i2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,1x,f7.2, 1 2x,f5.2)', & err=9999,end=999) & iyr,imo,iday,ihr,imin,origtime, & xlat,cns,xlon,cew,depth,xmagni ! i1 =ifx(i) !=======================! trial hypocenter !! cek i1-switch is dummy i1=0 c cek EQS: i1=ifx(i) ! no longer in use !!! c SHOTS: i1=icc c if(cns.eq.'S') xlat=-xlat if(cew.eq.'E') xlon=-xlon c call TIMECLEAR(iyr,imo,iday,ihr,imin,origtime,itime) c j2=0 10 j1=j2+1 j2=j1+5 read(iunit,'(6(a4,a1,i1,f6.2))',end=999) & (sta(j),cphase(j),iwt(j),ttime(j),j=j1,j2) do j=j1,j2 if(sta(j).eq.' ')then if(j.eq.1.and.j1.eq.1) goto 1 ! blank-line read ! j2=j-1 ! event is completely read-in goto 99 endif enddo goto 10 ! read next input-line c 99 continue nobs=j2 do j=1,nobs sec(j)=origtime+ttime(j) enddo c RETURN c 999 continue nobs=-1 RETURN c 9999 continue write(6,*)'INPUTCNV>>> read-error! input-line is:' write(6,'(a)') cline stop'subr. INPUTCNV >>> error!' c end ! of subr. inputcnv c subroutine INPUTARCVEL(iunit,nobs, & sta,iyr,imo,iday,ihr,imin,sec, & rmk1,rmk2,cphase,iwt,amx,prx, & xlat,xlon,xmagni,depth,origtime, & i1,i2,i3,eventtype) c c implemented by EK 9.11.93 to read velest-archive type input c data for single event location mode , replacing older c input routine for SED-format. called by ised=1 c c on Output: c --------- c EQS: i1=ifx(i) ! no longer in use !!! c SHOTS: i1=icc c implicit none c integer maxobsperevent parameter (maxobsperevent=180) integer nobs character*4 sta(maxobsperevent) integer*4 itime real sec(maxobsperevent) character*1 rmk1(maxobsperevent),rmk2(maxobsperevent), & cphase(maxobsperevent) integer iunit,iwt(maxobsperevent) real amx(maxobsperevent), prx(maxobsperevent), & xlat,xlon real xmagni, depth, origtime real ttime(maxobsperevent) character*1 eventtype integer i1,i2,i3 character*1 cns,cew c character*80 cline integer iyr,imo,iday,ihr,imin integer j,j1 c 1 eventtype='L' nobs=-1 c 2 read(iunit,'(a)',end=999) cline if(cline.eq.' ') goto 2 c read(cline,'(3i2,1x,2i2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,1x,f7.2, 1 2x,f5.2)', & err=9999,end=999) & iyr,imo,iday,ihr,imin,origtime, & xlat,cns,xlon,cew,depth,xmagni ! i1 =ifx(i) !=======================! trial hypocenter !! cek i1-switch is dummy i1=0 c cek EQS: i1=ifx(i) ! no longer in use !!! c SHOTS: i1=icc c if(cns.eq.'S') xlat=-xlat if(cew.eq.'E') xlon=-xlon c call TIMECLEAR(iyr,imo,iday,ihr,imin,origtime,itime) c j1=1 do j=1,maxobsperevent read(iunit,'(2x,a4,2x,a1,3x,i1,3x,f6.2)',end=99) & sta(j),cphase(j),iwt(j),ttime(j) if(sta(j).eq.' ')then cek mistake: j1=j1-1 ! event is completely read-in goto 99 endif j1=j enddo c 99 continue nobs=j1 c do j=1,nobs sec(j)=origtime+ttime(j) enddo c RETURN c 999 continue nobs=-1 RETURN c 9999 continue write(6,*)'INPUTARCVEL>>> read-error! input-line is:' write(6,'(a)') cline stop'subr. INPUTARCVEL >>> error!' c end ! of subr. inputarcvel c c subroutine INPUTSED(iunit,nobs, & sta,iyr,imo,iday,ihr,imin,sec, & rmk1,rmk2,cphase,iwt,amx,prx, & xlat,xlon,xmagni,depth,origtime, & iswt,ifixsolution,ievnr,eventtype) c c read inputfile (phase-list in *.SED format) c if NOBS=-1 ==> end of input-file detected! c implicit none c integer maxobsperevent parameter (maxobsperevent=180) integer nobs character*4 sta(maxobsperevent) integer*4 itime,itime1(maxobsperevent) real sec(maxobsperevent) character*1 rmk1(maxobsperevent),rmk2(maxobsperevent), & cphase(maxobsperevent),clayP,clayS integer iunit,iwt(maxobsperevent) real amx(maxobsperevent), prx(maxobsperevent), & xlat,xlon real xmagni, depth, origtime integer iswt,ifixsolution,ievnr character*1 eventtype c character*80 cline integer iyr1(maxobsperevent),imo1(maxobsperevent), & iday1(maxobsperevent),ihr1(maxobsperevent), & kmin1(maxobsperevent) integer iyr,imo,iday,ihr,imin integer j,j1, jjmin,jjmin1 c ifixsolution=0 nobs=0 j=0 c 1 read(iunit,'(a)',end=999) cline if(INDEX(cline,'INST').gt.0) goto 1 if(INDEX(cline,'SED').gt.0) goto 1 if(INDEX(cline,'BOL').gt.0) goto 1 if(INDEX(cline,'EVENT').gt.0) goto 1 c j=j+1 if(cline(1:4).eq.' ')then read(cline,'(17x,i1,i1,f5.2,2f8.3)') iswt,ifixsolution, & depth,xlat,xlon nobs=j-1 goto 99 ! one event finished!!! endif read(cline,'(a4,a1,a1,a1,i1,a1,5i2,f5.2,7x, & f5.2,2x,a1,i1,4x,f3.0,f3.1)',err=9999) & sta(j),rmk1(j),cphase(j),rmk2(j),iwt(j),clayP, & iyr1(j),imo1(j),iday1(j),ihr1(j),kmin1(j),sec(j), & sec(j+1),clayS,iwt(j+1),amx(j),prx(j) if(j.eq.1)then read(cline(64:64),'(a1)') eventtype read(cline(76:79),'(i4)') ievnr endif if(iwt(j).eq.9)then j=j-1 goto 1 ! p-weight 9 not accepted !(means: only T(s-p) ) endif if(clayP.eq.'m'.or.clayP.eq.'M') cphase(j)='M' if(cline(20:24).eq.' ') iwt(j)=5 ! NO P-arrival read ! ccc VELEST cannot handle reflected S-phases; therefore skip them! if(clayS.ne.' ') cline(32:36)=' ' ! <-- set NO S-data if REFLECTED if(cline(32:36).ne.' ')then ! field with observed S-time in sec cphase(j+1)='S' sta(j+1)=sta(j) rmk1(j+1)=' ' rmk2(j+1)=' ' iyr1(j+1)=iyr1(j) imo1(j+1)=imo1(j) iday1(j+1)=iday1(j) ihr1(j+1)=ihr1(j) kmin1(j+1)=kmin1(j) if(iwt(j).eq.5)then ! NO P arrival here; store amx&prx to S-arrival ! amx(j+1)=amx(j) prx(j+1)=prx(j) endif j=j+1 ! increment J, because two phases have been added!!! goto 1 else goto 1 ! no S-phase-data: elements J+1 will be overwritten endif c 99 continue do j=1,nobs if(iwt(j).lt.5)then jjmin1=j goto 222 endif enddo 222 j=jjmin1 call TIMECLEAR(iyr1(j),imo1(j),iday1(j),ihr1(j),kmin1(j),sec(j), & itime1(j)) itime=itime1(j) jjmin=jjmin1 do j=1,nobs if(iwt(j).lt.5)then call TIMECLEAR(iyr1(j),imo1(j),iday1(j),ihr1(j),kmin1(j), & sec(j),itime1(j)) if(itime1(j).lt.itime)then itime=itime1(j) jjmin=j endif endif enddo c c itime is the earliest arrival-minute; c adjust all seconds according to this (earliest) minute c 100 continue do j1=1,nobs if(iwt(j1).lt.5) sec(j1)=(itime1(j1)-itime)*60. + sec(j1) enddo origtime=sec(jjmin) iyr=iyr1(jjmin) imo=imo1(jjmin) iday=iday1(jjmin) ihr=ihr1(jjmin) imin=kmin1(jjmin) c RETURN c 999 continue ! come here, if end-of-input-file detected ! nobs=-1 RETURN c 9999 continue write(6,*)'INPUTSED>>> read-error! input-line is:' write(6,'(a)') cline stop'subr. INPUTSED >>> error!' c end ! of subr. inputsed c c subroutine INPUTSED_NEW(iunit,nobs, & sta,iyr,imo,iday,ihr,imin,sec, & rmk1,rmk2,cphase,iwt,amx,prx, & xlat,xlon,xmagni,depth,origtime, & iswt,ifixsolution,ievnr,eventtype,itrial) c c read inputfile (phase-list in *.SED format) c if NOBS=-1 ==> end of input-file detected! c implicit none c integer maxobsperevent parameter (maxobsperevent=180) integer nobs character*4 sta(maxobsperevent) integer*4 itime,itime_o,itime1(maxobsperevent) real sec(maxobsperevent) character*1 rmk1(maxobsperevent),rmk2(maxobsperevent), & cphase(maxobsperevent) integer iunit,iwt(maxobsperevent) real amx(maxobsperevent), prx(maxobsperevent), & xlat,xlon real xmagni, depth, origtime integer iswt,ifixsolution,ievnr character*1 eventtype c character*80 cline integer iyr1(maxobsperevent),imo1(maxobsperevent), & iday1(maxobsperevent),ihr1(maxobsperevent), & kmin1(maxobsperevent) integer iyr,imo,iday,ihr,imin integer j,j1, jjmin,jjmin1 integer ev_year,ev_month,ev_day,ev_hour,ev_min character*8 phase_id,amx_type integer use_flag,amx_flag integer found integer itrial c ifixsolution=0 nobs=0 j=0 c 1 read(iunit,'(a)',end=999) cline c c The following cards will be skipped c if(INDEX(cline,'SED').gt.0) goto 1 if(INDEX(cline,'BOL').gt.0) goto 1 if(INDEX(cline,'EVENT').gt.0) goto 1 c c The INST card will be partially read c if(INDEX(cline,'INST').gt.0) then read(cline,'(29x,i2)') iswt goto 1 endif c cccccccccccccccccccccccccccc c Hypon input section c cccccccccccccccccccccccccccc c read(line,*,err=900) c + latr,lonr,ztr,y0tr,motr,dytr,h0tr, c + m0tr,s0tr,inst c latr: trial latitude c lonr: " longitude c ztr: " depth c y0tr: " origin year c motr: " " month c dytr: " " day c h0tr: " " hour c m0tr: " " minute c s0tr: " " second c inst: 0= free solution c 1= fix depth c 2= fix lat/lon depth c 3= fix origin time c 4= fix all ccccccccccccccccccccccccccccccccccccccccccc c if(INDEX(cline,'TRIAL').gt.0) then read(cline,*) xlat,xlon,depth,iyr,imo,iday,ihr,imin, & origtime,ifixsolution xlon = -xlon iyr = iyr - 1900 if (ifixsolution.eq.4) then ifixsolution = 9 endif call TIMECLEAR(iyr,imo,iday,ihr,imin,origtime,itime_o) c c Reading the line after the TRIAL card c read(iunit,'(a)',end=999) cline read(cline,'(2x,i2,1x,i2,1x,i2,1x,i2,1x,i2)') & ev_year,ev_month,ev_day,ev_hour,ev_min read(cline(55:55),'(a1)') eventtype read(cline(71:78),'(i8)') ievnr goto 1 endif c c If the SKIP card is reached, the input for one event is finished c if(INDEX(cline,'SKIP').gt.0) then nobs=j goto 99 ! one event finished!!! endif c c If here, a phase will be read c j=j+1 read(cline,'(a4,4x,a8,a1,a1,f8.3,i2,f5.2,f9.0,1x,a8,i3)', & err=9999) & sta(j),phase_id,rmk1(j),rmk2(j),sec(j),use_flag, & prx(j),amx(j),amx_type,amx_flag call casefold(phase_id) call casefold(amx_type) call casefold(rmk1(j)) call casefold(rmk2(j)) c c Treat the supported phase types c found = 0 if (phase_id.eq.'P ') then found=1 cphase(j) = 'P' endif if (phase_id.eq.'S ') then found=1 cphase(j) = 'S' endif if (phase_id.eq.'PMP ') then found=1 cphase(j) = 'M' endif if (phase_id.eq.'S-P ') then found=1 cphase(j) = '-' endif c c If the read phase is not supported, it will be skipped c if (found.eq.0) then j=j-1 goto1 endif c c Conversion of the weights c if (rmk1(j).eq.'I') then iwt(j)=0 endif if (rmk1(j).eq.'E') then iwt(j)=1 endif if (rmk1(j).eq.'Q') then iwt(j)=2 endif if (rmk1(j).eq.' ') then ! Should never happen iwt(j)=5 endif chrm if (use_flag.eq.0) then chrm j=j-1 chrm goto 1 chrm endif if (use_flag.eq.0) then iwt(j) = 4 endif c c Assigning year,month,day,hour,min to each phase c iyr1(j)=ev_year imo1(j)=ev_month iday1(j)=ev_day ihr1(j)=ev_hour kmin1(j)=ev_min c c Read the next event c goto 1 c c If here, all phases of one event are read in c c 99 continue c c Searching for the first phase with weight less than 5 c do j=1,nobs if(iwt(j).lt.5)then jjmin1=j goto 222 endif enddo 222 j=jjmin1 call TIMECLEAR(iyr1(j),imo1(j),iday1(j),ihr1(j),kmin1(j),sec(j), & itime1(j)) itime=itime1(j) jjmin=jjmin1 do j=1,nobs if(iwt(j).lt.5)then call TIMECLEAR(iyr1(j),imo1(j),iday1(j),ihr1(j),kmin1(j), & sec(j),itime1(j)) if(itime1(j).lt.itime)then itime=itime1(j) jjmin=j endif endif enddo c c itime is the earliest arrival-minute; c adjust all seconds according to this (earliest) minute c 100 continue if (itrial.gt.0) then do j1=1,nobs if(iwt(j1).lt.5) sec(j1)=(itime1(j1)-itime)*60. + sec(j1) chrm itime1(j1) = itime ! Activate this, if you want to use itime1(j1) enddo origtime=sec(jjmin) iyr=iyr1(jjmin) imo=imo1(jjmin) iday=iday1(jjmin) ihr=ihr1(jjmin) imin=kmin1(jjmin) else do j1=1,nobs if(iwt(j1).lt.5) then sec(j1)=(itime1(j1)-itime_o)*60. + sec(j1) if (sec(j1).lt.0) then sec(j1) = 0 endif endif chrm itime1(j1) = itime ! Activate this, if you want to use itime1(j1) enddo endif c RETURN c 999 continue ! come here, if end-of-input-file detected ! nobs=-1 RETURN c 9999 continue write(6,*)'INPUTSED>>> read-error! input-line is:' write(6,'(a)') cline stop'subr. INPUTSED >>> error!' c end ! of subr. inputsed_new c cek end of vel_io.f c cek begin of vel_kern.f c subroutine SETUNT(nitt,invertratio,nsinv,icount, & xythet,stathet,othet,vthet,zthet,scale) c c set scale factors c implicit none integer nitt,invertratio,nsinv,icount real xythet,stathet,othet,vthet,zthet real scale(7) c c*** set damping so that velocities are adjusted every c*** "invertratio" iterations icount=mod(nitt,invertratio) c c scale(1) : origin-time c scale(2) : x c scale(3) : y c scale(4) : z c scale(5) : stacorr c scale(6) : veloc.model c scale(7) : (not used) c scale(1)=1.0 scale(7)=1.0 ! not used in this version!!! scale(2)=sqrt(othet/xythet) scale(3)=scale(2) scale(4)=sqrt(othet/zthet) scale(5)=0.0 if(nsinv.ne.0.and.icount.eq.0) scale(5)=sqrt(othet/stathet) scale(6)=0.0 if(icount.eq.0) scale(6)=sqrt(othet/vthet) return end ! of subr. setunt c subroutine FIXUNT(b,neqs,nshot,nl,ksta,scale, & vdamp,itotmodels,inltot,nlfirst) c c---- restore solution to proper units c implicit none integer neqs,nshot,nl,ksta real b(4*neqs+nshot+nl+ksta),scale(7) integer nlfirst,itotmodels,inltot real vdamp(itotmodels,inltot) integer i,j,k,l,m i=0 if(neqs.le.0) goto 10 do 1 j=1,neqs do 1 k=1,4 i=i+1 1 b(i)=b(i)*scale(k) 10 continue if(nshot.le.0) goto 3 do 2 j=1,nshot i=i+1 2 b(i)=b(i)*scale(7) 3 if(scale(6).eq.0.) return l=0 m=1 do 5 j=1,nl i=i+1 l=l+1 if(l.gt.nlfirst) then m=m+1 l=1 endif chrm write(6,*)m,' ',l 5 b(i)=b(i)*scale(6)/vdamp(m,l) if(ksta.eq.0) return do 4 j=1,ksta i=i+1 4 b(i)=b(i)*scale(5) return end ! of subr. fixunt c subroutine SETUPMATRIXG(neq,i) c c puts one row S(i) of the data kernel into the symmetric matrix G in c order to accumulate the normal equations. c implicit none integer neq,i include 'vel_com.f' integer j,nn,nni,mm,is1,kk1,ng,mg,ksta1,ksta2,k,k2 integer nl,nf,mf,n,k1,is c ccc real WK(8,2),bwk(1) c do 2 j=1,nvar 2 s(j)=0. c c No trvdrv's for reseted obs: c if(isingle.ne.0.and.w(i,neq).eq.0.0) goto 34 c c---- calculate hypocenter indices c*** neq-- event number, i--observation number nn=4*neq-2 nni=nn-1 c*** nni- space for time term; nn thru mm -- 3 places for dtdr's if(neq.gt.neqs) nni=3*neqs+neq mm=nn+2 if(neq.gt.neqs) mm=nni s(nni)=1.0*scale(1) if (sphase(i,neq).eq.2.0) then ! new: for s-p phases (hrm 30.3.92) s(nni) = 0.0 ! set derivative for orig. time to zero endif is1=0 if(neq.le.neqs) goto 40 s(nni)=1.0*scale(7) kk1=map2(neq-neqs) if(nshfix.eq.1.and.kk1.ne.0) s(nni)=0.0 if(nshcor.eq.0) goto 40 if(kk1.le.0.or.kk1.gt.ksta) goto 40 if(scale(5).eq.0) goto 40 c if(nsp.eq.3.and.sphase(i,neq).eq.1.) goto 40 if(nsp.eq.2.and.sphase(i,neq).eq.1.) goto 43 ng=4*neqs+nshot+nltot+1 mg=ng-1+ksta ksta1=ksta if(kk1.gt.ksta1) goto 40 is1=ng-1+kk1 goto 44 43 continue ng=4*neqs+nshot+nltot+(ksta/2)+1 mg=4*neqs+nshot+nltot+ksta ksta1=(ksta/2) ksta2=ksta-(ksta/2) if(kk1.gt.ksta2) goto 40 is1=ng-1+kk1 44 continue s(is1)=1.0*scale(5) 40 continue k=0 if(zadj.eq.0.0) dtdr(3)=0.0 cc if(isingle.ne.0.and.nitt.lt.3) dtdr(3)=0.0 cc if(isingle.ne.0.and.jgap.gt.250) dtdr(3)=0.0 if(neq.gt.neqs) goto 3 c cEK Dez. 1994 next statement again put in effect: if(ifx(neq).eq.1) dtdr(2)=0.0 ! no longer in use U.K. 2.Oct.87 do 4 j=nn,mm k=k+1 4 s(j)=dtdr(k)*scale(k+1) 3 continue c---- calculate velocity indices if(scale(6).eq.0.) goto 34 15 k2=iphase(i,neq) nl=nplay(k2) nf=4*neqs+nshot+laysum(k2) mf=nf+nl-1 k=0 do 5 n=nf,mf k=k+1 if(veladj.eq.0.0) dtdv(k)=0.0 chrm 5 s(n)=dtdv(k)*scale(6) 5 s(n)=dtdv(k)*scale(6)/vdamp(k2,k) c---- calculate indices for station terms if(scale(5).eq.0.0) goto 34 k1=istm(i,neq) ksta1=ksta if(nsp.eq.2) ksta1=ksta/2 if(nsp.eq.2.and.sphase(i,neq).eq.1.0) goto 16 if(nsp.eq.3.and.sphase(i,neq).eq.1.0) goto 34 18 continue ng=4*neqs+nshot+nltot+1 mg=ng-1+ksta if(map1(k1).eq.0) goto 34 if(map1(k1).gt.ksta1) goto 34 is=ng-1+map1(k1) goto 17 16 ng=4*neqs+nshot+nltot+(ksta/2)+1 ksta2=ksta-(ksta/2) mg=ng-1+ksta2 if(map1(k1).eq.0) goto 34 if(map1(k1).gt.ksta2) goto 34 is=ng-1+map1(k1) 17 continue s(is)=1.0*scale(5) 34 continue cc cc store one line of G in GG: cc c c if(isingle.ne.0)then c do i1=1,4 c gg(i,i1)=s(i1) c enddo cc if(i.eq.knobs(1))then ! matrix GG is fully calculated cc call LSVDF(GG,100,knobs(1),4,BWK,1,0,SV,WK,ier) cc call ALESUBR(SV,4,ale(1)) ccccccccc test ale(1)=-log10( sv(4) ) ! test test ccccc write(6,*) sv(1),sv(2),sv(3),sv(4), ale(1) cc endif cc endif c c now accumulate normal equations (vector s contains the traveltime-derivs.) c call ACCUNORMEQS(s,nvar,res(i,neq),w(i,neq),G,RHT) c return end ! of subr. setupmatrixg c subroutine CHECKSOLUTION(istopflag,better) c c checks, whether the current solution is 'better' than the previous one. c 'better' means here, that data variance has decreased. A warning is c output in case that although the data variance has decreased the RMS c didn't. c If datvar has decreased, the output-variable DECREASING is set to 1 . c implicit none include 'vel_com.f' c integer istopflag real datvar,xmsqrs2,varat1,varat2 integer decreasing logical better c save datvar,xmsqrs2 c decreasing=0 better=.true. c if(nitt.eq.0)then datvar=davar1 xmsqrs2=xmsqrs1 endif if(.not.single_turbo)then write(16,*) if(ibackups.eq.0)then write(16,'('' Iteration nr '',i2,'' obtained:'')') nitt else write(16,'(''(Iteration nr '',i2,'') BACKUP nr '',i1, & '' obtained:'')') nitt,ibackups endif write(16,10) davar1,xmsqrs1,sqrt(xmsqrs1) 10 format(' DATVAR=',f12.6,' mean sqrd residual= ',f12.6, & ' RMS RESIDUAL= ',f12.6) endif c if(isingle.ne.0) call GAPCALC(1) c if(isingle.eq.0) call AVRESISTATIST c c*** form ratio of old to new variance varat1=datvar/davar1 c if(isingle.ne.0)then ! stop calc. for single event if changes get small if(nitt.gt.2.and.abs(datvar-davar1).lt.1e-6)then istopflag=1 if(.not.single_turbo)then write(16,*)'Changes in datvar < 1e-6 : STOPPING...' endif endif endif c*** form ratio of old to new mean sqrd residual varat2=xmsqrs2/xmsqrs1 c*** test to see if variance is increasing if(varat1.ge..99)then decreasing=1 goto 1 endif c*** test to see if mean sqrd residual is increasing if(varat1.lt..99.and.varat2.ge..99)then c c msqrd residual decreasing, but data variance increased: c if(.not.single_turbo)then write(16,'('' *** WARNING: the data variance has increased.'')') endif decreasing=1 goto 1 endif if(varat2.ge..99)then decreasing=1 goto 1 endif c 1 if(decreasing.eq.1)then c c variance is decreasing: c datvar=davar1 xmsqrs2=xmsqrs1 else c c variance increased so backup c better=.false. endif c RETURN c end ! of subr. checksolution subroutine TRAVELTIME(i,nobs,iresflag) c c computes the forward problem: all the raytracing is done, traveltimes c AND traveltime-derivatives are calculated. Moreover, a whole bunch c of statistics is done here. c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Input parameter: c c c c i = ith event c c nobs = nr of obs for the ith event c c iresflag = ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c implicit none integer i,nobs,iresflag include 'vel_com.f' c integer ii,nittdone,ifirst,k2,nl,k1,mll,nrp,nrtn integer nrpdeep,ir,kk1,j,jzz real z,ttt,tkh,r1,r2,ster,direr,refrer,refler real takeoff_angle real dtddrefl,dtdhrefl,pobs,extrat1,extrat2 integer do_s real rp(3,inrpmax), & ss(inrpmax),x2(inrpmax),y2(inrpmax),z2(inrpmax) real v1(inltot),vsq1(inltot) real dtdr_s(3),dtdv_s(inltot),ttt_s save nITTdone, ifirst c c reset statistics-parameter if iteration is new c or if NITT is the same but all rays are shot again (e.g. after c model/hypocenter-backup) c if(isingle.gt.0)then if(kpwt(nobs,i).eq.5)then ! this is not a real phase!!! if(w(nobs,i).ne.0.0) stop'TRAVELTIME>>> error in obs-wt!' res(nobs,i)=0.0 do ii=1,3 dtdr(ii)=0.0 enddo RETURN endif endif if(isingle.eq.0)then if(i.eq.1.and.nobs.eq.1.and.nitt.gt.nITTdone)ifirst=1 ! 1st obs 1x done if(i.eq.1.and.nobs.eq.1.and.nitt.eq.nITTdone)ifirst=2 c ifirst=1 ---> first of all the obs for the first time done in this iterat. c ifirst=2 ---> first of all the obs for the 2nd time coming in this iterat. if(nitt.gt.nITTdone.or.ifirst.eq.2)then nITTdone=nitt ifirst=1 call RESETSTATIS endif endif c c Reset s-p switch c do_s = 1 c c c z -- event depth z=e(4,i) c k2 -- velocity model number k2=iphase(nobs,i) 10 continue c nl -- number of layers for model k2 nl=nplay(k2) c k1 -- station number k1=istm(nobs,i) c v,vsq are the velocity and velocity squared c h(ii) is the depth to the top of layer ii c thk(ii) -- thickness of layer ii c do ii=1,nl v(ii)=vp(k2,ii) v1(ii)=vp(k2,ii) if(nsp.eq.3.and.sphase(nobs,i).eq.1.0) v(ii)=vp(k2,ii)/vpvs if(nsp.eq.3.and.sphase(nobs,i).eq.2.0) then if (do_s.eq.1) then v(ii)=vp(k2,ii)/vpvs endif endif vsq(ii)=v(ii)**2 vsq1(ii)=v1(ii)**2 h(ii)=hp(k2,ii) thk(ii)=thkp(k2,ii) enddo c c calculate tkh, r1,r2,delta : c ttt=0. tkh=x(k1,3)-h(1) ! distance from station up to top of model r1=(e(2,i)-x(k1,1)) r2=(e(3,i)-x(k1,2)) c check if event too shallow if(itopo.gt.0)then if(e(4,i).lt.0.0)then ! depth above sea-level...so near surface ! call CHTOP(-e(2,i),e(3,i),zmin, & topo1file,topo2file) ! zmin:==surface at this point else zmin=zmininput ! depth below zero ... so zmin=zmininput endif endif if(i.le.neqs)then if(e(4,i).le.zmin)then if(isingle.eq.0) e(4,i)=zmin+0.1 ! earthquakes if(isingle.ne.0) e(4,i)=zmin+0.011 ! earthquake, single event endif else if(e(4,i).le.zmin) e(4,i)=zmin+0.011 ! shots endif if(ifixsolution.gt.0.and.e(4,i).le.0.0) e(4,i)=zmin+0.001 ! fix depth to c ! min_depth allowed!! cc r3=(e(4,i)-x(k1,3)) delta=sqrt(r1*r1+r2*r2) c c set reflector-layer-boundary : c MLL=0 if(ireflector.gt.0)then if(sphase(nobs,i).eq.-1.0)then MLL=ireflector ! P is reflected at bottom of layer ireflector endif endif c c do the ray-tracing : c call RAYPATH(1,1,1,1.,1.,1.,1.,nl,thk,h,v,vsq, & e(2,i),e(3,i),e(4,i),x(k1,1),x(k1,2),x(k1,3), & rp,nrp,nrtn,jl,tkj,1,ttt,MLL,ster,direr,refrer,refler, & DTDDrefl,DTDHrefl) c call CHECKRAYPATH(rp,nrp) c c c raypoints stored in RP [1st index: x,y,z; 2nd: raypt# (max. 2*nlay)] c nrp = nr of raypoints stored at moment in RP c if(itopo.eq.2)then !check each raypoint whether it is below surface or not call RAYPOINTCHECK(rp,nrp,stn(k1)) endif c c if ray travels through the air, bend it below surface !!! c if(itopo.eq.3) call BENDRAY(rp,nrp,stn(k1),v(1),ttt) c c sum raytracer-errors c c c For s-p phases the next statements should be done after the c p-wave calculation c if (sphase(nobs,i).ne.2.0.or.do_s.eq.0) then if(isingle.eq.0)then sterr=sterr+ster direrr=direrr+direr refrerr=refrerr+refrer reflerr=reflerr+refler endif c if(isingle.eq.0) call LAYERHIT(rp,nrpdeep,nl,nrp,mll) c if(irayout.eq.1)then write(13,1301) i,stn(k1),nrp if(icoordsystem.eq.2)then write(13,1302) (-rp(1,ir),rp(2,ir),rp(3,ir),ir=1,nrp) else write(13,1302) (rp(1,ir),rp(2,ir),rp(3,ir),ir=1,nrp) endif 1301 format(/,' event =',i5,' station ',a4,' num. raypoints= ',i5) 1302 format(3(2x,3f7.2)) endif endif ! if .NOT. ... c c calculate traveltime-derivatives according to the raytype : c goto (5,5,6,6,5,6,5,8),nrtn ! nrtn=8 if ray is reflected !! c stop'TRAVELTIME>>> illegal nrtn from raytracer!!!' c 5 call TRAVDERIV('direct', & nl,mll,v1,vsq1,rp,nrp,x2,y2,z2,ss,r1,r2,i,nobs) goto 40 6 call TRAVDERIV('refracted', & nl,mll,v1,vsq1,rp,nrp,x2,y2,z2,ss,r1,r2,i,nobs) goto 40 8 call TRAVDERIV('reflected', & nl,mll,v1,vsq1,rp,nrp,x2,y2,z2,ss,r1,r2,i,nobs) 40 continue c c For s-p phases, the traveltime of the s-wave was calculated. Now c the p-wave calculation will be performed. c if (sphase(nobs,i).eq.2.0.and.do_s.eq.1) then do_s = 0 ttt_s = ttt do ii=1,3 dtdr_s(ii) = dtdr(ii) enddo do ii=1,nl dtdv_s(ii) = dtdv(ii) enddo if(nsp.eq.2) then k2 = k2 - 1 endif goto 10 endif if(sphase(nobs,i).eq.2.0) then c c calculate the s-p traveltime derivative c do ii=1,3 dtdr(ii)=dtdr_s(ii) - dtdr(ii) enddo c c calculate the s-p time difference c ttt = ttt_s - ttt endif c c calculate residual by using appropriate station-corrections : c if (sphase(nobs,i).ne.2.0) then pobs=pt(nobs,i)-e(1,i) else pobs=pt(nobs,i) endif extrat1=ptcor(k1) extrat2=0.0 if(nsp.eq.2.and.sphase(nobs,i).eq.1.0) &extrat1=stcor(k1) if(nsp.eq.2.and.sphase(nobs,i).eq.2.0) then ! s-p phases extrat1=stcor(k1) - ptcor(k1) endif if(nsp.eq.3.and.sphase(nobs,i).eq.1.0) &extrat1=ptcor(k1)*vpvs if(nsp.eq.3.and.sphase(nobs,i).eq.2.0) then ! s-p phases extrat1=ptcor(k1)*vpvs - ptcor(k1) endif if(nshcor.eq.0) goto 600 if(i.le.neqs) goto 600 kk1=map2(i-neqs) if(kk1.eq.0) goto 600 do 601 j=1,nsta if(kk1.eq.map1(j)) goto 602 601 continue goto 600 c 602 extrat2=ptcor(j) if(nsp.eq.2.and.sphase(nobs,i).eq.1.0) &extrat2=stcor(j) if(nsp.eq.3.and.sphase(nobs,i).eq.1.0) &extrat2=ptcor(j)*vpvs 600 continue res(nobs,i)=pobs-(ttt+extrat1+extrat2) c if(isingle.ne.0)then tcalc(nobs)=ttt takeoff_angle= & SQRT( (rp(1,2)-rp(1,1))**2 & +(rp(2,2)-rp(2,1))**2 ) & / & SQRT( (rp(1,2)-rp(1,1))**2 & +(rp(2,2)-rp(2,1))**2 & +(rp(3,2)-rp(3,1))**2 ) takeoff_angle=57.296*ASIN(takeoff_angle) if( (rp(3,2)-rp(3,1)) .lt. 0.0 )then takeoff_angle=180.-takeoff_angle ! ray is going upwards endif iain(nobs)=NINT(takeoff_angle) ! with respect to positive z; downwards endif c c---- save residual according to the ray-type: c if(isingle.eq.0) call RESISAVE(nrp,nrpdeep,rp,nobs,i,k1,mll) c c c if VELEST is used in single-event-mode (isingle <> 0 ), c set weight to 0 if abs(residual) after 2nd iteration is still > 2. sec c ... and normalize the weights once more ! c --> if a reading with a reseted weight gets a residual which has c become small again, 'revive' it ! c cek if(isingle.ne.0)then cek if(nitt.gt.2.and.abs(res(nobs,i)).gt.2.0 cek & .and.igap(i).lt.250)then cek call REJECTOBS(i,nobs,iresflag) cek call GAPCALC(1) cek endif cek if(nitt.gt.2.and.abs(res(nobs,i)).lt.1.0 cek & .and.igap(i).lt.250)then cek if(w(nobs,i).eq.0.0)then cek call REVIVEOBS(i,nobs,iresflag) cek call GAPCALC(1) cek endif cek endif cek endif c tctime(nobs,i)=ttt h(1)=x(k1,3)-tkh ! reset h(1) after it has been altered in subr. raypath!! thk(1)=thk(1)+tkh if(idrvout.eq.1)then write(21,*)'i=',i,' nobs=',nobs,' nitt=',nitt,' nrtn=',nrtn write(21,500) ttt,pobs,res(nobs,i) write(21,501) (dtdr(jzz),jzz=1,3) write(21,502) (dtdv(jzz),jzz=1,nl) 500 format(' ttt=',f10.5,' pobs= ',f10.5,' res= ',f10.5) 501 format('dtdr=',3f10.5) 502 format('dtdv=',7f10.5) endif 510 continue return end ! of subr. traveltime c subroutine RESETSTATIS c c called by subr. TRAVELTIME. The statistics-variables are reset here. c implicit none include 'vel_com.f' integer ihitl,jhitl c if(irflout.eq.1) rewind(77) if(irfrout.eq.1) rewind(78) if(iresout.eq.1) rewind(79) c do ihitl=1,nltot irefllayer(ihitl)=0 irefrlayer(ihitl)=0 refraylen(ihitl)=0.0 hitlay(ihitl,1)=0.0 hitlay(ihitl,2)=0.0 hitlay(ihitl,3)=0.0 enddo noheadwave=0 ! nr of straight & direct waves avhraylen=0.0 ! average horiz. raylength avvraylen=0.0 ! " vertic. " sterr=0.0 ! raytracer-errors direrr=0.0 ! " refrerr=0.0 ! " reflerr=0.0 ! " avrefrres=0.0 ! average residual for this ray-type avotheres=0.0 ! " avreflres=0.0 ! " abrefrres=0.0 ! average absolute residual for this ray type abotheres=0.0 ! " abreflres=0.0 ! " nrrefrres=0.0 ! nr of residuals for this ray-type nrotheres=0.0 ! " nrreflres=0.0 ! " do ihitl=1,nsta do jhitl=1,8 stnazires(ihitl,jhitl)=0.0 enddo enddo c RETURN end ! of subr. resetstatis c subroutine RESISAVE(nrp,nrpdeep,rp,nobs,i,k1,mll) c c saves the residual according to the ray-type c implicit none integer nrp,nrpdeep,nobs,i,k1,mll include 'vel_com.f' c real xxx,yyy,xhyp,yhyp,xstn,ystn,azi,dist integer iazi real rp(3,inrpmax) c if(rp(3,nrpdeep).eq.rp(3,nrpdeep+1))then ! ray is horizontal : refracted ! avrefrres=avrefrres+ res(nobs,i) ! refracted abrefrres=abrefrres+ABS(res(nobs,i)) ! refracted nrrefrres=nrrefrres+1 c if(lmax.eq.10)then ! refractor is Moho... if(irfrout.eq.1)then c c write (x,y) of point A, where ray enters MOHO, c of point B, where ray leaves MOHO and of point between A and B c xxx=rp(1,nrpdeep) if(icoordsystem.eq.2) xxx=-xxx yyy=rp(2,nrpdeep) write(78,'(2x,''RFR'',3f10.3,'' .1'')') & xxx,yyy,res(nobs,i) xxx=(rp(1,nrpdeep)+rp(1,nrpdeep+1))/2. if(icoordsystem.eq.2) xxx=-xxx yyy=(rp(2,nrpdeep)+rp(2,nrpdeep+1))/2. write(78,'(2x,''RFR'',3f10.3,'' .1'')') & xxx,yyy,res(nobs,i) xxx=rp(1,nrpdeep+1) if(icoordsystem.eq.2) xxx=-xxx yyy=rp(2,nrpdeep+1) write(78,'(2x,''RFR'',3f10.3,'' .1'')') & xxx,yyy,res(nobs,i) endif endif c else if(mll.eq.0)then avotheres=avotheres+ res(nobs,i) ! straight or direct abotheres=abotheres+ABS(res(nobs,i)) ! straight or direct nrotheres=nrotheres+1 else avreflres=avreflres+ res(nobs,i) ! reflected abreflres=abreflres+ABS(res(nobs,i)) ! reflected nrreflres=nrreflres+1 c if(irflout.eq.1)then if(icoordsystem.eq.2)then xxx=-rp(1,nrpdeep) else xxx=rp(1,nrpdeep) endif write(77,'(2x,''RFL'',3f10.4,'' .1'')') & -rp(1,nrpdeep),rp(2,nrpdeep),res(nobs,i) endif endif endif c c save residual for station# k1 according to the azimuth: c xhyp=rp(1,1) yhyp=rp(2,1) xstn=rp(1,nrp) ystn=rp(2,nrp) c Azimuth (stn --> hypoc) = 57.296*ATAN2(xhyp-xstn,yhyp-ystn) azi=57.296*ATAN2(xhyp-xstn,yhyp-ystn) if(azi.lt.0) azi=azi+360. iazi=0 if(azi.ge. 0.0 .and. azi.lt. 90.0) iazi=1 if(azi.ge. 90.0 .and. azi.lt.180.0) iazi=2 if(azi.ge.180.0 .and. azi.lt.270.0) iazi=3 if(azi.ge.270.0 .and. azi.le.360.0) iazi=4 stnazires(k1,2*iazi-1)=stnazires(k1,2*iazi-1)+res(nobs,i) stnazires(k1,2*iazi)=stnazires(k1,2*iazi)+1. c c type residuals as a function of focus-receiver distance: if(iresout.eq.1)then dist=( (rp(1,1)-rp(1,nrp))**2 & +(rp(2,1)-rp(2,nrp))**2 & +(rp(3,1)-rp(3,nrp))**2 ) dist=sqrt(dist) write(79,'(1x,f6.2,2x,f7.3)') dist,res(nobs,i) endif c RETURN end ! of subr. resisave c subroutine ADJUSTMODEL(damp) c c adjust model-vector by the solution just obtained c implicit none real damp include 'vel_com.f' c integer jj,i,n,iminold,j,itime,j1,j2,k,k2,j11,j22 integer juliam integer kj,jjj,k1,ksta1,kk1,ksta2 real cc(ist) real dmin c c adjust hypocenters of this iteration and output them: c jj=0 c do 29 i=1,legs n=4 if(i.gt.neqs) n=1 ! for shots adjust only the origin-time !!! ccc call TIMECLEAR(iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i),iminold) if(iyr(i).lt.100)then iminold=JULIAM(iyr(i)+1900,imo(i),iday(i),ihr(i),imin(i)) else iminold=JULIAM(iyr(i),imo(i),iday(i),ihr(i),imin(i)) endif do j=1,n jj=jj+1 e(j,i)=e(j,i) + b(jj) enddo if(e(1,i).lt.0.0)then ! change reference minute call TIMECLEAR(iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i), & itime) do j=1,knobs(i) pt(j,i)=pt(j,i)+(iminold-itime)*60. enddo endif do j=1,3 isconstrain(j)=0 enddo iconstrain(i)=0 c c constrain focal depth if necessary c if(isingle.ne.0)then if(nitt.lt.2)then isconstrain(1)=1 c write(16,*)' *** nitt<2 --> ', c & 'depth-adjustment := 0.0 for event ',i e(4,i)=e(4,i)-b(4) b(4)=0.0 endif if(igap(1).gt.250)then dmin=999.9 ! minimum distance (epicenter --> receiver) do k=1,knobs(1) delta=SQRT( (e(2,1)-d(k,1,1))**2 & + (e(3,1)-d(k,2,1))**2 ) if(delta.lt.dmin) then dmin=delta endif enddo if (dmin.gt.15.) then isconstrain(2)=1 if(iconstrain(i).eq.1) iconstrain(i)=3 c write(16,*)' *** igap>250 --> ', c & 'depth-adjustment := 0.0 for event ',i e(4,i)=e(4,i)-b(4) b(4)=0.0 endif endif if(abs(b(4)).gt.zadj)then isconstrain(3)=1 c write(16,*)' *** depth-adjustment constrained for event ',i if(b(4).gt.0.0)then e(4,i)=e(4,i)-b(4)+zadj b(4)=zadj else e(4,i)=e(4,i)-b(4)-zadj b(4)=-zadj endif endif else ! simultanous inversion if(i.le.neqs.and.abs(b(jj)).gt.zadj)then ! b(jj)=depth-adj. if event i iconstrain(i)=1 c write(16,*)' *** depth-adjustment constrained for event ',i if(b(jj).gt.0.0)then e(4,i)=e(4,i)-b(jj)+zadj b(jj)=zadj else e(4,i)=e(4,i)-b(jj)-zadj b(jj)=-zadj endif endif endif c effdeltaz(i)=0.0 if(itopo.gt.0)then if(e(4,i).lt.0.0)then ! depth above sea-level...so near surface ! call CHTOP(-e(2,i),e(3,i),zmin, & topo1file,topo2file) ! zmin:==surface at this point else zmin=0.0 ! depth below zero ... so zmin:==0.0 is sufficiant ! endif endif if(e(4,i).lt.zmin.or.(ifixsolution.gt.0.and.e(4,i).le.0.0))then c effdeltaz(i)=b(jj)-(e(4,i)-zmin) c c instead of calculating effdeltaz constrain adjustment-vector-element c b(jj) directly: c b(jj)=b(jj)-(e(4,i)-zmin) c e(4,i)=zmin iconstrain(i)=1 c write(16,'('' ***** depth constrained for event '',i5)') i endif c 29 continue ! loop over all events (adjust) c c all new hypocenters adjusted now. c c c do velocity adjustments here: c if(scale(6).eq.0.0) goto 44 ! no velocity-adjustments... j1=4*neqs+nshot+1 j2=j1+nltot-1 k=0 if(.not.single_turbo)then write(16,*) write(16,40) 40 format(' doing velocity adjustments now...') endif c c do it for all velocity-models c do 4242 i=1,nmod k2=laysum(i) j11=j1+k2-1 j22=j11+nplay(i)-1 kj=1 c c do it for all layers in this model ( = i ) c do 42 jjj=j11,j22 vp(i,kj)=vp(i,kj)+b(jjj) ! <<---- VELOCITY-ADJUSTMENT c c If reflected phases are used, the velocity of the layer just above c the reflector is NOT allowed to have a lower velocity than any of c the above layers! c Because usually the reflector is almost at the bottom of the model, c namely the MOHO, we simplify the condition and don't allow any c low-velocity-layers at all in the whole model (of course o n l y c if reflected phases are used in this VELEST-run !) if(lowveloclay.eq.0)then if(kj.gt.1)then if(vp(i,kj).lt.vp(i,kj-1))then i f (.not.single_turbo)then write(16,'(1x,''WARNING: Tried to introduce a '', & ''low-velocity-layer! (Layer '',i2,'')'')') kj write(16,'(1x,''Setting DVP from '',f5.2,'' to 0.0 and'', & '' VP to vp(layer_above)+0.001'')') b(jjj) endif write(6,'(1x,''WARNING: Tried to introduce a '', & ''low-velocity-layer! (Layer '',i2,'')'')') kj write(6,'(1x,''Setting DVP from '',f5.2,'' to 0.0 and'', & '' VP to vp(layer_above)+0.001'')') b(jjj) write(6,*) b(jjj)=0.0 vp(i,kj)=vp(i,kj-1)+0.001 endif endif endif c kj=kj+1 42 continue c 4242 continue c c each velocity-model adjusted now. c c adjust p- & s- station-corrections here: c 44 if(scale(5).eq.0.0) goto 72 ! no station-correction adjustments... if(.not.single_turbo)then write(16,*) write(16,'('' doing station-correction adjustments...'')') write(16,*) endif k1=4*neqs+nshot+nltot+1 ksta1=ksta if(nsp.eq.2) ksta1=ksta/2 k2=k1+ksta1-1 c c do p-correction for all stations: c do j=1,nsta cc(j)=0. if(map1(j).eq.0) goto 49 if(map1(j).gt.ksta1) goto 49 kk1=k1-1+map1(j) cc(j)=b(kk1) ! STATION-CORRECTION- ptcor(j)=ptcor(j)+cc(j) ! ADJUSTMENT !!! (p-correction) 49 continue enddo if(nsp.ne.2) goto 72 k1=4*neqs+nshot+nltot+1+ksta1 ksta2=ksta-ksta1 k2=k1+ksta2-1 c c do s-correction for all stations: c do j=1,nsta cc(j)=0. if(map1(j).eq.0) goto 74 if(map1(j).gt.ksta2) goto 74 kk1=k1-1+map1(j) cc(j)=b(kk1) ! STATION-CORRECTION- stcor(j)=stcor(j)+cc(j) ! ADJUSTMENT !!! (s-correction) 74 continue enddo c 72 continue c RETURN c end ! of subr. adjustmodel c subroutine RMSDATVAR c c compute RMS and DATVAR for all the events (EQs & shots) c implicit none include 'vel_com.f' integer jj,i,j2,j,knobst real tres c c c now calculate rms for all events c jj=0 davar1=0.0 xmsqrs1=0.0 tres=0.0 knobst=0 do 11 i=1,legs j2=knobs(i) knobst=knobst+j2 do 12 j=1,j2 if(w(j,i).le.0.0) goto 12 avres(i)=avres(i)+res(j,i)*w(j,i) Cek changed by ek to res*w*res*w::::> rms(i)=rms(i)+ (res(j,i)*res(j,i))*w(j,i)*w(j,i) 12 continue davar1=davar1+rms(i) tres=tres+avres(i) cek next statement if( (j2-nobswithw0) .le.1) goto 11 rms(i)=sqrt( (rms(i)-avres(i)**2/(j2-nobswithw0) ) & /( (j2-nobswithw0) -1)) avres(i)=avres(i)/(j2-nobswithw0) 11 continue if(nitt.eq.0)then if(.not.single_turbo)then write(16,310) knobst endif endif 310 format(/,' Total number of observations is: ',i5,/) if(nitt.eq.0.and.isingle.ne.0)then if(.not.single_turbo)then write(16,*)'Number of observations with '// & 'normalized weight 0.0 :', nobswithw0 write(16,*)'knobs(i) = ',knobst write(16,*)'nobswithw0 = ',nobswithw0 endif endif c c calculate data variance: c c NVAReff is the actual number of unknowns to solve for !!! c if( (knobst-nobswithw0).gt.nvareff)then davar1=(davar1-tres*tres/(knobst-nobswithw0)) & / ((knobst-nobswithw0)-nvareff) xmsqrs1=davar1*((knobst-nobswithw0)-nvareff)/(knobst-nobswithw0) else davar1=999.99 xmsqrs1=999.99 endif c i f (.not.single_turbo) t h e n if(isingle.eq.0)then write(16,*) write(16,*)'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' write(16,*)'Events with | AVRES | > 1.0 SEC are suspicious !' write(16,*) j=0 do i=1,legs if(abs(avres(i)).gt.1.0)then write(16,'('' Event# '',i3,'' >>> '',1x,3i2.2,1x,2i2.2, & '' AVRES ='',f6.2,'' NOBS ='',i3)') & i,iyr(i),imo(i),iday(i),ihr(i),imin(i), & avres(i),knobs(i) j=j+1 endif enddo if(j.gt.0)then write(16,*) write(16,*)'^^^^^^^^^ C H E C K these events above ^^^^^^^^' write(16,*)'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$' else write(16,*)'ZERO events of this kind found! (lucky guy!!!)' endif write(16,*) endif e n d i f c return end ! of subr. rmsdatvar c subroutine AVRESISTATIST c c compute average residual statistics for the iteration just finished c implicit none integer ifirstrun integer nrtotres real abtotres,avtotres,proz,oldres c include 'vel_com.f' c save oldres, ifirstrun c write(16,*) if(nrotheres.gt.0) avotheres=avotheres/nrotheres if(nrotheres.gt.0) abotheres=abotheres/nrotheres c if(nrrefrres.gt.0) avrefrres=avrefrres/nrrefrres if(nrrefrres.gt.0) abrefrres=abrefrres/nrrefrres c if(nrreflres.gt.0) avreflres=avreflres/nrreflres if(nrreflres.gt.0) abreflres=abreflres/nrreflres c nrtotres=nrotheres+nrrefrres+nrreflres c if(nrtotres.gt.0)abtotres=(abotheres*nrotheres+ & abrefrres*nrrefrres+abreflres*nrreflres)/nrtotres c if(nrtotres.gt.0)avtotres=(avotheres*nrotheres+ & avrefrres*nrrefrres+avreflres*nrreflres)/nrtotres c write(16,'(1x,''After'',i3,'' iterations we got:'')') nitt write(16,*)'Average absolute & unweighted [and mean] residual of' write(16,'(1x,i5,'' straight and direct rays ='',f9.5,'' ['',f9.5, & '']'')')nrotheres,abotheres,avotheres write(16,'(1x,i5,'' refracted rays ='',f9.5,'' ['',f9.5, & '']'')')nrrefrres,abrefrres,avrefrres write(16,'(1x,i5,'' reflected rays ='',f9.5,'' ['',f9.5, & '']'')')nrreflres,abreflres,avreflres write(16,*) if(ifirstrun.ne.10000001)then ! first run; no 'oldres' available... ifirstrun=10000001 proz=0.0 else ! NOT the first time in this routine; proz may be calculated if(ABS(oldres).gt.1.0e-10)then proz=100.*(abtotres-oldres)/oldres endif endif write(16,'(1x,i5,'' ALL RAYS ='',f9.5,'' ['',f9.5, & '']'',5x,f7.2,'' %'')')nrtotres,abtotres,avtotres,proz oldres=abtotres write(16,*) c return end ! of subr. avresistatist c subroutine GAPCALC(i) c c determine GAP for one event c implicit none integer i include 'vel_com.f' integer nofgaps,j,ig real xstn,ystn,xhyp,yhyp,dxstnhyp,dystnhyp c integer iga(200) ! max. 200 obs. for a single event c c event: i knobs(i) +/-e(2,i)=x e(3,i)=y x=+/-x(nsta,1) y=...,2) c station# are stored in array ISTM(iobs,ievent) c c---- compute GAP for this event if(knobs(i).gt.200)then i f (.not.single_turbo)then write(16,*)' WARNING:' write(16,*)' Event# ',i,' Nobs = ',knobs(i),' > 200 !!!' write(16,*)' Array IGA(100) is too small; redimension it in' write(16,*)' subr. GAPCALC' e n d i f write(6,*)' Event# ',i,' Nobs = ',knobs(i),' > 200 !!!' write(6,*)' Array IGA(200) is too small; redimension it in' write(6,*)' subr. GAPCALC' stop'subr. GAPCALC >>> array IGA is too small !' endif nofgaps=0 do j=1,knobs(i) if(w(j,i).gt.0.0)then nofgaps=nofgaps+1 xstn=x(istm(j,i),1) ystn=x(istm(j,i),2) xhyp=e(2,i) yhyp=e(3,i) cek avoiding call to atan2(zero,zero) cek write(6,*) ' Gapcalc: i,nofgaps,xstn,ystn,xhyp,yhyp' cek write(6,'(1x,i4,2x,i3,2x,4f10.3)') i,nofgaps, cek + xstn,ystn,xhyp,yhyp dxstnhyp=abs(xstn-xhyp) dystnhyp=abs(ystn-yhyp) if(dxstnhyp.gt.0.0001.or.dystnhyp.gt.0.0001) then iga(nofgaps)=57.296*ATAN2(xstn-xhyp,ystn-yhyp) else iga(nofgaps)=359 endif cek if(iga(nofgaps).lt.0) iga(nofgaps)=iga(nofgaps)+360 endif enddo if(nofgaps.gt.0)then call SORTI(iga,nofgaps) else write(6,*)'WARNING: Event-# :',i,'has zero observations!' if(.not.single_turbo)then write(16,*)'WARNING: Event-# :',i,'has zero observations!' endif endif igap(i)=0 ig=iga(1)-iga(nofgaps) if(ig.lt.0) ig=ig+360 if(ig.gt.igap(i)) igap(i)=ig do j=2,nofgaps ig=iga(j)-iga(j-1) if(ig.lt.0) ig=ig+360 if(ig.gt.igap(i)) igap(i)=ig enddo c---- IGAP(i) is the gap of this event (nr. i) c return end ! of subr. gapcalc c subroutine BACKUP c c go back in direction of the previous solution by doing c only half of the adjustments calculated in the last iteration c implicit none include 'vel_com.f' integer jjj,i,n,k,iccc,k2,nl,j1,j2,ifl,k1,ksta1,j,kk1,m integer ksta2 real zzz,avelo c real cc(ist) character*1 reflch c jjj=0 do 2 i=1,legs c---------- hypocenter backup n=4 c if(i.gt.neqs) n=1 do 2 k=1,n jjj=jjj+1 b(jjj)=b(jjj)/2.0 if(k.eq.4)then ! backup depth c c concept of effdeltaz no longer in use! c c if(effdeltaz(i).eq.0.0)then e(k,i)=e(k,i)-b(jjj) ! depth not constrained c else c effdeltaz(i)=effdeltaz(i)/2.0 c e(k,i)=e(k,i)-effdeltaz(i) ! depth was constrained: c endif ! go back only half of the if(itopo.gt.0.and.e(k,i).lt.0.0)then c depth above zero... is it also above surface? call CHTOP(-e(2,i),e(3,i),zzz, & topo1file,topo2file) if(e(k,i).lt.zzz) e(k,i)=zzz ! set hypocenter down to surface ! if(ifixsolution.gt.0) e(k,i)=zzz ! fix depth to min_depth allowed!! endif else ! effective depth-change ! e(k,i)=e(k,i)-b(jjj) endif 2 continue ccc iccc=mod((nitt-1),invertratio) iccc=mod(nitt,invertratio) if(iccc.ne.0) goto 510 c---- velocity readjustments for each model do 26 k2=1,nmod nl=nplay(k2) j1=4*neqs+nshot+laysum(k2) j2=j1-1+nl k=0 if(.not.single_turbo)then write(16,3) 3 format(1x,'Velocity readjustments:') write(16,27) k2 27 format(1x,'Velocity model',i4) endif do 4 jjj=j1,j2 k=k+1 b(jjj)=b(jjj)/2. vp(k2,k)=vp(k2,k)-b(jjj) if(lowveloclay.eq.0)then if(k.gt.1)then if(vp(k2,k).lt.vp(k2,k-1))then i f (.not.single_turbo)then write(16,*)'WARNING:' write(16,'(1x,''WARNING: Tried to introduce a '', & ''low-velocity-layer! (Layer '',i2,'')'')') k write(16,'(1x,''Setting DVP from '',f5.2,'' to 0.0 and'', & '' VP to vp(layer_above)+0.001'')') b(jjj) e n d i f write(6,'(1x,''WARNING: Tried to introduce a '', & ''low-velocity-layer! (Layer '',i2,'')'')') k write(6,'(1x,''Setting DVP from '',f5.2,'' to 0.0 and'', & '' VP to vp(layer_above)+0.001'')') b(jjj) write(6,*) b(jjj)=0.0 vp(k2,k)=vp(k2,k-1)+0.001 endif endif endif 5 format(1x,3f7.3,3x,a1) if(k.eq.ireflector)reflch=reflchar if(k.ne.ireflector)reflch=' ' if(.not.single_turbo)then write(16,5) vp(k2,k),b(jjj),hp(k2,k),reflch endif 4 continue c c calculate and print average velocities of the model k2 : c i f (.not.single_turbo) t h e n ifl=1 write(16,*) write(16,*)'Calculation of average velocity starts at layer # ', & ifl avelo=0 do k=ifl+1,nplay(k2) avelo=avelo + ( hp(k2,k)-hp(k2,k-1) ) * vp(k2,k-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(k2,k-1),hp(k2,k),vp(k2,k-1),avelo/(hp(k2,k)-hp(k2,ifl)), & hp(k2,k) enddo write(16,*) c ifl=2 write(16,*) write(16,*)'Calculation of average velocity starts at layer # ', & ifl avelo=0 do k=ifl+1,nplay(k2) avelo=avelo + ( hp(k2,k)-hp(k2,k-1) ) * vp(k2,k-1) write(16,'('' z ='',f6.2,'' ...'',f6.2,'' v = '',f4.2, & '' AVEL = '',f4.2,'' downto z = '',f6.2)') & hp(k2,k-1),hp(k2,k),vp(k2,k-1),avelo/(hp(k2,k)-hp(k2,ifl)), & hp(k2,k) enddo write(16,*) write(16,*) e n d i f c 26 continue 510 if(nsinv.eq.0) goto 511 ccc if(mod((nitt-1),invertratio).ne.0) goto 511 if(mod(nitt,invertratio).ne.0) goto 511 k1=4*neqs+nshot+nltot+1 ksta1=ksta if(nsp.eq.2) ksta1=(ksta/2) k2=k1+ksta1-1 do 60 j=k1,k2 60 b(j)=b(j)/2. do 7 j=1,nsta cc(j)=0.0 if(map1(j).eq.0) goto 7 if(map1(j).gt.ksta1) goto 7 kk1=k1-1+map1(j) cc(j)=b(kk1) ptcor(j)=ptcor(j)-cc(j) 7 continue if(.not.single_turbo)then write(16,8) (stn(m),ptcor(m),cc(m),m=1,nsta) 8 format(5(2x,a4,2f7.3)) 6 format(1x,'P correction readjustments:') write(16,*) write(16,*)'Half adjustments made' endif if(nsp.ne.2) goto 29 k1=4*neqs+nshot+nltot+ksta1+1 ksta2=ksta-ksta1 k2=k1+ksta2-1 do 61 j=k1,k2 61 b(j)=b(j)/2. if(.not.single_turbo)then write(16,39) 39 format(1x,'S correction readjustments:') endif do 28 j=1,nsta cc(j)=0.0 if(map1(j).eq.0) goto 28 if(map1(j).gt.ksta2) goto 28 kk1=k1-1+map1(j) cc(j)=b(kk1) stcor(j)=stcor(j)-cc(j) 28 continue if(.not.single_turbo)then write(16,8) (stn(m),stcor(m),cc(m),m=1,nsta) endif 511 continue if(.not.single_turbo)then write(16,*) write(16,*)'Half adjustments made' endif 29 continue c return end ! of subr. backup c subroutine STEPLENGTHDAMP(damp) c c set step length damping to model-vector in case of LARGE VELOCITY CHANGE c ( | deltavelocity | > MAXveladjALLOWED ) c implicit none real damp include 'vel_com.f' integer i,j11,j22,jjj real btemp c damp=1.0 if(icount.eq.1) goto 900 if(scale(6).eq.0.0) goto 900 do i=1,nmod j11=4*neqs+nshot+laysum(i) j22=j11+nplay(i)-1 do 121 jjj=j11,j22 if(veladj.gt.abs(b(jjj))) goto 121 btemp=veladj/abs(b(jjj)) ! ABS[b(jjj)] > veladj --> damping enlarged if(btemp.lt.damp) damp=btemp ! eff. damping=smallest of all dampings 121 continue enddo c c apply step length damping just calculated to ALL unknowns !!! : c do jjj=1,nvar b(jjj)=b(jjj)*damp enddo 900 continue c return end ! of subr. steplengthdamp c subroutine STEPLENGTHCALC c c compute the step-length STEPLEN actually applied; c STEPLEN is the euclidean length of the model-vector c implicit none include 'vel_com.f' integer i c cu real csum(4,2) c steplen=0 cu bsum=0 cu k=0 cu do j=1,4 cu csum(j,1)=0.0 cu enddo do i=1,nvar cu k=k+1 cu if(i.le.4*neqs) csum(k,1)=csum(k,1)+b(i) ! CSUM is never used...!!??!! cu if(nitt.eq.1) csum(k,2)=csum(k,1) cu if(k.eq.4) k=0 cu if(i.gt.4*neqs+nshot) bsum=bsum+b(i) ! BSUM is never used... !!??!! steplen=steplen+b(i)*b(i) enddo steplen=sqrt(steplen) if(ibackups.gt.0) steplen=-steplen if(.not.single_turbo)then write(16,*) write(16,53) steplen 53 format (' (Applied) Step length = ', f7.3/) endif c return end ! of subr. steplengthcalc c subroutine RESOLCOVAR(davari) c c calculate resolution and covariance matrices. c implicit none real davari include 'vel_com.f' c integer mef,nef,n1,n2,n3,k,i,l,j real scale1,spread1,spread2,size,avresol real Rdiag(inva) c character*80 pcard c c---- resolution and covariance calculations if(.not.single_turbo)then write(16,'(/////)') write(16,40) 40 format(' Resolution and covariance calculations:') if(isingle.ne.0)then cc write(16,*)'CHOLESKY-decomposition:' write(16,*)' RESOLUTION-matrix ', & ' COVARIANCE-matrix' write(16,*) endif endif 25 mef=4*neqs+nshot-4 nef=4+nltot if(isingle.ne.0) NEF=4 ! only first 4 rows and first 4 standard-devs. n1=4*neqs n2=n1+nshot n3=n2+nltot if(iresolcalc.eq.2.and.isingle.eq.1) &write(80,*)'Covariance matrice' do 15 k=1,nef do 16 i=1,nvar 16 rht(i)=gcopy(k,i) l=k if(k.gt.4) l=k+mef call LUELMP(g,rht,nvar,rht) if(isingle.eq.0)then if(.not.single_turbo)then write(16,17) l 17 format(1x,'resolution row',i3) write(16,18) (rht(j),j=1,nvar) endif Rdiag(k)=rht(l) else write(pcard,18) (rht(j),j=1,nvar) do j=1,4 Rc(l,j)=rht(j) ! resolution-matrix enddo endif 18 format(8f10.4) call LUELMP(g,rht,nvar,rht) c---- put covariance into proper unit j=mod(l,4) if(j.eq.0) j=4 scale1=scale(j) if(l.gt.n1) scale1=scale(1) if(l.gt.n2) scale1=scale(6) if(l.gt.n3) scale1=scale(5) do 19 j=1,nvar ccc 19 rht(j)=rht(j)*davari*scale1 19 rht(j)=rht(j)*scale1 ! <== UNIT covariance matrix !!! call FIXUNT(rht,neqs,nshot,nltot,ksta,scale, & vdamp,itotmodels,inltot,nplay(1)) if(isingle.eq.0)then if(.not.single_turbo)then write(16,20) l 20 format(1x,'covariance row',i3) write(16,18) (rht(j),j=1,nvar) endif else write(pcard(41:80),18) (rht(j),j=1,nvar) if(.not.single_turbo) write(16,*) pcard do j=1,4 COVc(l,j)=rht(j) enddo endif c s(k)=sqrt(abs(rht(l))) ! compiler produces warning with range checking s(k)=abs(rht(l)) s(k)=sqrt(s(k)) 15 continue c if(isingle.ne.0)then if(.not.single_turbo) write(16,*) call SPREADd(Rc,4,spread1) spread=spread1 if(ifixsolution.eq.1)then do j=1,3 do k=1,3 R3(j,k)=Rc(j,k) enddo enddo call SPREADd(R3,3,spread) endif if(ifixsolution.eq.9)then call SPREADd(Rc(1,1),1,spread) endif call SPREADb(Rc,4,spread2) size=0.0 do j=1,4 size=size+COVc(j,j) enddo if(.not.single_turbo)then write(16,'(1x,''D-Spread(R) = '',f6.3, & '' B-G Spread(R) = '',f6.3, & '' Size (C) = '',f6.3 & )') spread,spread2, size endif endif c if(.not.single_turbo)then write(16,*) write(16,21) 21 format(' standard deviation of selected model parameters:') endif if(isingle.ne.0)then avresol=0.0 do j=1,nef avresol=avresol+Rc(j,j) enddo avresol=avresol/float(nef) i f (.not.single_turbo) t h e n write(16,*) write(16,*)' OT (sec) X (km) Y (km) Z (km) ' e n d i f write(6,'(23x,'' OT (sec) X (km) Y (km) Z (km) '')') c write(6,'(1x,''CHOLESKY (othet='',f5.3,'') :'')') othet write(6,'('' Sigma (CHD): '',4f10.4)') (s(j),j=1,nef) write(6,'('' Resolution (CHD): '',4f10.4,x, & ''D-spread ='',f6.3)') (Rc(j,j),j=1,nef) , spread write(6,'('' Data Variance = '',f10.4)') davari ccc call SPREADd(Rs,4,spread3) ccc do j=1,4 ccc COVs(j)=SQRT(COVs(j)) ! <-- standard deviation ccc enddo write(6,'('' Singular values: '',4f10.4,5x,''ALE ='',f7.3)') & (SV(j),j=1,nef) , ale(1) ccc write(6,'('' Sigma (SVD): '',4f10.4)') (COVs(j),j=1,nef) ccc write(6,'('' Resolution (SVD): '',4f10.4,3x, ccc & ''D-spread ='',f6.3)') (Rs(j,j),j=1,nef) , spread3 endif if(.not.single_turbo) write(16,22) (s(j),j=1,nef) 22 format(8f10.4) if(.not.single_turbo)then write(16,*) write(16,*)'Rdiag of selected model parameters:' write(16,22) (Rdiag(j),j=1,nef) write(16,*) write(16,*) endif c return end ! of subr. resolcovar c subroutine TRAVDERIV(raytype,nl,mll,v1,vsq1, & rp,nrp,x2,y2,z2,ss,r1,r2,ievent,inobs) c c compute traveltime derivatives with respect to all the unknowns inverted c for ! c implicit none include 'vel_com.f' c character*(*) raytype integer nl,mll,nrp,ievent,inobs,ii,j,jx,jndex,l,jb integer idownward,i real rp(3,inrpmax), f(inltot),zmax,r1,r2,dtdd real v1(nl),vsq1(nl),x2(nrp),y2(nrp),z2(nrp),ss(nrp) c if(isingle.ne.0.and.iturbo.eq.1)then continue else do 2 ii=1,nl 2 dtdv(ii)=0. endif do 3 ii=1,3 3 dtdr(ii)=0. c if(ifixsolution.eq.9) RETURN ! hold LAT/LON/DEPTH fixed !!! c c No trvdrv's for reseted obs: c if(isingle.ne.0.and.w(inobs,ievent).eq.0.0) RETURN c if(raytype.eq.'direct') goto 5 if(raytype.eq.'refracted') goto 6 if(raytype.eq.'reflected') goto 8 stop'TRAVDERIV>>> illegal raytype!!!' c c direct ray c 5 continue do 9 j=1,nrp-1 jx=nrp-j x2(j)=rp(1,j+1)-rp(1,j) y2(j)=rp(2,j+1)-rp(2,j) z2(j)=rp(3,j+1)-rp(3,j) ss(j)=sqrt(x2(j)**2 + y2(j)**2 + z2(j)**2) if(isingle.ne.0.and.iturbo.eq.1)then continue else dtdv(jx)= -ss(j)/vsq1(jx) endif 9 continue dtdr(1)=-x2(1)/(v(jl)*ss(1)) dtdr(2)=-y2(1)/(v(jl)*ss(1)) dtdr(3)=-z2(1)/(v(jl)*ss(1)) goto 40 c c refracted first path c 6 continue do 171 j=1,nrp z2(j)=rp(3,j) 171 continue call MAXRI(nrp,z2,zmax,jndex) ! determine MAX (=zmax) of z2 (vertical c path-lengths in each layer) l=nl 12 if(h(l).le.(zmax+.01)) goto 11 l=l-1 goto 12 11 continue jb=l c dtdd=1/v(jb) dtdr(1)=(r1/delta)*dtdd dtdr(2)=(r2/delta)*dtdd dtdr(3)=-sqrt(vsq(jb)-vsq(jl))/(v(jb)*v(jl)) c if(isingle.ne.0.and.iturbo.eq.1) goto 40 ! do not calc. dt/dv !!! c c thk(j) -- thickness of layer j c jl -- event layer c jb -- bottomming layer c tkj -- depth of event within event layer c do 201 j=1,nl f(j)=1. if(j.ge.jl) f(j)=2. 201 if(j.gt.jb) f(j)=0. do 202 j=1,jb-1 dtdv(jb)=dtdv(jb)+ thk(j)*v1(j)*f(j)/(vsq1(jb)* &sqrt(vsq1(jb)-vsq1(j))) dtdv(j)=-thk(j)*v1(jb)*f(j)/(vsq1(j)* &sqrt(vsq1(jb)-vsq1(j))) 202 continue dtdv(jl)=dtdv(jl)+tkj*v1(jb)/(vsq1(jl)* &sqrt(vsq1(jb)-vsq1(jl))) dtdv(jb)=dtdv(jb)-tkj*v1(jl)/(vsq1(jb)* &sqrt(vsq1(jb)-vsq1(jl))) -delta/vsq1(jb) c goto 40 c c reflected phase c 8 continue c avoid hypocenter on layer-boundary: chrm if(rp(1,1).eq.rp(1,2).and. chrm & rp(2,1).eq.rp(2,2).and. chrm & rp(3,1).eq.rp(3,2))then chrm rp(3,1)=rp(3,1)-0.0001 ! move hypocenter 10 cm up chrm endif c ctest dtdr(1)=DTDDrefl*(r1/delta) ! valid for REFLECT ctest dtdr(2)=DTDDrefl*(r2/delta) ctest dtdr(3)=DTDHrefl c jx=0 do j=1,nrp-1 x2(j)=rp(1,j+1)-rp(1,j) y2(j)=rp(2,j+1)-rp(2,j) z2(j)=rp(3,j+1)-rp(3,j) ss(j)=sqrt(x2(j)**2 + y2(j)**2 + z2(j)**2) if(j.eq.1)then dtdr(1)=-x2(1)/(v(jl)*ss(1)) ! valid for REFLECT1 dtdr(2)=-y2(1)/(v(jl)*ss(1)) dtdr(3)=-z2(1)/(v(jl)*ss(1)) endif if(isingle.ne.0.and.iturbo.eq.1) goto 40 ! do not calc. dt/dv !!! idownward=0 if(z2(j).gt.0.0) idownward=1 if(j.eq.(nrp-1).and.idownward.eq.1) idownward=0 if(idownward.eq.1)then ! DOWNwards jx=jl+j-1 c if(vsq1(jx).le.0)then c write(6,*)'jx=',jx,'jl=',jl,'tkj=',tkj c write(6,*)'j=',j,'vsq1(jx)=',vsq1(jx),'nrp=',nrp c endif dtdv(jx)=-ss(j)/vsq1(jx) else ! UPward if(jx.eq.mll)then dtdv(mll)=dtdv(mll)-ss(j)/vsq1(mll) jx=jx-1 else dtdv(jx)=dtdv(jx)-ss(j)/vsq1(jx) jx=jx-1 endif endif enddo if(jx.ne.0)stop'TRAVDERIV>>> did not reach the top...!' goto 40 c c 40 continue c if(ifixsolution.eq.1) dtdr(3)=0.0 ! hold depth fixed !!! c cek test if nrp gt. inrpmax:::> if(nrp.gt.inrpmax) then if(.not.single_turbo)then write(16,2000) i,inobs,nrp 2000 format(//,2x,'travderiv>>>, label 2000: ', & 'nrp greater than inrpmax:',/, & 5x,'event nr=',i6,2x,'nr. of obs=',i4,5x,4hnrp=,i4,/, & 3x,'program stops here',/) endif stop'subr. TRAVDERIV >>> nrp > nrpmax' endif c return end ! of subr. travderiv c subroutine REJECTOBS(i,nobs,iresflag) c c reject the current observation for further calculation in case the c reading (or the seismologist who read it...) seems to be nuts: c implicit none integer i,nobs,iresflag include 'vel_com.f' c real wsum,xkndw integer knobst,iii,iobswt if(w(nobs,i).eq.0.0) RETURN if( (knobs(i)-nobswithw0) .eq. nvar ) RETURN c cc w(nobs,i)=0.0039 ! = 1./(2**(2*reading_weight)) = 1./256 c c re-normalize weights of this event : c nobswithw0=nobswithw0+1 wsum=0.0 knobst=knobs(i) do iii=1,knobst iobswt=kpwt(iii,i) if(iobswt.lt.4.and.w(iii,i).ne.0.0)then if(sphase(iii,i).eq.1.0.or.sphase(iii,i).eq.2.0)then w(iii,i)=swtfac*1.0/(2**(iobswt*2)) ! S-phase or s-p phase else w(iii,i)= 1.0/(2**(iobswt*2)) ! P- or M-phase endif else w(iii,i)=0.0 ! observation-weight 4 ==> don't use this arrival endif if(iii.eq.nobs) w(iii,i)=0.0 wsum=wsum+w(iii,i) enddo xkndw=float(knobst-nobswithw0)/wsum do iii=1,knobst w(iii,i)=w(iii,i)*xkndw enddo if(.not.single_turbo)then write(16,*)'WARNING:' write(16,'('' Iteration# '',i3,'' Event#'',i4,'' Res#'',i3, & '' ='',f7.2,''; ABS > 2.0 ---> weight set to zero !'')') & nitt,isingle,nobs,res(nobs,i) endif write(6,'('' Iteration# '',i3,'' Event#'',i4,'' Res#'',i3, & '' ='',f7.2,''; ABS > 2.0 ---> weight set to zero !'')') & nitt,isingle,nobs,res(nobs,i) if(.not.single_turbo)then write(16,*)'knobs(i) = ',knobst write(16,*)'nobswithw0 = ',nobswithw0 endif cc write(6,*)'knobs(i) = ',knobst cc write(6,*)'nobswithw0 = ',nobswithw0 cc write(6,*) iresflag=1 ! inhibit a pre-stopping in subr. OUTPUT due to ! increased datvar; give location a second chance. c return end ! of subr. rejectobs c subroutine REVIVEOBS(i,nobs,iresflag) c c If observationweight < 4 and weight=0.0 then set 'original' weight c if residual has become smaller since it has been reseted: c implicit none integer i,nobs,iresflag include 'vel_com.f' c real wsum,xkndw integer knobst,iii,iobswt if(w(nobs,i).ne.0.0) RETURN if(kpwt(nobs,i).eq.4) RETURN c cc w(nobs,i)=0.0039 ! = 1./(2**(2*reading_weight)) = 1./256 c c re-normalize weights of this event : c nobswithw0=nobswithw0-1 wsum=0.0 knobst=knobs(i) do iii=1,knobst iobswt=kpwt(iii,i) if(iii.ne.nobs.and.w(iii,i).eq.0.0)then w(iii,i)=0.0 ! keep zero-weights as they are !!! else if(iobswt.lt.4)then if(sphase(iii,i).eq.1.0.or.sphase(iii,i).eq.2.0)then w(iii,i)=swtfac*1.0/(2**(iobswt*2)) ! S-phase else w(iii,i)= 1.0/(2**(iobswt*2)) ! P- or M-phase endif else w(iii,i)=0.0 ! observation-weight 4 ==> don't use this arrival endif endif wsum=wsum+w(iii,i) enddo xkndw=float(knobst-nobswithw0)/wsum do iii=1,knobst w(iii,i)=w(iii,i)*xkndw enddo if(.not.single_turbo)then write(16,*)'WARNING:' write(16,'('' Iteration# '',i3,'' Event#'',i4,'' Res#'',i3, & '' ='',f7.2,''; ABS < 1.0 ---> weight revived !'')') & nitt,isingle,nobs,res(nobs,i) endif write(6,'('' Iteration# '',i3,'' Event#'',i4,'' Res#'',i3, & '' ='',f7.2,''; ABS < 1.0 ---> weight revived !'')') & nitt,isingle,nobs,res(nobs,i) if(.not.single_turbo)then write(16,*)'knobs(i) = ',knobst write(16,*)'nobswithw0 = ',nobswithw0 endif cc write(6,*)'knobs(i) = ',knobst cc write(6,*)'nobswithw0 = ',nobswithw0 cc write(6,*) iresflag=1 ! inhibit a pre-stopping in subr. OUTPUT due to ! increased datvar; give location a second chance. c return end ! of subr. reviveobs c subroutine DETNOFUNKNOWNS c implicit none include 'vel_com.f' integer lipeff c c determine the number of unknowns NVAR and c calculate the number of equations LIP to be solved : c if(icount.ne.0)then lip=4*neqs + nshot +1 ! do NOT invert for velocity parameters lipeff=lip else lip=4*neqs + nshot + nltot + ksta +1 ! invert for velocity parameters lipeff=4*neqs + nshot + nltot + nstaeff +1 ! invert for vel. parameters if(nsinv.eq.0) lip=4*neqs + nshot + nltot + 1 !do NOT inv. for sta-corr endif c NVAR is the number of unknowns to solve for : nvar=lip-1 c NVAREFF is the REAL number of unknowns to solve for!!! nvareff=lipeff-1 c KVAR is the number of elements on or above the main diagonal of G=(At(A)) kvar=nvar*lip/2 ! cuk !BELOW!! cuk c c if(.not.single_turbo)then write(16,*) write(16,'('' Number of unknowns (for array-indexing): '', & '' nvar = '',i4)') nvar write(16,'('' Number of effective unknowns : '', & '' nvareff = '',i4)') nvareff write(16,'('' Number of elements on/below main diagonal '', & ''of matrix G = At*A : kvar = '',i7)') kvar write(16,*) endif c return end ! of subr. detnofunknowns c subroutine ACTUALSTATIONS c cek added separate report of P and S phases 20.8.98 c implicit none include 'vel_com.f' integer i,nofreadings,k,nobsp(ist),nobss(ist),nofreadp,nofreads c do i=1,nsta nactualsta(i)=0 nobsp(i)=0 nobss(i)=0 enddo nstaeff=0 nofreadings=0 do i=1,legs ! = neqs+nshot do k=1,knobs(i) nactualsta( istm(k,i) ) = nactualsta( istm(k,i) ) + 1 if(nsp.eq.2) then if(sphase(k,i).eq.0.0) nobsp(istm(k,i))=nobsp(istm(k,i))+1 if(sphase(k,i).eq.1.0) nobss(istm(k,i))=nobss(istm(k,i))+1 endif nofreadings=nofreadings+1 enddo enddo if(.not.single_turbo) write(16,*) do i=1,nsta if(nactualsta(i).gt.0)then if(.not.single_turbo)then if(nsp.eq.2) then write(16,'('' readings for station '',a4,'' : tot='', & i4,'' P:'',i4,'' S:'',i4)') & stn(i),nactualsta(i),nobsp(i),nobss(i) else write(16,'('' readings for station '',a4,'' :'',i4)') & stn(i),nactualsta(i) endif endif nstaeff=nstaeff+1 endif nofreadp=nofreadp+nobsp(i) nofreads=nofreads+nobss(i) enddo if(.not.single_turbo)then write(16,*) write(16,'('' Total number of stations with readings:'',i4)') & nstaeff write(16,*) write(16,'('' Total number of readings: '',i7)') nofreadings write(16,'('' Total number of P readings: '',i7)') nofreadp write(16,'('' Total number of S readings: '',i7)') nofreads write(16,*) endif c RETURN end ! of subr. actualstations c c subroutine FINALSTARESI c c computes final station residuals for all stations used in this run. c implicit none include 'vel_com.f' c integer i,j,m,k,iz,iwarn real stcor1 real del(ist) chrm real phz(3) character*1 phz(3) real aa(ist),bb(ist),dd(ist),ee(ist) integer icc(ist), iccs(ist) real aas(ist),bbs(ist),dds(ist),ees(ist) character*1 cns,cew character cline*80, sta*4 character*1 phzz(ist) data phz(1),phz(2),phz(3)/'S','P','m'/ c if(isingle.eq.0)then if(iturbo.eq.0)then write(16,*) write(16,*) write(16,*) write(16,*) else write(16,*)'TURBO-option is set; residuals are NOT printed ' & //'for each event!' endif endif write(16,*) if(isingle.eq.0)then if(iturbo.eq.0)then write(16,1) 1 format(1h1) else goto 8001 ! do NOT output residuals for each event if TURBO set. endif endif c c output residuals for each event seperately: c do 2 i=1,legs write(16,*) if(imin(i).lt.0)then ! U.K. 3.Feb.87 imin(i)=imin(i)+60 ihr(i)=ihr(i)-1 endif if(isingle.eq.0)then write(16,'(1x,''Station residuals for event='',i4, & 3x,3i2.2,1x,2i2.2,1x,f5.2)') & i,iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i) else write(16,'(1x,''Station residuals for event='',i4, & 3x,3i2.2,1x,2i2.2,1x,f5.2)') & isingle,iyr(i),imo(i),iday(i),ihr(i),imin(i),e(1,i) endif c no more active c3 format(1h ,'Station residuals for event=',i4, c & 3x,3i2.2,1x,2i2.2,1x,f5.2) write(16,51) 51 format(1x,2('sta ph wt res ttime delta',5x)) do 52 j=1,knobs(i) del(j)=sqrt((e(2,i)-d(j,1,i))**2 + (e(3,i)-d(j,2,i))**2) phzz(j)='p' if(sphase(j,i).eq.1.0) phzz(j)='s' if(sphase(j,i).eq.-1.0) phzz(j)='m' 52 continue write(16,53) (smn(j,i),phzz(j),kpwt(j,i),res(j,i),tctime(j,i), & del(j),j=1,knobs(i)) 53 format(2(1x,a4,1x,a1,1x,i2,f7.3,2f6.2,4x)) 2 continue write(16,*) if(isingle.ne.0) goto 8001 write(16,*) write(16,*) write(16,*) write(16,*) write(16,*) write(16,*) 8001 continue c c output station statistics (nobs, avres, ...) : c if(isingle.eq.0) then write(16,7777) nsp 7 format(/,1x,'sta phase nobs avres avwres std wsum ', & 'delay',/) write(16,7) 7777 format(//,2x,' station statistics, remember nsp was set to:',i2,/) endif 48 do m=1,nsta aa(m)=0.0 bb(m)=0.0 icc(m)=0 dd(m)=0.0 ee(m)=0.0 aas(m)=0.0 bbs(m)=0.0 iccs(m)=0 dds(m)=0.0 ees(m)=0.0 enddo c loop 9: collect residual data from all events do 9 m=1,nsta sta=stn(m) do 10 i=1,legs k=knobs(i) do 11 j=1,k if(sta.eq.smn(j,i).and.sphase(j,i).eq.0.) goto 12 ! P if(sta.eq.smn(j,i).and.sphase(j,i).eq.-1.0) goto 12 ! refl. P 11 continue goto 110 12 continue aa(m)=aa(m)+res(j,i)*w(j,i) cek res: *w(j,i) bb(m)=bb(m)+res(j,i)*res(j,i)*w(j,i)*w(j,i) ee(m)=ee(m)+res(j,i) dd(m)=dd(m)+w(j,i) icc(m)=icc(m)+1 110 continue if(nsp.eq.1) goto 10 c chrm Doing S and S-P phases c do 101 j=1,k if(sta.eq.smn(j,i).and.sphase(j,i).eq.1.) goto 102 ! s-phase if(sta.eq.smn(j,i).and.sphase(j,i).eq.2.) goto 102 ! s-p phase 101 continue goto 10 102 continue aas(m)=aas(m)+res(j,i)*w(j,i) c res: *w(j,i) bbs(m)=bbs(m)+res(j,i)*res(j,i)*w(j,i)*w(j,i) ees(m)=ees(m)+res(j,i) dds(m)=dds(m)+w(j,i) iccs(m)=iccs(m)+1 10 continue 9 continue c end loop 9 c c Station file output: c if(istaout.gt.0)then open(12,file=stafile,status='unknown') write(12,1201) fm 1201 format(a80) endif c c begin loop 13: print output do 13 m=1,nsta c c write on file 12 if(istaout.gt.0)then iz=ielev(m) if(xla(m).lt.0.0)then cns='S' xla(m)=-xla(m) else cns='N' endif if(xlo(m).lt.0.0)then cew='E' xlo(m)=-xlo(m) else cew='W' endif write(cline,fm) stn(m),xla(m),cns,xlo(m),cew, & iz,model(m),map1(m), & ptcor(m),stcor(m) if(cns.eq.'S') xla(m)=-xla(m) if(cew.eq.'E') xlo(m)=-xlo(m) if(m.eq.1)then cline(47:)=' lon,z,model,icc,ptcor,stcor' endif write(12,'(a)') cline endif c end writing on file 12 c if(dd(m).eq.0.or.icc(m).lt.2) goto 1013 bb(m)=(bb(m)-aa(m)**2/dd(m))*icc(m)/(dd(m)*(icc(m)-1)) iwarn=0 if(bb(m).lt.-0.1)then iwarn=1 write(16,'(5x,''WARNING: Station = '',a4, & 5x,''!!! Variance bb('',i3,'') = '',f7.3,'' < 0 !!'')') & stn(m),m,bb(m) cek write(6,'(5x,''WARNING: Station = '',a4, cek & 5x,''!!! Variance bb('',i3,'') = '',f7.3,'' < 0 !!'')') cek & stn(m),m,bb(m) cek write(6,*) bb(m)=0.0 else bb(m)=abs(bb(m)) endif if(iwarn.eq.0) then bb(m)=sqrt(bb(m)) else endif aa(m)=aa(m)/dd(m) ee(m)=ee(m)/icc(m) c cek phz(2)= P-phases c cek if(iwarn.eq.0)then write(16,'(1x,a4,3x,a1,i4,3f8.4,1x,2f8.4)') & stn(m),phz(2),icc(m),ee(m),aa(m),bb(m),dd(m),ptcor(m) cek else cek write(16,'(1x,a4,3x,a1,i4,2f8.4,'' ?.?.?''1x,2f8.4, cek & '' <--- !!'')') cek & stn(m),phz(2),icc(m),ee(m),aa(m),dd(m),ptcor(m) cek iwarn=0 cek endif 1013 if(nsp.eq.1) goto 39 cek write(16,'(1x,a4,3x,a1,i4,25x,f8.4)') cek & stn(m),phz(1),iccs(m),dds(m) c print output for S-wave data (nsp=2 or 3): if(dds(m).eq.0.or.iccs(m).lt.2) goto 13 bbs(m)=(bbs(m)-aas(m)**2/dds(m))*iccs(m)/(dds(m)*(iccs(m)-1)) iwarn=0 if(bbs(m).lt.-0.1)then iwarn=1 write(16,'(5x,''WARNING: Station = '',a4, & 5x,''!!! Variance bbs('',i3,'') = '',f7.3,'' < 0 !!'')') & stn(m),m,bbs(m) cek write(6,'(5x,''WARNING: Station = '',a4, cek & 5x,''!!! Variance bb('',i3,'') = '',f7.3,'' < 0 !!'')') cek & stn(m),m,bb(m) cek write(6,*) else bbs(m)=abs(bbs(m)) endif if(iwarn.eq.0) then bbs(m)=sqrt(bbs(m)) else bbs(m)=0.0 endif aas(m)=aas(m)/dds(m) ees(m)=ees(m)/iccs(m) c c (nsp=3): if(nsp.eq.3) then stcor1=ptcor(m)*vpvs c (nsp=2): else stcor1=stcor(m) endif c cek phz(1)= S-phases c cek if(iwarn.eq.0)then write(16,'(1x,a4,3x,a1,i4,3f8.4,1x,2f8.4)') & stn(m),phz(1),iccs(m),ees(m),aas(m),bbs(m),dds(m), & stcor1 cek else cek write(16,'(1x,a4,3x,a1,i4,2f8.4,'' ?.?.?''1x,2f8.4, cek & '' <--- !!'')') cek & stn(m),phz(1),iccs(m),ees(m),aas(m),dds(m),stcor1 cek iwarn=0 cek endif c 14 format(1x,a4,3x,a1,i4,3f8.4,1x,2f8.4) 39 continue 13 continue c c end loop print one station c write(16,*) write(16,*) if(istaout.gt.0)then write(12,*) close(12) endif c chrm Output of the final model c if(istaout.eq.2)then open(12,file='velout.mod',status='unknown') write(12,*)'Output model:' c write(12,*)(nplay(m),m=1,nmod) do m=1,nmod write(12,*)nplay(m) do i=1,nplay(m) write(12,'(f5.2,5x,f7.2,2x,f7.3,4x)') & vp(m,i),hp(m,i),vdamp(m,i) enddo enddo close(12) endif return end ! of subr. finalstaresi c cek end of vel_kern.f c cek begin of vel_mag.f c SUBROUTINE MAGNITUDE(ievent,itime) ! Urs Kradolfer, July 1987 c c calculate magnitude for an event with depth Z and NRP observations c implicit none integer ievent,itime include 'vel_com.f' c integer iseis,iscon,isdmp,isamp,ier,i real cormag,sconst,sdampf,voltgain,xmag character*2 ifilt character staname*4 c nmag=0 xmagnitude=0. sdxmagnitude=0. do i=1,knobs(ievent) if(kpwt(i,ievent).gt.4) goto 40 ! weights > 4 are no readings!!! c station# are stored in array ISTM(iobs,ievent) c smn(iobs,iev) is the station-name write(staname,'(a4)') smn(i,ievent) call STINP(itime,staname,ifilt,iseis,iscon, & isdmp,isamp,cormag,ier) if(ier.lt.0) goto 40 ! seismo-parameters of station not found if(iyr(ievent).ge.1984.and.ifilt.eq.'DE') ifilt='AD' sconst=float(iscon)/10. sdampf= float(isdmp)/10. voltgain=float(isamp) delta=SQRT( (e(2,ievent)-d(i,1,ievent))**2 & + (e(3,ievent)-d(i,2,ievent))**2 ) xmag=0. call MUK(delta,e(4,ievent),ifilt,iseis,sconst,sdampf, & voltgain,cormag,amx(i),prx(i),xmagni(i)) if(xmagni(i).eq.-13.) goto 40 nmag=nmag+1 xmag=xmagni(i) xmagnitude=xmagnitude+xmag sdxmagnitude=sdxmagnitude+xmag**2 40 continue enddo if(nmag.ne.0)then if(nmag.ge.2)then sdxmagnitude= & SQRT( (nmag*sdxmagnitude-xmagnitude*xmagnitude) & / (nmag*(nmag-1)) ) else sdxmagnitude=0. endif xmagnitude=xmagnitude/nmag else xmagnitude=0.0 endif c return ! calculated magnitude is: AVXM +/- SDXM and all xmagni(1...nobs) c END ! of subr. magnitude c subroutine MUK(epdist,depth,ifilter,isecpendel,seismkonst, & seismdamp,voltgain,stacor,devampl,period,xmag) c c------------------------------- Urs Kradolfer 1984 ------------------- C C Berechnet die Magnitude Ml fuer Epizentraldistanz <= 700 km C Berechnet die Magnitude Mb fuer Epizentraldistanz > 2200 km c c Input: c Epizentraldistanz [km] epdist >=0. {real} c " [deg] epdist < 0. {real} c Herdtiefe [km] depth {real} c filter-typ (z.b. DE, AD, PD) filter-typ {char} c Seismometer-Grenzperiode [sec] isecpendel {integer} c " -Konstante [V/(cm/s)] seismkonst {real} c " -Daempfung [1] seismdamp {real} c Verstaerkung (Elektronik) [1] voltgain {real} c Stationskorrektur [Mag] stacor {real} c Max. Ablese-Amplitude [mm] devampl {real} c (Devco oder Plot) c dominierende Periode [sec] period {real} c c Output: Magnitude (Ml oder Mb) [Mag] xmag {real} c c >> Falls die Magnitude nicht berechnet werden kann, erfolgt c >> ein RETURN und der Output-Parameter xmag wird -13. gesetzt! c c Zur Subr. muk gehoert ebenfalls die Subr. UFWABO und die c zur letzteren gehoerenden vier Complex-Functions. c--------------------------------------------------------------------------- c implicit none real epdist,depth,seismkonst,seismdamp,voltgain real stacor,devampl,period,xmag integer isecpendel c real epdistkm,ampl,waampl,boampl,delta,sigma,a,b integer iampltype,i character*2 ifilter real RDELT(12), SIGAR(12) DATA RDELT/4.0,6.,13.,16.,28.,87., & 114.,120.,134.,141.,146.,180./, & SIGAR/6.2,7.,7.0,5.8,6.6,7.0,7.5, & 7.5, 6.9, 7.1, 6.9, 6.9 / if(isecpendel.le.0.or.seismkonst.le.0..or.seismdamp.le.0..or. & voltgain.le.0..or.devampl.le.0..or.period.le.0.)then xmag=-13. ! Magnitude kann nicht berechnet werden return endif xmag=-13. ! falls xmag nicht anders berechnet wird !! if(epdist.lt.0.)then epdistkm= -epdist/360.*40030 ! epdist < 0. --> [epdist] = Grad else epdistkm=sqrt(epdist**2+depth**2) endif if(epdistkm.le.2200.)iampltype=1 ! Wood-Anderson --> Ml if(epdistkm.gt.2200.)iampltype=2 ! Bodenbewegung --> Mb if(ifilter.eq.'DE'.or.ifilter.eq.'AD') &call ufwabo(isecpendel,seismkonst,seismdamp,voltgain, & devampl,period,iampltype,ampl,ifilter) if(ifilter.eq.'PD') &call mpdr2(isecpendel,seismkonst,seismdamp,voltgain, & devampl,period,iampltype,ampl) if(ampl.le.1.0e-10)then xmag=-13. ! avoid taking LOG of non-positive value !!! RETURN endif if(iampltype.eq.1)waampl=ampl/2. ! p-p-Ampl. --> 0-p-Ampl. if(iampltype.eq.2)boampl=ampl if(epdistkm.gt.2200.)then delta=epdistkm/40030.*360. ! delta:=epdistkm in Grad if(delta.gt.180.)then delta=180. sigma=sigar(12) goto 2 endif i=0 1 i=i+1 if(delta.gt.rdelt(i))goto 1 ! jetzt ist delta < rdelt(i) --> Linearisieren ! y=a*x+b a=(sigar(i)-sigar(i-1))/(rdelt(i)-rdelt(i-1)) b=sigar(i)-a*rdelt(i) sigma=a*delta+b 2 xmag=log10(boampl/period) + sigma + stacor RETURN endif if(epdistkm.gt.0..and.epdistkm.le.60.)then xmag=log10(waampl) + 0.018 *epdistkm+1.77 + 0.40 endif if(epdistkm.gt.60..and.epdistkm.le.700.)then xmag=log10(waampl) + 0.0038*epdistkm+2.62 + 0.40 endif if(epdistkm.gt.1100..and.epdistkm.le.1700.)then xmag=log10(waampl) + 0.0029*epdistkm+3.40 + 0.40 - 2. ! EMPIRISCH endif if(xmag.eq.-13.) RETURN ! xmag konnte nicht berechnet werden xmag=xmag+stacor ! Stationskorrektur Cs c return end c subroutine MPDR2(isecpendel,seismkonst,seismdamp, & voltgain,pdrampl,period,iampltyp,ampl) c c------------------------------------ Kaspar G. Renggli 1984 --------------- C c bodenamliptude fuer pdr2-stationen des nw-ch-netzes c parameter wie bei subr. muk, ausser pdrampl in [1/10 um/sec] c--------------------------------------------------------------------------- c implicit none integer isecpendel,iampltyp real seismkonst,seismdamp,voltgain,pdrampl,period,ampl complex G,gseis,ghp,glp2,glp2a,glp3,j,jom real zpi,ts,s,hs,om,om2,omg1,omg2,omg3,omg4,omg5,twa real omw,hw,vwa data zpi/6.28319/ j/(0.,1.)/ TS=isecpendel S=seismkonst hs=seismdamp om=zpi/period jom=j*om om2=om**2 c-----Uebertragungsfunktionen fuer Seismometer und Filter des PDR-2-Systems--- c c------------ Seismometer als Wegaufnehmer (nur Mechanik) ------------- omg1=zpi/TS gseis=jom*om2/(omg1**2+2*jom*omg1*hs-om2) c------------- 2 Hochpaesse 1. Ordnung => 2. Ordnung, fc=0.3 Hz ----- omg2=zpi*0.3 ghp=1/(1-2*j*omg2/om-omg2**2/om2) c------------- Butterworth Tiefpass 2. Ordnung, fc=30.Hz -------------- omg3=zpi*30. glp2=1/(1+1.4142*j*om/omg3-om2/omg3**2) c----------- Butterworth Tiefpass 3.Ordnung, fc=25 Hz (Discriminator)---- omg4=zpi*25. glp3=1/(1+2*j/omg4-2*om2/omg4**2-jom*om2/omg4**3) c----------- Butterworth Tiefpass 2.Ordnung, fc=24 Hz (Antialiasing) ---- omg5=zpi*24. glp2a=1/(1+1.4142*jom/omg5-om2/omg5**2) c----------- Uebertragungsfunktion des gesamten Systems ----------------- G=gseis*ghp*glp2*glp3*glp2a c---- Deconvolution mit der Uebertragungsfunktion eines Wood-Anderson-Seism. Twa=0.8 omw=zpi/Twa hw=0.78 Vwa=2800 G=(om2 *Vwa/(omw**2+2*jom*omw*hw-om2))/G ampl=cabs(G) ! [sec] Amplitudengang = Betrag der kompl. Transferfkt. ampl=ampl*pdrampl/10000. ! [sec*1/10um/sec*1/1000=mm] return end c subroutine ufwabo(isecpendel,seismkonst,seismdamp,voltgain, & devampl,period,iampltype,ampl,ifilter) c---- subr. UFWABO --------------------------------------------------- c c Berechnet die komplexe Uebertragungsfunktion im Frequenzbereich c fuer das System 'Bodenbewegung --> Devco-Auswertetisch' bzw. c fuer das System 'Bodenbewegung --> ADC (Mini)' c c Options: iampltype = 1 --> [ampl] = mm(Wood-Anderson)/mm(Devco) c iampltype = 2 --> [ampl] = Mikron(Bodenbewegung)/mm(Devco) c c ifilter = 'DE' --> devampl von Develocorder c ifilter = 'AD' --> devampl von ADC c c Zur Subr. UFWABO gehoeren ebenfalls die Complex-Functions: c HP1, STS373, DEV und B6. c-------------------------------------------------------------------------- implicit none integer isecpendel,iampltype real seismkonst,seismdamp,voltgain,devampl real period,ampl c real zpi,t02,t01,ts,s,hs,om,om2,omg2,tau2 real om0,gain,twa,o0w,hw,vwa,amplresp,omg1,tau1 integer iline,i character*(*) ifilter complex g1,g2,G,j,B6,HP1,STS373,DEV,jom complex gseismb data zpi/6.28319/j/(0.,1.)/ c c---- Spezifikation der Hochpaesse auf der Gesamtuebertragung (PREampl. --> c---- ADC) wie mit Programm Calap berechnet (bzw. verifiziert) c iline=isecpendel if(iline.eq.1)then T02=11.9 ! 1-sec-Linie T01= 3.7 ! '' endif if(iline.eq.2)then T02= 12.7 ! 2-sec-Linie T01=112. ! '' endif TS=isecpendel S=seismkonst hs=seismdamp c c---- Berechnung der Uebertragungsfunktion {Bodenbewegung --> ADC} --- c om=zpi/period jom=j*om om2=om**2 c c--------------------------- HP 2. Ordnung ---------------------------- c--------------------------- zus.gesetzt aus 2 HP 1. Ordnung ---------- omg2=zpi*1./T02 tau2=1./omg2 c g2=jom*tau2 g2=(g2/(1.+g2))**2 c--------------------------- HP 1. Ordnung ---------------------------- omg1=zpi*1./T01 tau1=1./omg1 c g1=jom*tau1 g1=g1/(1.+g1) c----- Seismometer ---------------------------------------------------- 100 om0=zpi/TS ! fuer Bodenbewegung ------------------------------------------ gseismb=om2*jom*S/(om0**2+2*jom*om0*hs-om2) ! [V/cm] c---------------------------------------------------------------------- c c---- Die Uebertragungsfunktionen wurden urspruenglich via ADC berechnet c (WK Kradi ~1983) und demzufolge ist der anti-alias-Filter schon c in der Uebertragungsfunktion mit inbegriffen. Um die Uebertragungs- c funktionen nur bis zum Diskriminator zu berechnen, muss dieser c Filter rueckgaengig gemacht werden: c---- Inverse Uebertragung des DC-Unterdrueckungs-HP vor ADC c G=g1*g2*gseismb/HP1(om) c---- (damit sind wir beim Diskriminator) c if(ifilter.eq.'DE')then c c Uebertragung {Diskriminator --> Vergroesserungsschirm} c G=G*STS373(om)*DEV(om) ! Bis jetzt [mm Devco/mm Bodenbew.] c endif c if(ifilter.eq.'AD')then c c Uebertragung {Diskriminator --> ADC } c G=G*HP1(om)*B6(om) ! Bis jetzt [volt/cm Bodenbewegung] gain=16. ! [plot mm / volt] (Ablesung ist so skaliert) G=G/10. ! [volt/mm Bodenbewegung] G=G*gain ! [mm plot/mm Bodenbewegung] c endif c c---- Umrechnung in Mikron/Devco-Millimeter bzw. c---- Deconvolution mit der Uebertragungsfunktion eines Wood-Anderson-Seism. c i=iampltype !!! Ablesung = devco oder plot if(i.eq.2)then G=G/1000. ! jetzt: mm Ablesung/um Bodenbewegung goto 999 endif if(i.eq.1)then Twa=0.8 o0w=zpi/Twa hw=0.78 Vwa=2800 G=G/(om2 *Vwa/(o0w**2+2*jom*o0w*hw-om2)) C ! [1] nur Wegvergr. !! ! jetzt: mm Ablesung/mm Wood-Anderson ! goto 999 endif c 999 amplresp=cabs(G) ! Amplitudengang := Betrag der kompl. Transferfkt. c ampl=devampl/(voltgain*amplresp) ! erst hier reziproke Einheiten !! c c fuer IAMPLTYPE = 1 | 2 c dann [ampl] = [mm Wood-Anderson] | [um Bodenbewegung] c RETURN end c c c------------------- B6: Bessel-Filter (TP) ------------------------------ complex function B6(om) implicit none complex j,gbn1,gbn2,gbn3 real om,zpi,fg1,omg1 c data j/(0.,1.)/,zpi/6.28319/ fg1=12. ! Grenzfrequenz 12 Hz omg1=om/(zpi*fg1) c gbn1= 1. + 1.2217*j*omg1 - 0.3887*omg1*omg1 gbn2= 1. + 0.9686*j*omg1 - 0.3505*omg1*omg1 gbn3= 1. + 0.5131*j*omg1 - 0.2756*omg1*omg1 c b6=1./(gbn1*gbn2*gbn3) c end c c------------------- HP 0.1 Hz 1. Ordnung (vor ADC) [DC-Unterdrueckung]- complex function HP1(om) implicit none real om complex j real zpi,fg,tau data j/(0.,1.)/zpi/6.28319/ Fg=0.1 ! [Hz] Grenzfrequenz tau=1./(zpi*Fg) c HP1=j*om*tau HP1=HP1/(1.+HP1) c return end c c------------------- TP STS-373 (Bessel 4. Ordnung, 5 Hz ) ---------- complex function STS373(om) implicit none real om c implicit InTeGeR*4 (i-n) complex j,gbn1,gbn2, o real zpi,fg1,omg1 data j/(0.,1.)/zpi/6.28319/ fg1=5. omg1=zpi*fg1 o=om/omg1 c gbn1=1.+1.3397*j*o-0.4889*o**2 gbn2=1.+0.7743*j*o-0.3890*o**2 c STS373=1/(gbn1*gbn2) c return end c c------------------- Develocorder & 12-fache Schirmvergroesserung ----- complex function DEV(om) implicit none real om complex j real zpi,fg,tau data j/(0.,1.)/zpi/6.28319/ ! 1.6 cm/V MIT 12-f. Vergr. am Tisch !! Fg=15. ! [Hz] ! Galvanometer krit. Daempfung tau=1./(zpi*Fg) ! (TP) 2. Ordnung c DEV=1.6*( 1./(1.+j*om*tau) )**2 ! [cm/V] c c!!!!!!!! bei neuen functions diese in Haupt-Subroutine deklarieren !!! return end c cek end of vel_mag.f c cek begin of vel_math.f c subroutine STOREG(k,l) c c---- save column k of g in gcopy c implicit none integer k,l include 'vel_com.f' integer ii,jj,i,j c ii=0 jj=0 do 1 i=1,nvar do 1 j=1,i jj=jj+1 if(i.ne.k.and.j.ne.k) goto 1 ii=ii+1 gcopy(l,ii)=g(jj) 1 continue return end ! of subr. storeg c subroutine SINGULARVALUES(i) c c compute the singular values (in this case: eigenvalues) of the c symmetric matrix G. c implicit none integer i include 'vel_com.f' integer k,ii,jj,i1,j c real A(4,4), Xsol(4) c do k=1,nvar ii=0 jj=0 do i1=1,nvar do j=1,i1 jj=jj+1 if(.NOT.(i1.ne.k.and.j.ne.k))then ii=ii+1 A(k,ii)=g(jj) endif enddo enddo enddo c call SVDSOLUK(A,RHt,nvar,-1.,Xsol,SV,ale(i),COVs,Rs) c if(ifixsolution.eq.1) call ALESUBR(SV,3,ale(i)) if(ifixsolution.eq.9) call ALESUBR(SV,1,ale(i)) c if(.not.single_turbo)then write(16,*)'Singular values; iteration #',nitt write(16,'(1x,4(2x,f10.6))') (sv(jj),jj=1,nvar) write(16,*)'ALE = ',ale(i) endif c ccc write(16,*)'SVD-solution vector:' ccc write(16,'(1x,4(2x,f16.6))') (Xsol(jj),jj=1,nvar) c return end ! of subr. singularvalues c subroutine DAMPG c c apply damping to the diagonal elements of the symmetric matrix G c implicit none include 'vel_com.f' integer j,k c c apply damping to diagonal elements of G-matrix : c j=0 do k=1,nvar ! k = 1 2 3 4 5 ... j=j+k ! j = 1 3 6 10 15 ... <== diagonal elements of G g(j)=g(j)+othet enddo c return end ! of subr. dampg c subroutine ACCUNORMEQS(rowofa,nvar,res,w,g,rhs) c c Urs Kradolfer, 22. 4. 1987 c c accumulate normal equations, knowing only one row of A at a time; c subr. ACCUNORMEQS must be called nvar times (once for c each observation). c w is the (normalized ! ) weight of the observation. c c A * x = res INPUT: one row of A and one element of res c c At*A * x = At*res c c G * x = RHS OUTPUT: G (nvar x nvar) and RHS (nvar) c implicit none real g(*),rowofa(*),rhs(*),res,w integer nvar call OUTER(g,rowofa,nvar,w) call RSIDE(rhs,rowofa,nvar,res,w) c return end ! of subr. accunormeqs c subroutine OUTER(g,s,n,w) c c this routine does an outer product of a vector c s with itself. This is used in least squares c to accumulate (At)A knowing only one c row of A at a time. (At)A is a symmetric c matrix which is n by n. This matrix is stored c in the vector g in symmetric storage mode. Thus, c given the ith row and jth column of the matrix, then c nsym=((i*(i-1))/2) + j c gives the index for the element nsym of g c for i.ge.j. For j less than i, the c element ij is identical to the element ji. c c input: c s(i) one row of the matrix (A) . c n - the length of s(i) c w - a weight for the least squares. c implicit none integer n real s(n),g((n*(n-1)/2)+n),w integer i,j,nsym real a,b c do 1 i=1,n if(s(i).eq.0) goto 1 a=s(i)*w c do 2 j=1,i if(s(j).eq.0) goto 2 b=s(j)*a c nsym=((i*(i-1))/2) + j g(nsym)=g(nsym) + b 2 continue c 1 continue return end ! of subr. outer c subroutine RSIDE(rht,s,n,res,w) c c this routine accumulates in rht the quantity (At)b c for the normal equations. c c input: c s(i)-one column of the matrix (At) c n - the length of s(i) c res - one value of the vector b. c w - a weight for the weighted least sqs. c implicit none integer n real rht(n),s(n),w,res integer i c do 1 i=1,n if(s(i).eq.0) goto 1 rht(i)=res*w*s(i) + rht(i) 1 continue return end ! of subr. rside c subroutine ALEsubr(SV,m,ale) c c Urs Kradolfer, June 1st, 1987 c c Input : Array SV, containing the M singular values c m , dimension of SV c c Output: ALE-value c c ALE = - 1./(m-izero) * sum(i=1...m) log10( SV(i)/SV(1) ) c + izero*10. c c where izero = # zero-singular-values c implicit none c integer m real SV(m) real ale,alesum integer i,izero c if(m.eq.0)stop'ALEsubr>>> m was zero !!!' c ale=0.0 alesum=0.0 izero=0 do i=1,m ale=sv(i)/sv(1) if(ale.le.0.0)then izero=izero+1 else alesum=alesum+log10(ale) endif enddo ale=-(alesum/float(m-izero)) + 10*izero c return end ! of subr. alesubr c subroutine LSVDF (A,IA,M,N,B,IB,NB,S,WK,IER) c This is an IMSL-subroutine implicit none C C SPECIFICATIONS FOR ARGUMENTS INTEGER IA,M,N,IB,NB,IER real A(IA,N),B(IB,1),S(N),WK(N,2) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,J,JP1,K,L,MM,NN,NNP1,NS,NSP1 real ZERO,ONE,T integer nm real f DATA ZERO/0.0e0/,ONE/1.0e0/ C FIRST EXECUTABLE STATEMENT IER=0 C BEGIN SPECIAL FOR ZERO ROWS AND C COLS. PACK THE NONZERO COLS TO THE C LEFT NN=N IER=34 IF (NN.LE.0.OR.M.LE.0) GO TO 9000 IER=0 J=NN 5 CONTINUE DO 10 I=1,M IF (A(I,J).NE.ZERO) GO TO 25 10 CONTINUE C COL J IS ZERO. EXCHANGE IT WITH COL C N IF (J.EQ.NN) GO TO 20 DO 15 I=1,M 15 A(I,J)=A(I,NN) 20 CONTINUE A(1,NN)=J NN=NN-1 25 CONTINUE J=J-1 IF (J.GE.1) GO TO 5 C IF N=0 THEN A IS ENTIRELY ZERO AND C SVD COMPUTATION CAN BE SKIPPED NS=0 IF (NN.EQ.0) GO TO 120 C PACK NONZERO ROWS TO THE TOP QUIT C PACKING IF FIND N NONZERO ROWS I=1 MM=M 30 IF (I.GT.N.OR.I.GE.MM) GO TO 75 IF (A(I,I).NE.ZERO) GO TO 40 DO 35 J=1,NN IF (A(I,J).NE.ZERO) GO TO 40 35 CONTINUE GO TO 45 40 I=I+1 GO TO 30 C ROW I IS ZERO EXCHANGE ROWS I AND M 45 IF (NB.LE.0) GO TO 55 DO 50 J=1,NB T=B(I,J) B(I,J)=B(MM,J) B(MM,J)=T 50 CONTINUE 55 DO 60 J=1,NN 60 A(I,J)=A(MM,J) IF (MM.GT.NN) GO TO 70 DO 65 J=1,NN 65 A(MM,J)=ZERO 70 CONTINUE C EXCHANGE IS FINISHED MM=MM-1 GO TO 30 C 75 CONTINUE C END SPECIAL FOR ZERO ROWS AND C COLUMNS C BEGIN SVD ALGORITHM.. C (1) REDUCE THE MATRIX TO UPPER C BIDIAGONAL FORM WITH HOUSEHOLDER C TRANSFORMATIONS. C H(N)...H(1)AQ(1)...Q(N-2) = C (D**T,0)**T WHERE D IS UPPER C BIDIAGONAL. C (2) APPLY H(N)...H(1) TO B. HERE C H(N)...H(1)*B REPLACES B IN C STORAGE. C (3) THE MATRIX PRODUCT W= C Q(1)...Q(N-2) OVERWRITES THE FIRST C N ROWS OF A IN STORAGE. C (4) AN SVD FOR D IS COMPUTED. HERE K C ROTATIONS RI AND PI ARE COMPUTED C SO THAT RK...R1*D*P1**(T)...PK**(T) C = DIAG(S1,...,SM) TO WORKING C ACCURACY. THE SI ARE NONNEGATIVE C AND NONINCREASING. HERE RK...R1*B C OVERWRITES B IN STORAGE WHILE C A*P1**(T)...PK**(T) OVERWRITES A C IN STORAGE. C (5) IT FOLLOWS THAT,WITH THE PROPER C DEFINITIONS, U**(T)*B OVERWRITES C B, WHILE V OVERWRITES THE FIRST N C ROW AND COLUMNS OF A. L=MIN0(MM,NN) C THE FOLLOWING LOOP REDUCES A TO C UPPER BIDIAGONAL AND ALSO APPLIES C THE PREMULTIPLYING TRANSFORMATIONS C TO B. DO 85 J=1,L IF (J.GE.MM) GO TO 80 JP1=MIN0(J+1,NN) CALL VHS12 (1,J,J+1,MM,A(1,J),1,T,A(1,JP1),1,IA,NN-J) CALL VHS12 (2,J,J+1,MM,A(1,J),1,T,B,1,IB,NB) 80 IF (J.GE.NN-1) GO TO 85 CALL VHS12 (1,J+1,J+2,NN,A(J,1),IA,WK(J,2),A(J+1,1),IA,1,MM-J) 85 CONTINUE C COPY THE BIDIAGONAL MATRIX INTO THE C ARRAY S FOR LSVDB IF (L.EQ.1) GO TO 95 DO 90 J=2,L S(J)=A(J,J) WK(J,1)=A(J-1,J) 90 CONTINUE 95 S(1)=A(1,1) C NS=NN IF (MM.GE.NN) GO TO 100 NS=MM+1 S(NS)=ZERO WK(NS,1)=A(MM,MM+1) 100 CONTINUE C CONSTRUCT THE EXPLICIT N BY N C PRODUCT MATRIX, W=Q1*Q2*...*QL*I C IN THE ARRAY A DO 115 K=1,NN I=NN+1-K IF (I.GT.MIN0(MM,NN-2)) GO TO 105 CALL VHS12 (2,I+1,I+2,NN,A(I,1),IA,WK(I,2),A(1,I+1),1,IA,NN-I) 105 DO 110 J=1,NN 110 A(I,J)=ZERO A(I,I)=ONE 115 CONTINUE C COMPUTE THE SVD OF THE BIDIAGONAL C MATRIX C C LEVEL=1 C CALL UERSET(LEVEL,LEVOLD) CALL LSVDB (S(1),WK(1,1),NS,A,IA,NN,B,IB,NB,IER) C TEST FOR IER=33 C IF (IER.GT.128) GO TO 9000 C CALL UERSET(LEVOLD,LEVOLD) IF (IER.NE.33) GO TO 120 cuk WRITE(6,4500) IER 4500 FORMAT(2X,'SUBR. LSVDF: IER=',I4,'AFTER CALL OF SUBR.LSVDB') T=0.0e0 NM=MIN0(M,N) IF (S(1).NE.ZERO) T=S(NM)/S(1) F=100.0e0+T IF (F.EQ.100.0e0) GO TO 120 IER=0 120 CONTINUE IF (NS.GE.NN) GO TO 130 NSP1=NS+1 DO 125 J=NSP1,NN 125 S(J)=ZERO 130 CONTINUE IF (NN.EQ.N) GO TO 155 NNP1=NN+1 C MOVE RECORD OF PERMUTATIONS AND C STORE ZEROS DO 140 J=NNP1,N S(J)=A(1,J) IF (NN.LT.1) GO TO 140 DO 135 I=1,NN 135 A(I,J)=ZERO 140 CONTINUE C PERMUTE ROWS AND SET ZERO SINGULAR C VALUES DO 150 K=NNP1,N I=S(K) S(K)=ZERO DO 145 J=1,N A(K,J)=A(I,J) 145 A(I,J)=ZERO A(I,K)=ONE 150 CONTINUE C END SPECIAL FOR ZERO ROWS AND C COLUMNS 155 IF (IER.EQ.0) GO TO 9005 9000 CONTINUE C CALL UERTST (IER,'LSVDF ') cuk if(ier.ne.33)then WRITE(6,4501) IER 4501 FORMAT(2X,'SUBR. LSVDF: AT END, IER=',I4,'CHECK SUBR. HEAD FOR', 11X,'MEANING') endif cuk 9005 RETURN END c subroutine LSVDB (D,E,N,V,IV,NRV,C,IC,NCC,IER) c C IMSL ROUTINE NAME - LSVDB C C----------------------------------------------------------------------- C C COMPUTER - HP1000/DOUBLE C C LATEST REVISION - JANUARY 1, 1978 C C PURPOSE - SINGULAR VALUE DECOMPOSITION OF A BIDIAGONAL C MATRIX. C C USAGE - CALL LSVDB (D,E,N,V,IV,NRV,C,IC,NCC,IER) C C ARGUMENTS D - VECTOR OF LENGTH N. (INPUT/OUTPUT) C ON INPUT, D CONTAINS THE DIAGONAL ELEMENTS C OF THE BIDIAGONAL MATRIX B. D(I)=B(I,I), C I=1,...,N. C ON OUTPUT, D CONTAINS THE N (NONNEGATIVE) C SINGULAR VALUES OF B IN NONINCREASING C ORDER. C E - VECTOR OF LENGTH N. (INPUT/OUTPUT) C ON INPUT, E CONTAINS THE SUPERDIAGONAL C ELEMENTS OF B. E(1) IS ARBITRARY, C E(I)=B(I-1,I), I=2,...,N. C ON OUTPUT, THE CONTENTS OF E ARE MODIFIED C BY THE SUBROUTINE. C N - ORDER OF THE MATRIX B. (INPUT) C V - NRV BY N MATRIX. (INPUT/OUTPUT) C IF NRV.LE.0, V IS NOT USED. OTHERWISE, C V IS REPLACED BY THE NRV BY N PRODUCT C MATRIX V*VB. SEE REMARKS. C IV - ROW DIMENSION OF MATRIX V EXACTLY AS C SPECIFIED IN THE DIMENSION STATEMENT IN THE C CALLING PROGRAM. (INPUT) C NRV - NUMBER OF ROWS OF V. (INPUT) C C - N BY NCC MATRIX. (INPUT/OUTPUT) C IF NCC.LE.0 C IS NOT USED. OTHERWISE, C C IS REPLACED BY THE N BY NCC PRODUCT C MATRIX UB**(T) * C. SEE REMARKS. C IC - ROW DIMENSION OF MATRIX C EXACTLY AS C SPECIFIED IN THE DIMENSION STATEMENT IN THE C CALLING PROGRAM. (INPUT) C NCC - NUMBER OF COLUMNS IN C. (INPUT) C IER - ERROR PARAMETER. (INPUT) C WARNING ERROR C IER=33 INDICATES THAT MATRIX B IS NOT FULL C RANK OR VERY ILL-CONDITIONED. SMALL C SINGULAR VALUES MAY NOT BE VERY ACCURATE. C TERMINAL ERROR C IER=129 INDICATES THAT CONVERGENCE WAS C NOT ATTAINED AFTER 10*N QR SWEEPS. C (CONVERGENCE USUALLY OCCURS IN ABOUT C 2*N SWEEPS). C C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 C - SINGLE/H36,H48,H60 C C REQD. IMSL ROUTINES - LSVG1,LSVG2,VHS12,UERTST,UGETIO C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C REMARKS LSVDB COMPUTES THE SINGULAR VALUE DECOMPOSITION OF C AN N BY N BIDIAGONAL MATRIX C B = UB * S * VB**(T) WHERE C UB AND VB ARE N BY N ORTHOGONAL MATRICES AND C S IS DIAGONAL. C IF ARGUMENTS V AND C ARE N BY N IDENTITY MATRICES, C ON EXIT THEY ARE REPLACED BY VB AND UB**T, C RESPECTIVELY. C C COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C implicit none C SPECIFICATIONS FOR ARGUMENTS INTEGER N,IV,NRV,IC,NCC,IER cuk real D(N),E(N),V(IV,1),C(IC,1) real D(N),E(N),V(IV,100),C(IC,100) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I,II,J,K,KK,L,LL,LP1,NQRS,N10 LOGICAL WNTV,HAVERS,FAIL real DNORM,ZERO,ONE,TWO,CS,F,G,H,SN,T,X,Y,Z DATA ZERO/0.0e0/,ONE/1.0e0/,TWO/2.0e0/ C FIRST EXECUTABLE STATEMENT IER=0 IF (N.LE.0) GO TO 9005 N10=10*N WNTV=NRV.GT.0 HAVERS=NCC.GT.0 FAIL=.FALSE. NQRS=0 E(1)=ZERO DNORM=ZERO DO 5 J=1,N 5 DNORM=MAX1(ABS(D(J))+ABS(E(J)),DNORM) DO 100 KK=1,N K=N+1-KK C TEST FOR SPLITTING OR RANK C DEFICIENCIES FIRST MAKE TEST FOR C LAST DIAGONAL TERM, D(K), BEING C SMALL. 10 IF (K.EQ.1) GO TO 25 T=DNORM+D(K) IF (T.NE.DNORM) GO TO 25 C C SINCE D(K) IS SMALL WE WILL MAKE A C SPECIAL PASS TO TRANSFORM E(K) TO C ZERO. CS=ZERO SN=-ONE DO 20 II=2,K I=K+1-II F=-SN*E(I+1) E(I+1)=CS*E(I+1) T=D(I) CALL LSVG1 (T,F,CS,SN,D(I)) C TRANSFORMATION CONSTRUCTED TO ZERO C POSITION (I,K). IF (.NOT.WNTV) GO TO 20 DO 15 J=1,NRV 15 CALL LSVG2 (CS,SN,V(J,I),V(J,K)) C C ACCUMULATE RT. TRANSFORMATIONS IN V. 20 CONTINUE C THE MATRIX IS NOW BIDIAGONAL, AND OF C LOWER ORDER SINCE E(K) .EQ. ZERO 25 DO 30 LL=1,K L=K+1-LL T=DNORM+E(L) IF (T.EQ.DNORM) GO TO 50 T=DNORM+D(L-1) IF (T.EQ.DNORM) GO TO 35 30 CONTINUE C THIS LOOP CANT COMPLETE SINCE E(1) = C ZERO. GO TO 50 C CANCELLATION OF E(L), L.GT.1. 35 CS=ZERO SN=-ONE DO 45 I=L,K F=-SN*E(I) E(I)=CS*E(I) T=DNORM+F IF (T.EQ.DNORM) GO TO 50 T=D(I) CALL LSVG1 (T,F,CS,SN,D(I)) IF (.NOT.HAVERS) GO TO 45 DO 40 J=1,NCC 40 CALL LSVG2 (CS,SN,C(I,J),C(L-1,J)) 45 CONTINUE C TEST FOR CONVERGENCE 50 Z=D(K) IF (L.EQ.K) GO TO 85 C SHIFT FROM BOTTOM 2 BY 2 MINOR OF C B**(T)*B. X=D(L) Y=D(K-1) G=E(K-1) H=E(K) F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(TWO*H*Y) G=SQRT(ONE+F**2) IF (F.LT.ZERO) GO TO 55 T=F+G GO TO 60 55 T=F-G 60 F=((X-Z)*(X+Z)+H*(Y/T-H))/X C NEXT QR SWEEP CS=ONE SN=ONE LP1=L+1 DO 80 I=LP1,K G=E(I) Y=D(I) H=SN*G G=CS*G CALL LSVG1 (F,H,CS,SN,E(I-1)) F=X*CS+G*SN G=-X*SN+G*CS H=Y*SN Y=Y*CS IF (.NOT.WNTV) GO TO 70 C ACCUMULATE ROTATIONS (FROM THE C RIGHT) IN V DO 65 J=1,NRV 65 CALL LSVG2 (CS,SN,V(J,I-1),V(J,I)) 70 CALL LSVG1 (F,H,CS,SN,D(I-1)) F=CS*G+SN*Y X=-SN*G+CS*Y IF (.NOT.HAVERS) GO TO 80 DO 75 J=1,NCC 75 CALL LSVG2 (CS,SN,C(I-1,J),C(I,J)) C C APPLY ROTATIONS FROM THE LEFT TO C RIGHT HAND SIDES IN C 80 CONTINUE E(L)=ZERO E(K)=F D(K)=X NQRS=NQRS+1 IF (NQRS.LE.N10) GO TO 10 C RETURN TO TEST FOR SPLITTING. FAIL=.TRUE. C CUTOFF FOR CONVERGENCE FAILURE. NQRS C WILL BE 2*N USUALLY. 85 IF (Z.GE.ZERO) GO TO 95 D(K)=-Z IF (.NOT.WNTV) GO TO 95 DO 90 J=1,NRV 90 V(J,K)=-V(J,K) 95 CONTINUE C CONVERGENCE. D(K) IS MADE C NONNEGATIVE 100 CONTINUE IF (N.EQ.1) GO TO 140 DO 105 I=2,N IF (D(I).GT.D(I-1)) GO TO 110 105 CONTINUE GO TO 140 C EVERY SINGULAR VALUE IS IN ORDER 110 DO 135 I=2,N T=D(I-1) K=I-1 DO 115 J=I,N IF (T.GE.D(J)) GO TO 115 T=D(J) K=J 115 CONTINUE IF (K.EQ.I-1) GO TO 135 D(K)=D(I-1) D(I-1)=T IF (.NOT.HAVERS) GO TO 125 DO 120 J=1,NCC T=C(I-1,J) C(I-1,J)=C(K,J) 120 C(K,J)=T 125 IF (.NOT.WNTV) GO TO 135 DO 130 J=1,NRV T=V(J,I-1) V(J,I-1)=V(J,K) 130 V(J,K)=T 135 CONTINUE C END OF ORDERING ALGORITHM. 140 IER=129 IF (FAIL) GO TO 9000 C CHECK FOR POSSIBLE RANK DEFICIENCY IER=33 T=0.0e0 IF (D(1).NE.ZERO) T=D(N)/D(1) F=100.0e0+T IF (F.EQ.100.0e0) GO TO 9000 IER=0 GO TO 9005 9000 CONTINUE C CALL UERTST (IER,'LSVDB ') cuk if(ier.ne.33)then WRITE(6,4500) IER 4500 FORMAT(2X,'SUBR. LSVDB AT END: IER=',I4,' CHECK HEADER FOR', 1' MEANING') endif cuk 9005 RETURN END c subroutine LSVG1 (A,B,DCOS,DSIN,SIG) c C IMSL ROUTINE NAME - LSVG1 C C----------------------------------------------------------------------- C C COMPUTER - HP1000/DOUBLE C C LATEST REVISION - JANUARY 1, 1978 C C PURPOSE - NUCLEUS CALLED ONLY BY IMSL ROUTINE LSVDB C C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 C - SINGLE/H36,H48,H60 C C REQD. IMSL ROUTINES - NONE REQUIRED C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C implicit none C SPECIFICATIONS FOR ARGUMENTS real A,B,DCOS,DSIN,SIG C SPECIFICATIONS FOR LOCAL VARIABLES real AA,BB C FIRST EXECUTABLE STATEMENT double precision doubleb, doubleaa, doubler IF (ABS(A).LE.ABS(B)) GO TO 5 AA=ABS(A+A) cuk next statement caused an underflow! u.kradolfer, 16.7.81 cuk SIG=AA*SQRT(0.25e0+(B/AA)**2) cuk next statement produced a compiler warning with range checking option cuk SIG=AA*sngl( dSQRT(0.25d0+(dble(B)/dble(AA))**2) ) ! u.k. 7.2.92 doubleb=DBLE(b) doubleaa=DBLE(aa) doubler=dSQRT(0.25d0+(doubleb/doubleaa)**2) sig=AA*sngl(doubler) DCOS=A/SIG DSIN=B/SIG RETURN 5 IF (B.EQ.0.0e0) GO TO 10 BB=ABS(B+B) SIG=BB*SQRT(0.25e0+(A/BB)**2) DCOS=A/SIG DSIN=B/SIG RETURN 10 SIG=0.0e0 DCOS=0.0e0 DSIN=1.0e0 RETURN END c subroutine LSVG2 (DCOS,DSIN,X,Y) c C IMSL ROUTINE NAME - LSVG2 C C----------------------------------------------------------------------- C C COMPUTER - HP1000/DOUBLE C C LATEST REVISION - JANUARY 1, 1978 C C PURPOSE - NUCLEUS CALLED ONLY BY IMSL ROUTINE LSVDB C C PRECISION/HARDWARE - SINGLE AND DOUBLE/H32 C - SINGLE/H36,H48,H60 C C REQD. IMSL ROUTINES - NONE REQUIRED C C NOTATION - INFORMATION ON SPECIAL NOTATION AND C CONVENTIONS IS AVAILABLE IN THE MANUAL C INTRODUCTION OR THROUGH IMSL ROUTINE UHELP C C COPYRIGHT - 1978 BY IMSL, INC. ALL RIGHTS RESERVED. C C WARRANTY - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN C APPLIED TO THIS CODE. NO OTHER WARRANTY, C EXPRESSED OR IMPLIED, IS APPLICABLE. C C----------------------------------------------------------------------- C C implicit none C SPECIFICATIONS FOR ARGUMENTS real DCOS,DSIN,X,Y C SPECIFICATIONS FOR LOCAL VARIABLES real XR C FIRST EXECUTABLE STATEMENT XR=DCOS*X+DSIN*Y Y=-DSIN*X+DCOS*Y X=XR RETURN END c subroutine VHS12 (MODE,LP,L1,M,U,INCU,UP,C,INCC,ICV,NCV) C implicit none C SPECIFICATIONS FOR ARGUMENTS INTEGER MODE,LP,L1,M,INCU,INCC,ICV,NCV cuk real U(1),UP,C(1) cuk real U(m+1),UP,C(ncv*m) ! did NOT work... real U(100),UP,C(100) ! in this case only!!! (single-ev-l) C SPECIFICATIONS FOR LOCAL VARIABLES INTEGER IJ,ILP,IL1,IM,INCR,I2,I3,I4,J real SM,B real ONE,CL,CLINV,SM1 C FIRST EXECUTABLE STATEMENT ONE=1.e0 C IF (0.GE.LP.OR.LP.GE.L1.OR.L1.GT.M) GO TO 9005 ILP=(LP-1)*INCU+1 IL1=(L1-1)*INCU+1 IM=(M-1)*INCU+1 CL=ABS(U(ILP)) IF (MODE.EQ.2) GO TO 15 C CONSTRUCT THE TRANSFORMATION. DO 5 IJ=IL1,IM,INCU 5 CL=MAX1(ABS(U(IJ)),CL) IF (CL.LE.0.0e0) GO TO 9005 CLINV=ONE/CL SM=(U(ILP)*CLINV)**2 DO 10 IJ=IL1,IM,INCU 10 SM=SM+(U(IJ)*CLINV)**2 C CONVERT DBLE. PREC. SM TO SNGL. C PREC. SM1 SM1=SM CL=CL*SQRT(SM1) IF (U(ILP).GT.0.0e0) CL=-CL UP=U(ILP)-CL U(ILP)=CL GO TO 20 C APPLY THE TRANSFORMATION C I+U*(U**T)/B TO C. 15 IF (CL.LE.0.0e0) GO TO 9005 20 IF (NCV.LE.0) GO TO 9005 B=UP*U(ILP) C B MUST BE NONPOSITIVE HERE. IF B = C 0., RETURN. IF (B.GE.0.0e0) GO TO 9005 B=ONE/B I2=1-ICV+INCC*(LP-1) INCR=INCC*(L1-LP) DO 35 J=1,NCV I2=I2+ICV I3=I2+INCR I4=I3 SM=C(I2)*UP DO 25 IJ=IL1,IM,INCU SM=SM+C(I3)*U(IJ) I3=I3+INCC 25 CONTINUE IF (SM.EQ.0.0e0) GO TO 35 SM=SM*B C(I2)=C(I2)+SM*UP DO 30 IJ=IL1,IM,INCU C(I4)=C(I4)+SM*U(IJ) I4=I4+INCC 30 CONTINUE 35 CONTINUE 9005 RETURN END c subroutine LUDECP (a,ul,n,d1,d2,ier) c c function: - cholesky decomposition of a matrix A - c --------- c A nxn pos. def. symm. matrix, stored in symm. storage mode c UL nxn lower triangular matrix, with UL * ULt = A c !!! diagonal elements of UL are stored in reziprocal form !!! c det(A) = D1*(2.**D2) d1, d2 is output of LUDECP c IER=0 --> A is pos. def.; everything o.k. c implicit none integer n integer ier real d1,d2 real a(n*(n+1)/2),ul(n*(n+1)/2) real zero,one,four,sixtn,sixth,rn,x integer ip,i,iq,ir,j,k,ip1 data zero,one,four,sixtn,sixth/0.0,1.,4.,16.,.0625/ c d1=one d2=zero rn=one/(n*sixtn) ip=1 ier=0 do 45 i=1,n iq=ip ir=1 do 40 j=1,i x=a(ip) if (j .eq. 1) go to 10 do 5 k=iq,ip1 x=x-ul(k)*ul(ir) ir=ir+1 5 continue 10 if (i.ne.j) go to 30 d1=d1*x if (a(ip)+x*rn .le. a(ip)) go to 50 15 if (abs(d1) .le. one) go to 20 d1=d1 * sixth d2=d2 + four go to 15 20 if (abs(d1) .ge. sixth) go to 25 d1=d1 * sixtn d2=d2 - four go to 20 25 ul(ip)=one/sqrt(x) go to 35 30 ul(ip)=x * ul(ir) 35 ip1=ip ip=ip+1 ir=ir+1 40 continue 45 continue go to 9005 50 ier=129 9000 continue 9005 return end ! of subr. ludecp c subroutine luelmp (a,b,n,x) c c function: - elimination part of the solution of Ax=b c --------- c A (nxn) lower triangular matrix (outout of LUDECP) c !!! diagonal elements of A are stored in reziprocal form !!! c b n-vector c x n-vector (solution of equation Ax=b) c implicit none integer n real a(n*(n+1)/2),b(n),x(n) real zero,t integer ip,iw,i,im1,k,n1,ii,is,iq,kk data zero/0./ c solution of ly = b ip=1 iw=0 do 15 i=1,n t=b(i) im1=i-1 if (iw .eq. 0) go to 9 ip=ip+iw-1 do 5 k=iw,im1 t=t-a(ip)*x(k) ip=ip+1 5 continue go to 10 9 if (t .ne. zero) iw=i ip=ip+im1 10 x(i)=t*a(ip) ip=ip+1 15 continue c solution of ux = y n1=n+1 do 30 i=1,n ii=n1-i ip=ip-1 is=ip iq=ii+1 t=x(ii) if (n.lt.iq) go to 25 kk=n do 20 k=iq,n t=t-a(is)*x(kk) kk=kk-1 is=is-kk 20 continue 25 x(ii)=t*a(is) 30 continue return end ! of subr. luelmp c subroutine MATRMULT(A,m,p,B,p1,n,C,m1,n1) c Urs Kradolfer, 28.3.1987 implicit none c input: (mxp)-matrix A c (p1xn)-matrix B c output: (m1xn1)-matrix C = A*B integer m,p, p1,n, m1,n1 , & i,j,k real A(m,p), B(p1,n), C(m1,n1) , & s if(m.ne.m1)stop'Matrices cannot be multiplied !' if(p.ne.p1)stop'Matrices cannot be multiplied !' if(n.ne.n1)stop'Matrices cannot be multiplied !' do i=1,m do j=1,n s=0. do k=1,p s=s+A(i,k)*B(k,j) enddo C(i,j)=s enddo enddo return end ! of subr. matrmult c subroutine MATRTRAN(A,n,m,AT) c Urs Kradolfer, 28.3.1987 implicit none c input: (nxm)-matrix A c output: (mxn)-matrix AT ( = A transpose ) integer n,m , & i,j real A(n,m),AT(m,n) do i=1,n do j=1,m AT(j,i)=A(i,j) enddo enddo return end ! of subr. matrtran c subroutine MAXII(n,nx,imax,jndex) c determine maximum-value of an integer-array implicit none integer jndex,i,n,imax, nx(n) jndex=1 do 1 i=1,n 1 if(nx(jndex).le.nx(i)) jndex=i imax=nx(jndex) return end ! of subr. maxni c subroutine MAXRI(n,x,xmax,jndex) c determine maximum-value of a real-array implicit none integer i,n,jndex real x(n), xmax jndex=1 do 1 i=1,n 1 if(x(jndex).le.x(i)) jndex=i xmax=x(jndex) return end ! of subr. maxri c subroutine SORTI(iX,NO) ! Urs Kradolfer, Okt. 1986 (aus HYPOSUBR.FOR ) c c SORTA sortiert einen Integer-Array iX so, dass iX(1) < iX(2) < ... < iX(N) c c Aufruf: call SORTI(iX,N) c c mit INTEGER iX(N) c INTEGER N (Anzahl Elemente in X) c c Array iX wird in SORTI veraendert !! c implicit none integer i,no,mo,ko,jo integer iX(no),itemp c if(no.eq.0) return MO=NO 2 IF (MO-15) 21,21,23 21 IF (MO-1) 29,29,22 22 MO=2*(MO/4)+1 GO TO 24 23 MO=2*(MO/8)+1 24 KO=NO-MO JO=1 25 I=JO 26 IF (iX(I)-iX(I+MO)) 28,28,27 27 iTEMP=iX(I) iX(I)=iX(I+MO) iX(I+MO)=iTEMP I=I-MO IF (I-1) 28,26,26 28 JO=JO+1 IF (JO-KO) 25,25,2 29 continue return END ! of subr. sorti c subroutine SORTR(X,NO) ! Urs Kradolfer, Okt. 1986 (aus HYPOSUBR.FOR ) c c SORTR sortiert einen Real-Array X so, dass X(1) < X(2) < ... < X(N) c c Aufruf: call SORTR(X,N) c c mit REAL X(N) c INTEGER N (Anzahl Elemente in X) c c Array X wird in SORTR veraendert !! c implicit none integer i,no,mo,ko,jo real X(no),temp c MO=NO 2 IF (MO-15) 21,21,23 21 IF (MO-1) 29,29,22 22 MO=2*(MO/4)+1 GO TO 24 23 MO=2*(MO/8)+1 24 KO=NO-MO JO=1 25 I=JO 26 IF (X(I)-X(I+MO)) 28,28,27 27 TEMP=X(I) X(I)=X(I+MO) X(I+MO)=TEMP I=I-MO IF (I-1) 28,26,26 28 JO=JO+1 IF (JO-KO) 25,25,2 29 continue return END ! of subr. sortr c subroutine SPREADd(R,m,spread) ! Urs Kradolfer c DIRICHLET SPREAD FUNCTION c measures the goodness of the resolution spread, based on the c L2 norm of the difference between the resolution matrix and the c identity matrix [ Dirichlet spread function ] c R = I <==> spread(R) = 0 c implicit none integer m real r(m,m) real spread integer i,j c spread=0.0 do i=1,m do j=1,m if(i.eq.j) spread=spread+(r(i,j)-1)*(r(i,j)-1) if(i.ne.j) spread=spread+r(i,j)*r(i,j) enddo enddo return end ! of subr. SPREADd c subroutine SPREADb(R,m,spread) ! Urs Kradolfer c BACKUS-GILBERT SPREAD FUNCTION c measures the goodness of the resolution spread, based on the c L2 norm of the WEIGHTED difference between the resolution matrix and the c identity matrix [ Backus-Gilbert spread function ] c R = I <==> spread(R) = 0 c implicit none integer m real r(m,m) real spread integer j,i c spread=0.0 do i=1,m do j=1,m spread=spread+(i-j)*(i-j)*r(i,j)*r(i,j) enddo enddo return end ! of subr. spreadb c subroutine SVDSOLUK(Ain,Bin,m,eigmin,X,S,ale,COV,R) c c Urs Kradolfer, 24. April 1987 c c solve NORMAL EQUATIONS Gt*G * X = Gt*R c A * X = B , so A is symmetric !!! c c Input : left-hand-side A(mxm), right-hand-side B(m), c eigmin : >=0 cutoff-value for solution c = -1 only S (singular values) are returned c c Output: solution-vector X(m), singular-(eigen-)values S(m), c diagonal elements of covariance-matrix COV(m), c resolution-matrix R(mxm) c Average Logarithmic Eigenvalue ALE : c c ALE = 1./(m-izero) * sum(i=1...m) log10(S(i)) c c where izero = # zero-singular-values c c before, LGCN was used !!! c GCN = LOG10 [ average quotient of 1stEigenvalue to ithEigenvalue c / average eigenvalue ] c implicit none integer m real eigmin,ale,sum integer mm,mm2,i,j,ier,izero,nfre parameter (mm=4,mm2=8) real Ain(mm,mm),Bin(mm),A(4,4),B(mm), & X(mm),S(mm),COV(mm),R(mm,mm) real At(mm,mm) real WK(mm2,2) ! must be dimensioned to : 2m,2 c if(m.gt.4)stop'SVDSOLUK>>> m.gt.4 ; redimension arrays !!!' c c copy input-matrix/-vector into local ones (so the input doesn't change) : c do i=1,m do j=1,m a(i,j)=ain(i,j) enddo b(i)=bin(i) s(i)=0.0 cov(i)=0.0 enddo do i=1,mm2 do j=1,2 wk(i,j)=0.0 enddo enddo c c do SVD (singular value decomposition) of matrix A = V * S * Vt : c call LSVDF(A,m,m,m,B,m,1,S,WK,ier) ! IMSL-routine c c determine ALE ( Average Logarithmic Eigenvalue ) c c izero=0 c if(m.eq.1)then c GCN=1.0 c else c GCN=0.0 c sum=s(1) c do i=2,m c if(s(i).gt.0.0)then c GCN=GCN+s(1)/s(i) c sum=sum+s(i) c else c izero=izero+1 c endif c enddo c endif c sum=sum/m ! average eigenvalue. c GCN=izero*100.+log10((GCN/float((m-1)-izero))/sum) cc ale=0.0 izero=0 cc do i=1,m cc ale=ale+log10((s(i)/s(1))) ccc ale=ale+log10((s(i)/s(1)) + 1e-10) cc enddo cc ale=-ale/float(m) call ALEsubr(s,m,ale) c if(eigmin.lt.0) return c c determine degree of freedom (neglect sing. vals. < cutoff-value eigmin) : c nfre=0 do i=1,m x(i)=0.0 if(s(i).gt.eigmin)then nfre=nfre+1 else ccc write(6,*)'SVDSOLUK>>> skipping singular value = ',s(i) s(i)=0.0 ! set eigenvalue to zero do j=1,m a(j,i)=0.0 ! set appr. COLUMN of V (=eigenvector!!!) to zero enddo endif enddo c c calculate solution-vector X = V * inv(S) * Vt*B : c [ X = A * inv(S) * B ] c do i=1,m do j=1,nfre x(i)=x(i)+a(i,j)*b(j)/s(j) enddo enddo c c calculate diagonal elements of UNSCALED covariance matrix : c c C = datvar * V * inv(inv(S)) * Vt c c C(i,j)= SUM(k=1...m) V(i,k)*V(j,k)/(S(k,k)*S(k,k)) <-- for all elements c C(i,i)= SUM(k=1...m) V(i,k)*V(i,k)/(S(k,k)*S(k,k)) <-- diag. elem. only c do i=1,m sum=0.0 do j=1,nfre ccc write(6,*)'i=',i,'j=',j,'V(i,j)=',a(i,j) sum=sum+a(i,j)*a(i,j)/(s(j)*s(j)) enddo cov(i)=sum enddo c c compute resolution-matrix: R = V * Vt : c [ R = A * At ] c call MATRTRAN(A,m,m,At) call MATRMULT(A,m,m,At,m,m,R,m,m) c return end ! of subr. SVDSOLUK c cek end of vel_math.f c cek begin of vel_ray.f c subroutine RAYPOINTCHECK(rp,nrp,staname) c c checks, whether all the raypoints with z<0 are below the actual c surface of the topography (of Switzerland). c implicit none include 'vel_com.f' c integer nrp real rp(3,inrpmax) character*4 staname c integer j real zzz,dzzz do j=1,nrp if(rp(3,j).lt.0.0)then call CHTOP(-rp(1,j),rp(2,j),zzz,topo1file,topo2file) dzzz=rp(3,j)-zzz if(dzzz.lt.0.0)then write(6,'(1x,''ray in the air... ! rp3='',f6.3, & '' ZZ='',f6.3,'' dz='',f6.3,'' rp# ='',i2,'' nrp='',i2, & '' STN='',a4,''i '',i4)') & rp(3,j),zzz,dzzz,j,nrp,staname,isingle endif endif enddo c RETURN end ! of subr. raypointcheck c subroutine LAYERHIT(rp,nrpdeep,nl,nrp,mll) c c counts the number of hits in each layer. c implicit none include 'vel_com.f' c integer nrpdeep,nl,nrp,mll real rp(3,inrpmax) real rpmax,avraydepth integer j,jlay c c c find deepest layer hit by this ray (= refraction layer or eventlayer c for direct wave) rpmax=-999. do j=1,nrp if(rp(3,j).gt.rpmax)then rpmax=rp(3,j) ! = max. depth of ray nrpdeep=j ! index of deepest raypoint endif enddo rpmax=rpmax+0.000001 ! avoid raypoint on layer-boundary lmax=1 do j=2,nl if(h(j).gt.rpmax)then ! h(j)= top of layer j [km] lmax=j-1 ! lmax = layer number for depth rpmax goto 4000 endif enddo lmax=nl ! lowest layer 4000 continue if(rp(3,nrpdeep).eq.rp(3,nrpdeep+1))then ! ray is horizontal irefrlayer(lmax)=irefrlayer(lmax)+1 ! headwave in layer LMAX refraylen(lmax)=refraylen(lmax)+ & SQRT( (rp(1,nrpdeep)-rp(1,nrpdeep+1))**2 + & (rp(2,nrpdeep)-rp(2,nrpdeep+1))**2 ) else if(mll.eq.0)then noheadwave=noheadwave+1 else irefllayer(lmax-1)=irefllayer(lmax-1)+1 c ! -1 because of rpmax=rpmax+0.000001 endif endif avhraylen=avhraylen+ & SQRT( (rp(1,1)-rp(1,nrp))**2 + & (rp(2,1)-rp(2,nrp))**2 ) avvraylen=avvraylen+ & ABS( rp(3,nrpdeep)-rp(3,nrp) ) c do j=2,nrp avraydepth=( rp(3,j)+rp(3,j-1) ) / 2. avraydepth=avraydepth+0.000001 ! avoid raydepth on layer-boundary do jlay=1,nl if(avraydepth.ge.h(jlay).and. & avraydepth.lt.(h(jlay)+thk(jlay)) )then hitlay(jlay,1)=hitlay(jlay,1)+1 hitlay(jlay,2)=hitlay(jlay,2)+ & SQRT( (rp(1,j)-rp(1,j-1))**2 + & (rp(2,j)-rp(2,j-1))**2 ) hitlay(jlay,3)=hitlay(jlay,3)+ & ABS( rp(3,j)-rp(3,j-1) ) endif enddo enddo RETURN end ! of subr. layerhit c subroutine CHECKRAYPATH(rp,nrp) c c implicit none include 'vel_com.f' c c do not allow two identical raypoints ! c (first two raypoints may be identical; e.g. if hypocenter is on c layer-boundary) c real rp(3,inrpmax) integer nrp c if(rp(1,1).eq.rp(1,2).and. & rp(2,1).eq.rp(2,2).and. & rp(3,1).eq.rp(3,2))then chrm do j=1,nrp-1 chrm rp(1,j)=rp(1,j+1) ! delete first ray-point chrm rp(2,j)=rp(2,j+1) ! and move elements in array RP 'down' chrm rp(3,j)=rp(3,j+1) chrm enddo chrm nrp=nrp-1 ! nr_of_raypoints is now smaller by 1 !! chrm move hypocenter 10 cm away from the layer boundary (upwards) rp(3,1) = rp(3,1) - 0.0001 RETURN endif c RETURN end ! of subr. checkraypath c subroutine BENDRAY(rp,nrp,staname,vtop,ttt) c implicit none include 'vel_com.f' c real rp(3,inrpmax) integer nrp real vtop,ttt character*4 staname c logical hypocintop real rpn(3,10) real xydist,takeoff_angle,arrive_angle real deltat1,deltat2,dx1,dy1,dz1,xyz1 real dx2,dy2,dz2,xyz2,zzz,ttt1new,xyz1n real ttt2new,xyz2n,ttt1old,ttt2old integer nrpm1,jnrp,jnrpm1 c if(icoordsystem.ne.2) RETURN ! topo-array only for switzerland available c xydist= & SQRT( (rp(1,nrp)-rp(1,1))**2 & +(rp(2,nrp)-rp(2,1))**2 ) if(xydist.gt.10.0) RETURN !epicentral-distance too big for 'airy' rays!(?) c takeoff_angle= & SQRT( (rp(1,2)-rp(1,1))**2 & +(rp(2,2)-rp(2,1))**2 ) & / & SQRT( (rp(1,2)-rp(1,1))**2 & +(rp(2,2)-rp(2,1))**2 & +(rp(3,2)-rp(3,1))**2 ) takeoff_angle=57.296*ASIN(takeoff_angle) if( (rp(3,2)-rp(3,1)) .lt. 0.0 )then takeoff_angle=180.-takeoff_angle ! ray is going upwards endif c arrive_angle= & SQRT( (rp(1,nrp)-rp(1,(nrp-1)))**2 & +(rp(2,nrp)-rp(2,(nrp-1)))**2 ) & / & SQRT( (rp(1,nrp)-rp(1,(nrp-1)))**2 & +(rp(2,nrp)-rp(2,(nrp-1)))**2 & +(rp(3,nrp)-rp(3,(nrp-1)))**2 ) arrive_angle=57.296*ASIN(arrive_angle) if( (rp(3,2)-rp(3,1)) .lt. 0.0 )then arrive_angle=180.-arrive_angle ! ray is coming upwards endif c c write(6,'(1x,''takeoff_angle='',f6.1,'' arrive_angle='', c & f6.1)') takeoff_angle, arrive_angle c deltat1=0.0 deltat2=0.0 hypocintop=.false. if(rp(3,1).lt.0.0)then hypocintop=.true. c compute XYZ1: the length between the first 2 raypoints dx1=rp(1,2)-rp(1,1) dy1=rp(2,2)-rp(2,1) dz1=rp(3,2)-rp(3,1) xyz1=SQRT(dx1**2 + dy1**2 + dz1**2) endif c c if takeoff_angle at surface < 45 --> ray too steep to be 'airy' c if(hypocintop.and.takeoff_angle.le.45.0) hypocintop=.false. if(hypocintop)then continue ! stay here; ray-start could be in the air... else if(arrive_angle.ge.135.0) RETURN ! ray too steep to be 'airy' endif c nrpm1=nrp-1 c compute XYZ2: the length between the last 2 raypoints dx2=rp(1,nrp)-rp(1,nrpm1) dy2=rp(2,nrp)-rp(2,nrpm1) dz2=rp(3,nrp)-rp(3,nrpm1) xyz2=SQRT(dx2**2 + dy2**2 + dz2**2) c c average (3D-)ray-length in the top-layer is about 2 kilometers; c now split ray in top-layer into 4 parts of about equal length: if(hypocintop)then dx1=dx1/4. dy1=dy1/4. dz1=dz1/4. endif dx2=dx2/4. dy2=dy2/4. dz2=dz2/4. if(hypocintop)then do jnrp=1,4 ! first raypoint = first old raypoint! rpn(1,jnrp)=rp(1,1)+(jnrp-1)*dx1 rpn(2,jnrp)=rp(2,1)+(jnrp-1)*dy1 rpn(3,jnrp)=rp(3,1)+(jnrp-1)*dz1 enddo jnrp=5 ! set last raypoint to second old raypoint to keep accuracy! rpn(1,jnrp)=rp(1,2) rpn(2,jnrp)=rp(2,2) rpn(3,jnrp)=rp(3,2) endif do jnrp=6,9 ! first raypoint = second-last old raypoint! rpn(1,jnrp)=rp(1,nrpm1)+(jnrp-6)*dx2 rpn(2,jnrp)=rp(2,nrpm1)+(jnrp-6)*dy2 rpn(3,jnrp)=rp(3,nrpm1)+(jnrp-6)*dz2 enddo jnrp=10 ! set last raypoint to last old raypoint to keep accuracy! rpn(1,jnrp)=rp(1,nrp) rpn(2,jnrp)=rp(2,nrp) rpn(3,jnrp)=rp(3,nrp) c c now set raypoints min. 100meters below surface (if necessary): c if(hypocintop)then do jnrp=2,5 call CHTOP(-rpn(1,jnrp),rpn(2,jnrp),zzz, & topo1file,topo2file) zzz=zzz+0.1 ! 100meters below surface if(rpn(3,jnrp).lt.zzz) rpn(3,jnrp)=zzz ! set hypoc. below surface ! enddo endif do jnrp=6,9 call CHTOP(-rpn(1,jnrp),rpn(2,jnrp),zzz, & topo1file,topo2file) zzz=zzz+0.1 ! 100meters below surface if(rpn(3,jnrp).lt.zzz) rpn(3,jnrp)=zzz ! set hypoc. below surface ! enddo c c calculate ray-length-difference and correct traveltime: c ttt1new=0.0 if(hypocintop)then do jnrp=2,5 jnrpm1=jnrp-1 xyz1n=SQRT( (rpn(1,jnrp)-rpn(1,jnrpm1))**2 & +(rpn(2,jnrp)-rpn(2,jnrpm1))**2 & +(rpn(3,jnrp)-rpn(3,jnrpm1))**2 ) ttt1new=ttt1new+xyz1n/vtop enddo endif ttt2new=0.0 do jnrp=7,10 jnrpm1=jnrp-1 xyz2n=SQRT( (rpn(1,jnrp)-rpn(1,jnrpm1))**2 & +(rpn(2,jnrp)-rpn(2,jnrpm1))**2 & +(rpn(3,jnrp)-rpn(3,jnrpm1))**2 ) ttt2new=ttt2new+xyz2n/vtop enddo if(hypocintop)then ttt1old=xyz1/vtop deltat1=(ttt1new-ttt1old) endif ttt2old=xyz2/vtop deltat2=(ttt2new-ttt2old) if(ABS(deltat1).gt.1e-5.or.ABS(deltat2).gt.1e-5)then write(6,'(1x,''BENDRAY>>> ray bended below surface!'', & '' Station: '',a4)') staname write(6,'(1x,''dt1='',f6.3,'' dt2='',f6.3)') deltat1,deltat2 endif ttt=ttt+deltat1+deltat2 c RETURN end ! of subr. bendray c subroutine RAYPATH(nx,ny,nz,x,y,z,vel,nl,thk,d,v,vsq,xe,ye,ze, & xr,yr,zr,rp,nrp,nrtn,jl,tkj,itype,ttt,MLL,sterr,direrr,refrerr, & reflerr,DTDDrefl,DTDHrefl) c c raypath attempts to approximate the least time path for a c seismic ray traveling in a medium with velocities specified at c points on a 3-dimensional grid. for very small delta a straight c line path is chosen. for larger delta a layered velocity model c approximating the region between the event and the receiver is c constructed and the least time path in that layered model is chosen c both direct and refracted rays are considered and the possibility c of low velocity layers is allowed. c the 3 - dimensional grid should be specified by the c intersections of 3 sets of planes normal to the x,y and z coordinate c axes. the intersection of the planes with the axes are specified c by x(i), y(j), and z(k), and the spacing of these may be c completely arbitrary. c subr. layers produces layer velocities from the c velocities of the 3 - dimensional model between the event and c the receiver, and because these will differ for every event - c receiver pair, layers must be called every time raypath is c called (unless delta is very small). the number, thicknesses, c and depths of the layers should depend only on the array z(k), c and need only to be calculated once for a given velocity model. c this is why nl, thk(l), and d(l) are included as input parameters c for raypath. when calling layers, the event and receiver must c be located within the horizontal confines of the grid, that is, c x(1) <= xe, xr <= x(nx) and y(1) <= ye, yr <= y(ny). c subrs. refract and direct determine refracted and direct c ray travel times and other parameters in a relatively standard c fashion, but are sufficiently general to account for low velocity c layers. c once the nature of the fastest ray has been determined, the c calculation of a set of raypoints along the path is straightforward c and is performed by subr. strpath, refpath, or dirpath. these c points consist of the event and receiver coordinates and, in the cases c of refpath and dirpath, every intermediate point at which the ray c crosses a boundary between layers. c because of the extensive branching in raypath, a parameter c to index the the 7 return statements in the main subr., c nrtn is included and takes on values from 1 to 7 (to 8 with extension c of reflected waves ! U.K. 11/1986). c c input: c nx,ny,nz - number of grid planes in x,y,z directions c x(i),y(j),z(k) - gridpoint coordinates c vel(i,j,k) - velocity at grid point x(i),y(j),z(k) c c nl - number of layers (should equal nz) c thk(l) - thickness of layer l c d(l) - depth to top of layer l c c xe,ye,ze - event coordinates c xr,yr,zr - receiver coordinates c c output: c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c nrp - number of raypoints c rp(1,2,or 3,i) - coordinates of raypoint i c c important internal arrays and variables: c c delta - horizontal distance between source and receiver c depth - depth of event below receiver c jl - number of event layer c tkj - depth of event from top of event layer c c kk - refracting layer for fastest refracted ray c didjkk - critical distance for refraction in layer kk c tref - refracted ray travel time c xovmax - an upper bound on delta for which the direct ray c can be the first arrival c c salpha - sine of the takeoff angle of the direct ray c deljl - horizontal travel distance of the c direct ray in the event layer c tdir - direct ray travel time c nrtn - index to point of return from raypath c c subrs. called: c c layers - constructs averaged layered model c c stpath - straight raypath c strpath - NOT USED !! straight raypath from event to receiver c c direct - for the direct ray: c salpha, deljl, tdir c dirpath - direct ray path c c reflect1 - for reflected ray c reflect - NOT USED !! for reflected ray c reflectpath - reflected ray path c c refract - for the fastest refracted ray: c kk, didjkk, tref, xovmax c tiddid - travel-time intercept & crit. distance for a ray c refpath - refracted ray path c implicit none integer nx,ny,nz,nl,nrp,nrtn,jl,itype,mll real xe,ye,ze,xr,yr,zr,tkj,ttt,sterr real direrr,refrerr,reflerr,dtddrefl,dtdhrefl integer l,ierr,kk real depth,delta,tdir,salpha,deljl,trefl real ain,tref,didjkk,xovmax real x(nx),y(ny),z(nz),vel(nx,ny,nz) real d(nl),thk(nl),v(nl),vsq(nl) cek max. nr of raypoints =50 real rp(3,200) c 1313 continue ! restart here in case of an error in REFLECT !! c sterr=0.0 direrr=0.0 refrerr=0.0 reflerr=0.0 c if(ze.lt.d(1)) stop'RAYPATH>>> earthquake ABOVE model!' if(zr.lt.d(1)) stop'RAYPATH>>> station ABOVE model!' c depth=ze-zr delta=sqrt((xr-xe)**2+(yr-ye)**2) l=nl continue 23107 if(.not.(d(l).ge.ze))goto 23108 c c determine event layer c l=l-1 goto 23107 23108 continue jl=l d(1)=zr c adjust for nonzero depth of reciever c thk(1)=d(2)-zr tkj=ze-d(jl) if(.not.(delta.lt..05))goto 23105 call stpath(xe,ye,ze,xr,yr,zr,rp,nrp,ttt,nl,jl,tkj,v,d,thk,sterr) c c if delta is small, set a straight path c nrtn=1 return 23105 continue c c assign averaged layer velocities c if(itype.eq.1) go to 1 call layers(nx,ny,nz,x,y,z,vel,xe,ye,xr,yr,nl,v,vsq) 1 continue if(.not.(jl.eq.nl))goto 23109 c c consider only the direct ray if the event is in the half space c call direct1(nl,v,vsq,thk,jl,tkj,delta,depth,tdir,salpha,deljl) call dirpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,jl,tkj, 2 salpha,deljl,rp,nrp,direrr) nrtn=2 ttt=tdir return 23109 continue c c if(mll.le.0)goto 23110 c MLL > 0 : a reflection layer is specified; ray MUST be reflected! ctest call reflect(nl,v,vsq,thk,jl,tkj,delta,depth,mll,trefl,ain,ierr, ctest & DTDDrefl,DTDHrefl) call reflect1(nl,v,vsq,thk,jl,tkj,delta,depth,mll,trefl,ain,ierr, & DTDDrefl,DTDHrefl) if(ierr.ne.0)then write(6,*)'trying another ray-type...' write(16,*)'trying another ray-type...' MLL=0 ! maybe it works with another ray-type... goto 1313 ! retry endif call reflectpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,jl,tkj, & ain,mll,rp,nrp,reflerr) c ttt=trefl nrtn=8 ! reflected wave RETURN 23110 continue c c find the first refracted ray to arrive c call refract(nl,v,vsq,thk,jl,tkj,delta,kk,tref,didjkk,xovmax) if(.not.(delta.gt.xovmax))goto 23111 c for delta greater than xovmax c 1st arrival is the refracted ray c call refpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,tkj,jl, 2 kk,didjkk,rp,nrp,refrerr) nrtn=3 ttt=tref return 23111 continue if(.not.(jl.eq.1))goto 23113 tdir=(sqrt(tkj**2+delta**2))/v(1) if(.not.(tref.lt.tdir))goto 23115 c c if refracted ray is 1st arrival c call refpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,tkj,jl, 2 kk,didjkk,rp,nrp,refrerr) nrtn=4 ttt=tref return 23115 continue c c if direct ray is 1st arrival c call stpath(xe,ye,ze,xr,yr,zr,rp,nrp,ttt,nl,jl,tkj,v,d,thk,sterr) nrtn=5 ttt=tdir return 23113 continue c c for event below layer 1 c call direct1(nl,v,vsq,thk,jl,tkj,delta,depth,tdir,salpha,deljl) if(.not.(tref.lt.tdir))goto 23117 c c if refracted ray is 1st arrival c call refpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,tkj,jl, 2 kk,didjkk,rp,nrp,refrerr) ttt=tref nrtn=6 return 23117 continue c c if direct ray is 1st arrival c call dirpath(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk,jl,tkj, 2 salpha,deljl,rp,nrp,direrr) nrtn=7 ttt=tdir return end ! of subr. raypath c subroutine LAYERS (nx,ny,nz,x,y,z,vel,xe,ye,xr,yr,nl,v,vsq) c c Subr. layers converts a 3 - dimensional velocity model to a c 1 - dimensional layered model by averaging slownesses between c specified event and receiver positions. the input c model must consist of velocities specified at grid c points at the intersections of 3 orthogonal grid planes. c slownesses are averaged along a segment joining the c horizontal event and receiver positions in each grid plane c specified by z(k). c c input: c nx,ny,nz - numbers of grid planes c x(i),y(j),z(k) - grid point coordinates c vel(i,j,k) - velocity at point x(i),y(j),z(k) c xe,ye - horizontal event coordinates c xr,yr - horizontal receiver coordinates c nl - number of layers (should equal nz) c c output: c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c implicit none integer nx,ny,nz,nl real xe,ye,xr,yr real x(nx),y(ny),z(nz),vel(nx,ny,nz),v(nl),vsq(nl) real w(4),u(100) integer i,ie,j,je,ir,jr,imin,jmin,numseg,numpts,l integer ipts,ipoint,jpoint real a,b,c,d,denom,vpt1,vpt2,vpt3,vpt4,vpoint real xseg,yseg,xpoint,ypoint c c locate the event and the reciever within horizontal c grid rectangles c i=1 continue 23119 if(.not.(x(i).lt.xe))goto 23120 i=i+1 goto 23119 23120 continue ie=i-1 if(.not.(ie.eq.0))goto 23121 ie=1 23121 continue j=1 continue 23123 if(.not.(y(j).lt.ye))goto 23124 j=j+1 goto 23123 23124 continue je=j-1 if(.not.(je.eq.0))goto 23125 je=1 23125 continue i=1 continue 23127 if(.not.(x(i).lt.xr))goto 23128 i=i+1 goto 23127 23128 continue ir=i-1 if(.not.(ir.eq.0))goto 23129 ir=1 23129 continue j=1 continue 23131 if(.not.(y(j).lt.yr))goto 23132 j=j+1 goto 23131 23132 continue jr=j-1 if(.not.(jr.eq.0))goto 23133 jr=1 23133 continue imin=min0(ie,ir) jmin=min0(je,jr) c c choose the number of points to use for averaging slownesses c and calculates x and y increments between points c numseg=iabs(ir-ie)+iabs(jr-je)+1 numpts=numseg+1 xseg=(xr-xe)/(numseg*1.0) yseg=(yr-ye)/(numseg*1.0) do 23135l=1,nl u(l)=0 23135 continue 23136 continue c c loop to sum slownesses in each layer, u(l), at points c between the event and the reciever c do 23137ipts=1,numpts xpoint=xe+(ipts-1)*xseg ypoint=ye+(ipts-1)*yseg c c locate (xpoint,ypoint) within a grid rectangle c i=imin continue 23139 if(.not.(xpoint.gt.x(i)))goto 23140 i=i+1 goto 23139 23140 continue ipoint=i-1 if(.not.(ipoint.eq.0))goto 23141 ipoint=1 23141 continue j=jmin continue 23143 if(.not.(ypoint.gt.y(j)))goto 23144 j=j+1 goto 23143 23144 continue jpoint=j-1 if(.not.(jpoint.eq.0))goto 23145 jpoint=1 23145 continue c c choosing weighting factors for interpolation within c a horizontal rectangle on the velocity grid c a=xpoint-x(ipoint) b=x(ipoint+1)-xpoint c=ypoint-y(jpoint) d=y(jpoint+1)-ypoint denom=(a+b)*(c+d) w(1)=b*d/denom w(2)=a*d/denom w(3)=b*c/denom w(4)=a*c/denom c c loop to interpolate for the velocity, vpoint, at c (xpoint,ypoint) in each layer and add its c reciprocal to the sum of the slownesses in that layer c do 23147l=1,nl vpt1=w(1)*vel(ipoint,jpoint,l) vpt2=w(2)*vel(ipoint+1,jpoint,l) vpt3=w(3)*vel(ipoint,jpoint+1,l) vpt4=w(4)*vel(ipoint+1,jpoint+1,l) vpoint=vpt1+vpt2+vpt3+vpt4 u(l)=u(l)+1/vpoint 23147 continue 23148 continue 23137 continue 23138 continue c c loop to calculate the velocity from the sum of the c slownesses for each layer c do 23149l=1,nl v(l)=(numpts*1.0)/u(l) vsq(l)=v(l)**2 23149 continue 23150 continue return end ! of subr. layers c subroutine STPATH(xe,ye,ze,xr,yr,zr,rp,nrp,tt,nl,jl,tkj,v,d,thk, & sterr) implicit none real xe,ye,ze,xr,yr,zr,tt,tkj,sterr integer nrp,nl,jl c integer jl1,j,j1,jb,jt real v(nl),d(nl),thk(nl) c real rp(3,200) nrp=jl+1 c assign points along raypath rp(1,1)=xe rp(2,1)=ye rp(3,1)=ze c if (nrp.eq.2) go to 50 c jl1=jl-1 cuk do 25 j=1,jl1 ! calculate up to the top and then compute an error do 25 j=1,jl1+1 j1=j+1 rp(1,j1)=xe rp(2,j1)=ye jb=jl-j+1 rp(3,j1)=d(jb) 25 continue c 50 continue if(nrp.gt.2)then sterr=sqrt( (rp(1,nrp)-xr)**2 + (rp(2,nrp)-yr)**2 + & (rp(3,nrp)-zr)**2 ) *1000. endif rp(1,nrp)=xr rp(2,nrp)=yr rp(3,nrp)=zr c c compute travel time tt=tkj/v(jl) if (nrp.eq.2) return c do 75 j=1,jl1 jt=jl-j tt=tt+thk(jt)/v(jt) 75 continue return end ! of subr. stpath c subroutine STRPATH (xe,ye,ze,xr,yr,zr,rp,nrp) c c strpath assigns raypoint coordinates for a straight path c between the event and the receiver. c c input: (xe,ye,ze) - event coordinates c (xr,yr,zr) - receiver coordinates c c output: rp(1,2,or 3,i) - coordinates of raypoint i c nrp - number of raypoints = 2 c implicit none real xe,ye,ze,xr,yr,zr integer nrp real rp(3,2) nrp=2 rp(1,1)=xe rp(2,1)=ye rp(3,1)=ze rp(1,2)=xr rp(2,2)=yr rp(3,2)=zr return end ! of subr. strpath c subroutine DIRECT1(nl,v,vsq,thk,jl,tkj,delta,depth,tdir,u,x) c c for the direct seismic ray from an event to a receiver in c a layered velocity structure, direct predicts the travel time, the c sine of the takeoff angle, and the horizontal distance of travel in c the event layer. the receiver must be located at the top of layer c 1 and the event must be located below layer 1. low velocity c layers are permitted. c to find the takeoff angle of the ray, a numerical approach c is required. the basic scheme adopted here is the method of false c position. (see acton, 1970, 'numerical methods that work,' for c example.) first, the characteristics of the fastest layer c between the event and the surface are determined. these permit c placing definite lower and upper bounds, ua and ub, on the c sine of the takeoff angle. in turn, lower and upper bounds, xa c and xb, on the horizontal travel distance in the event layer are c determined. the total horizontal travel distance for a ray with c with horizontal travel distance x in the event layer is denoted c by del, and the zero of del - delta is obtained by using xa and c xb as initial guesses for x in the method of false position c from x and tkj, the depth of the event below the top of the event c layer, the sine of the takeoff angle, u , is calculated. c from u and x, tdir is found by summing the travel time in c each layer. finally, a slight correction to tdir is made, based c on the misfit between the final del and delta. c c input: nl - number of layers c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c thk(l) - thickness of layer l c jl - event layer c tkj - depth of event from top of event layer c delta - horizontal distance between event and receiver c depth - depth of event c c output: tdir - direct ray travel time c u - sine of the takeoff angle c x - horizontal travel distance in the event layer c c c find the fastest layer, lmax, above and including jl c implicit none integer nl,jl real tkj,delta,depth,tdir,u,x real v(nl),vsq(nl),thk(nl) c real del,tklmax,vlmax,ua,ub,uasq,ubsq,usq real xa,xb,dela,delb,ubdiv,xtest integer lmax,j1,l,kount del=0.0 ! U.K. 28. Jan. 1987 c lmax=jl tklmax=tkj vlmax=v(jl) j1=jl-1 do 23184l=1,j1 if(.not.(v(l).gt.vlmax))goto 23186 lmax=l tklmax=thk(l) vlmax=v(l) 23186 continue 23184 continue 23185 continue C CHANGE BY E.KISSLING MARCH 1984 IF(tklmax.le.0.05) tklmax=0.05 c c find initial bounds on the sine of the takeoff angle c ua=(v(jl)/vlmax)*delta/sqrt(delta**2+depth**2) ub=(v(jl)/vlmax)*delta/sqrt(delta**2+tklmax**2) c c calculate horizontal travel distances c uasq=ua**2 ubsq=ub**2 C CHANGE BY E.KISSLING MARCH 1984 IF(UBSQ.GE.1.) UBSQ=0.99999 IF(UASQ.GE.1.) UASQ=0.99999 xa=tkj*ua/sqrt(1.0-uasq) if(.not.(lmax.eq.jl))goto 23188 xb=delta goto 23189 23188 continue xb=tkj*ub/sqrt(1.0-ubsq) 23189 continue dela=xa delb=xb do 23190l=1,j1 dela=dela+thk(l)*ua/sqrt(vsq(jl)/vsq(l)-uasq) ubdiv=sqrt(vsq(jl)/vsq(l)-ubsq) if(ubdiv.GT.1.e-20) GOTO 1002 write(16,*)'WARNING:' write(16,1000) jl,l,lmax,vsq(jl),vsq(l),ubsq,delta,tklmax,vlmax 1000 format(/,2x,'subr. direct1: ',3i4,2f10.4,f15.6,3f10.5,/) ubdiv=1.e-20 1002 continue delb=delb+thk(l)*ub/sqrt(vsq(jl)/vsq(l)-ubsq) 23190 continue 23191 continue ! NOT used... !!! c c loop to find the zero of del-delta by teh method of false position c do 23192kount=1,25 if(.not.((delb-dela).lt.0.02))goto 23194 x=0.5*(xa+xb) u=x/sqrt(x**2+tkj**2) usq=u**2 goto 23193 23194 continue x=xa+(delta-dela)*(xb-xa)/(delb-dela) u=x/sqrt(x**2+tkj**2) usq=u**2 del=x do 23196l=1,j1 del=del+thk(l)*u/sqrt(vsq(jl)/vsq(l)-usq) 23196 continue 23197 continue xtest=del-delta if(.not.(abs(xtest).lt.0.02))goto 23198 goto 23193 23198 continue if(.not.(xtest.lt.0.0))goto 23200 xa=x dela=del goto 23201 23200 continue xb=x delb=del 23201 continue 23192 continue 23193 continue c c calculate direct ray travel time c c if(del.eq.0.0) del=x ! U.K. 28. Jan. 1987 c tdir=(sqrt(x**2+tkj**2))/v(jl) do 23202l=1,j1 tdir=tdir+thk(l)*v(jl)/(vsq(l)*sqrt(vsq(jl)/vsq(l)-usq)) 23202 continue 23203 continue tdir=tdir-(u/v(jl))*(del-delta) return end ! of subr. direct1 c subroutine DIRPATH (xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk, &jl,tkj,salpha,deljl,rp,nrp,direrr) c c dirpath assigns raypoints with coordinates rp(1,i),rp(2,i), c rp(3,i) along a direct seismic raypath in a flat layered earth. c c input: xe,ye,ze - event coordinates c xr,yr,zr - receiver coordinates c delta - horizontal distance between event and receiver c nl - total number of layers in model c (used only to dimension v vsq and thk) c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c thk(l) - thickness of layer l c jl - event layer c tkj - depth of event from top of event layer c salpha - sine of takeoff angle c deljl - horizontal travel distance in event layer c c output: rp(1,2,or 3,i) - raypoint coordinates c nrp - number of raypoints c implicit none real xe,ye,ze,xr,yr,zr,delta,tkj,salpha,deljl real direrr integer nl,jl,nrp,nrp1,i,m real d1,d2,tng cek max. nr of raypoints =50 real v(nl),thk(nl),vsq(nl),rp(3,200) d1=(xr-xe)/delta d2=(yr-ye)/delta nrp=jl+1 c c assign raypoint coordinates c rp(1,1)=xe rp(2,1)=ye rp(3,1)=ze rp(1,2)=rp(1,1)+deljl*d1 rp(2,2)=rp(2,1)+deljl*d2 rp(3,2)=rp(3,1)-tkj cuk nrp1=nrp-1 nrp1=nrp ! calculate up to the top and then compute an error ! do 23208i=3,nrp1 m=nrp-(i-1) c c m is the number of the layer below ray point i c tng=v(m)*salpha/sqrt(vsq(jl)-vsq(m)*salpha**2) c c tng is the tangent of the angle of incidence in layer m c rp(1,i)=rp(1,i-1)+thk(m)*tng*d1 rp(2,i)=rp(2,i-1)+thk(m)*tng*d2 rp(3,i)=rp(3,i-1)-thk(m) 23208 continue 23209 continue direrr=sqrt( (rp(1,nrp)-xr)**2 + (rp(2,nrp)-yr)**2 + & (rp(3,nrp)-zr)**2 ) *1000. rp(1,nrp)=xr rp(2,nrp)=yr rp(3,nrp)=zr return end ! of subr. dirpath c subroutine REFLECT1(nl,v,vsq,thk,jl,tkj,delta,z,mll,trefl,ain, & ierr,DTDDrefl,DTDHrefl) c c Urs Kradolfer, Nov. 1986 c implicit none c integer nl,ierr real tkj,trefl,dtddrefl,dtdhrefl c integer m,lmax,j1,l,kount real del, fac,depth,tklmax,vlmax,ua,ub,uasq,ubsq real xa,xb,dela,delb,ubdiv,x,u,usq real xtest,tdir integer jl ! hypocenter-layer integer mll ! reflection at bottom of layer MLL real thk(nl),v(nl),vsq(nl) real div(100) ! dimension = max. number of layers allowed real ain ! auftauchwinkel in rad real z ! hypocenter-depth real delta ! distance epicenter-receiver integer i c ierr=0 DTDDrefl=0.0 DTDHrefl=0.0 c c del=0.0 ! U.K. 28. Jan. 1987 c if(jl.gt.mll)then ! hypocenter below reflector !!! write(6,*)'hypocenter-layer jl = ',jl write(6,*)'reflection at bottom of layer mll = ',mll ierr=-1 write(6,*)'WARNING:' write(6,*)'subr. REFLECT1 >>> hypocenter is below reflector!' write(16,*)'WARNING:' write(16,*)'subr. REFLECT1 >>> hypocenter is below reflector!' ccc stop'subr. REFLECT1 >>> hypocenter below reflector!' endif if(mll.gt.nl)then stop'subr. REFLECT1 >>> reflector-nr > number of layers !' endif c c determine out of real model (THK) transformed model (DIV) c DO M=1,MLL C LAYER M IS PASSED ONLY ONCE: FAC= 1. IF(JL.GT.M) GOTO 505 C LAYER M IS PASSED TWICE FAC= 2. IF(JL.LT.M) GOTO 505 C LAYER M CONTAINS HYPOCENTER: FAC= (2.*THK(M)-tkj)/THK(M) 505 DIV(M)= FAC*THK(M) enddo depth=0.0 do i=1,mll depth=depth+div(i) enddo c c c now 'new' model is established; layer-thicknesses are stored in DIV(1...mll) c lmax=mll tklmax=div(mll) vlmax=v(mll) j1=mll-1 do 23184l=1,j1 if(.not.(v(l).gt.vlmax))goto 23186 lmax=l tklmax=div(l) vlmax=v(l) 23186 continue 23184 continue 23185 continue C CHANGE BY E.KISSLING MARCH 1984 IF(tklmax.le.0.05) tklmax=0.05 c c find initial bounds on the sine of the takeoff angle c ua=(v(mll)/vlmax)*delta/sqrt(delta**2+depth**2) ub=(v(mll)/vlmax)*delta/sqrt(delta**2+tklmax**2) c c calculate horizontal travel distances c uasq=ua**2 ubsq=ub**2 C CHANGE BY E.KISSLING MARCH 1984 IF(UBSQ.GE.1.) UBSQ=0.99999 IF(UASQ.GE.1.) UASQ=0.99999 xa=div(mll)*ua/sqrt(1.0-uasq) if(.not.(lmax.eq.mll))goto 23188 xb=delta goto 23189 23188 continue xb=div(mll)*ub/sqrt(1.0-ubsq) 23189 continue dela=xa delb=xb do 23190l=1,j1 dela=dela+div(l)*ua/sqrt(vsq(mll)/vsq(l)-uasq) ubdiv=sqrt(vsq(mll)/vsq(l)-ubsq) if(ubdiv.GT.1.e-20) GOTO 1002 write(16,*)'WARNING:' write(16,1000) mll,l,lmax,vsq(mll),vsq(l),ubsq,delta,tklmax,vlmax 1000 format(/,2x,'subr. reflect1: ',3i4,2f10.4,f15.6,3f10.5,/) ubdiv=1.e-20 1002 continue delb=delb+div(l)*ub/sqrt(vsq(mll)/vsq(l)-ubsq) 23190 continue 23191 continue ! NOT used... !!! c c loop to find the zero of del-delta by teh method of false position c do 23192kount=1,25 if(.not.((delb-dela).lt.0.02))goto 23194 x=0.5*(xa+xb) u=x/sqrt(x**2+div(mll)**2) usq=u**2 goto 23193 23194 continue x=xa+(delta-dela)*(xb-xa)/(delb-dela) u=x/sqrt(x**2+div(mll)**2) usq=u**2 del=x do 23196l=1,j1 del=del+div(l)*u/sqrt(vsq(mll)/vsq(l)-usq) 23196 continue 23197 continue xtest=del-delta if(.not.(abs(xtest).lt.0.02))goto 23198 goto 23193 23198 continue if(.not.(xtest.lt.0.0))goto 23200 xa=x dela=del goto 23201 23200 continue xb=x delb=del 23201 continue 23192 continue 23193 continue c c calculate direct ray travel time c c if(del.eq.0.0) del=x ! U.K. 28. Jan. 1987 c tdir=(sqrt(x**2+div(mll)**2))/v(mll) do 23202l=1,j1 tdir=tdir+div(l)*v(mll)/(vsq(l)*sqrt(vsq(mll)/vsq(l)-usq)) 23202 continue 23203 continue tdir=tdir-(u/v(mll))*(del-delta) c trefl=tdir c---- u is sine of the 'takeoff-angle' in c---- transformed model = emerging angle at reflector! c---- Find now takeoff-angle at source! ain=u if(mll.gt.jl)then do i=mll-1,jl,-1 ain=ain * v(i)/v(i+1) enddo endif c return end ! of subr. reflect1 c subroutine REFLECT(nl,v,vsq,thk,jl,tkj,delta,z,mll,trefl,ain,ierr, & DTDDrefl,DTDHrefl) c c Urs Kradolfer, Nov. 1986 c implicit none integer nl,ierr real tkj,trefl,ain,dtddrefl,dtdhrefl c integer nit,m real zbig,fac,a,sina,dellit,dddas,sqr,ddda,da,da2 real tt,dtda,ti,dti,dtdd,sina2,dtdh integer jl ! hypocenter-layer integer mll ! reflection at bottom of layer MLL real thk(nl),v(nl),vsq(nl) real vsqu(100),vi(100),div(100) ! dimension = max. number of layers allowed real anin ! auftauchwinkel in rad real test4 ! iterate until hypoc-adjustments are less than (TEST4)**-2 real z ! hypocenter-depth real delta ! distance epicenter-receiver integer i real sum c ierr=0 DTDDrefl=0.0 DTDHrefl=0.0 c test4=0.01 ! see HYMD01.DAT do i=1,nl vi(i)=1./v(i) enddo c c---- determine, which layer contains hypocenter 10 sum=0.0 do jl=1,nl sum=sum+thk(jl) if(z.le.sum)goto 19 enddo c---- hypocenter is in the halfspace: jl=nl tkj=z-sum if(jl.eq.0) goto 10 goto 20 19 tkj=z-sum+thk(jl) goto 20 20 continue c hypocenter is TKJ [km] below top of hypoc-layer c JL is the hypocenter layer c if(jl.gt.mll)then ! hypocenter below reflector !!! ierr=-1 write(6,*)'WARNING:' write(6,*)'subr. REFLECT >>> hypocenter is below reflector!' write(16,*)'WARNING:' write(16,*)'subr. REFLECT >>> hypocenter is below reflector!' ccc stop'subr. REFLECT >>> hypocenter below reflector!' endif if(mll.gt.nl)then stop'subr. REFLECT >>> reflector-nr > number of layers !' endif c C C CALCULATE REFLECTED WAVES C NIT= 0 ZBIG= TKJ SUM= 0.0 DO M=1,MLL C LAYER M IS PASSED ONLY ONCE: FAC= 1. IF(JL.GT.M) GOTO 505 C LAYER M IS PASSED TWICE FAC= 2. IF(JL.LT.M) GOTO 505 C LAYER M CONTAINS HYPOCENTER: FAC= (2.*THK(M)-ZBIG)/THK(M) 505 DIV(M)= FAC*THK(M) VSQU(M)= VSQ(MLL)/VSQ(M) SUM= SUM+DIV(M) enddo C ITERATE TO FIND EMERGING ANGLE FOR THE GIVEN DISTANCE: A= ATAN2(delta,SUM) 515 SINA= SIN(A) if(sina.eq.1.00) sina=0.9999999 SINA2= SINA*SINA DELLIT= 0. DDDAS= 0. DO M=1,MLL SQR= VSQU(M)-SINA2 c if(sqr.le.0)then write(16,*)'WARNING: subr. REFLECT' write(16,*)'probably a low velocity layer detected!' write(16,*)'sina=',sina write(16,*)'sina2=',sina2 write(16,*)'VSQU(M): vsqu(',m,')=',vsqu(m) write(16,*)'MLL=',mll write(16,*)'JL=',jl write(6,*)'sina=',sina write(6,*)'sina2=',sina2 write(6,*)'VSQU(M): vsqu(',m,')=',vsqu(m) write(6,*)'MLL=',mll write(6,*)'JL=',jl write(6,*) endif c c!!!!! if(sqr.le.0.) goto 530 !auftauchwinkel gefunden c sina2 is always < 1 ; c vsqu is always > 1 if no velocity-layers are above the event-layer !! DDDA= DIV(M)/SQRT(SQR) DELLIT= DELLIT+DDDA DDDAS= DDDAS+VSQU(M)*DDDA/SQR enddo DELLIT= DELLIT*SINA DDDAS= DDDAS*COS(A) DA= DELLIT-delta DA2= DA*DA IF(DA2.LE.TEST4) GOTO 530 NIT= NIT+1 cuk IF(NIT.LT.15) GOTO 525 IF(NIT.LT.50) GOTO 525 c WRITE(6,524) delta c 524 FORMAT(' REFLECTED WAVE DID NOT CONVERGE WITHIN', c 1' 50 ITERATIONS AT DISTANCE:',F8.1, c 2' SET WEIGHT TO 0') GOTO 27 525 A= A-DA/DDDAS if(a.ge.1.570796) a=1.5 ! 1.5 ~ 86 deg ; a = never .gt. pi/2. !!! GOTO 515 c---- successful iteration: 530 TT=0. DTDA= 0. DO M=1,MLL TI= DIV(M)*VI(M)/SQRT(1.-SINA2/VSQU(M)) DTI= TI/(VSQU(M)-SINA2) TT= TT+TI DTDA= DTDA+DTI enddo DTDA= DTDA*SINA*COS(A) DTDD= DTDA/DDDAS DTDH= -(1.-V(JL)*SINA*DTDD)/(V(JL)*SQRT(1.-SINA2)) ANIN= SINA GOTO 260 C------- IF NOT POSSIBLE, SET P + S WEIGHTS TO ZERO 27 continue write(16,*)'WARNING:' write(16,*)'Reflected wave did not converge within 50 iterations!' write(16,*)'---> trying another ray-type ...' write(6,*)'Reflected wave did not converge within 50 iterations!' write(6,*)'sina=',sina,' delta=',delta write(6,*)'da=',da,' da2=',da2,' test4=',test4 write(6,*)'---> trying another ray-type ...' write(6,*) ierr=50 return cc stop'STOP in subr. REFLECT >>> nit > 50' c 260 continue c---- anin is emerging angle at reflector; find now takeoff-angle at source! ain=anin if(mll.gt.jl)then do i=mll-1,jl,-1 ain=ain * v(i)/v(i+1) enddo endif trefl=tt DTDDrefl=dtdd dtdhrefl=dtdh cc wain=57.29578*asin(ain) cc write(6,*)'takeoff angle = ',wain return c end ! of subr. reflect c subroutine REFLECTPATH(xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk, &jl,tkj,ain,mll,rp,nrp,reflerr) c c Urs Kradolfer, Nov. 1986 c c reflectpath assigns raypoints with coordinates rp(1,i),rp(2,i), c rp(3,i) along a reflected seismic raypath in a flat layered earth. c c input: xe,ye,ze - event coordinates c xr,yr,zr - receiver coordinates c delta - horizontal distance between event and receiver c nl - total number of layers in model c (used only to dimension v vsq and thk) c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c thk(l) - thickness of layer l c jl - event layer c tkj - depth of event from top of event layer c ain - sine of takeoff angle (with respect to downward vertical) c mll - reflector is bottom of layer MLL c c output: rp(1,2,or 3,i) - raypoint coordinates c nrp - number of raypoints c c max. nr of raypoints =50 c implicit none c real xe,ye,ze,xr,yr,zr,delta,tkj,ain,reflerr integer nl,jl,mll,nrp c real d1,d2,salpha,tng,deljl integer m,ld,j,i real v(nl),thk(nl),vsq(nl),rp(3,200) c d1=(xr-xe)/delta d2=(yr-ye)/delta nrp=jl+1+(mll-jl)*2+1 c salpha=ain c c assign raypoint coordinates c rp(1,1)=xe rp(2,1)=ye rp(3,1)=ze c tng=tan(asin(salpha)) ! compiler produces warning with range checking tng=asin(salpha) tng=tan(tng) ! must be defined here; in case ld is zero deljl=tng*(thk(jl)-tkj) !horiz. travel distance in ev.layer rp(1,2)=rp(1,1)+deljl*d1 rp(2,2)=rp(2,1)+deljl*d2 rp(3,2)=rp(3,1)+(thk(jl)-tkj) c---- now arrived at bottom of event-layer m=jl ld=mll-jl ! nr of layer to go down to reflector j=2 do i=1,ld j=j+1 m=jl+i tng=v(m)*salpha/sqrt(vsq(jl)-vsq(m)*salpha**2) rp(1,j)=rp(1,j-1)+thk(m)*tng*d1 rp(2,j)=rp(2,j-1)+thk(m)*tng*d2 rp(3,j)=rp(3,j-1)+thk(m) ! ray is going downward enddo c---- now arrived down at reflector; going upward from now on if(m.ne.mll)stop'subr. REFLECTPATH >>> Error in ray-path...' j=j+1 deljl=tng*thk(m) ! horiz. travel-distance in lowest layer rp(1,j)=rp(1,j-1)+deljl*d1 rp(2,j)=rp(2,j-1)+deljl*d2 rp(3,j)=rp(3,j-1)-thk(m) c---- now arrived at top of lowest layer c---- going up to top of model: c do i=j+1,nrp-1 if one would raytrace only to the second-last point c in order to calculate an error, we calculate up to the receiver: do i=j+1,nrp m=m-1 c c m is the number of the layer below ray point i c tng=v(m)*salpha/sqrt(vsq(jl)-vsq(m)*salpha**2) c c tng is the tangent of the angle of incidence in layer m c rp(1,i)=rp(1,i-1)+thk(m)*tng*d1 rp(2,i)=rp(2,i-1)+thk(m)*tng*d2 rp(3,i)=rp(3,i-1)-thk(m) enddo c reflerr=sqrt( (rp(1,nrp)-xr)**2 + (rp(2,nrp)-yr)**2 + & (rp(3,nrp)-zr)**2 ) *1000. cc write(6,*)'REFLECTPATH: raytracer-error was : ',reflerr,' meter' c---- now assign the correct receiver-coordinates to the last raypoint: rp(1,nrp)=xr rp(2,nrp)=yr rp(3,nrp)=zr return end ! of subr. reflectpath c subroutine REFRACT (nl,v,vsq,thk,jl,tkj,delta, &kk,tref,didjkk,xovmax) c c for refracted rays in a layered earth model, refract c determines the fastest travel time, tref, the layer c in which the fastest ray is refracted, kk, the c critical distance for refraction in that layer, c didjkk, and an upper bound on delta for which a c direct ray can be a first arrival, xovmax. refract c allows for the possibility of low velocity layers. c note that there may not be a refracted ray, either because c all layers below the event layer are low velocity layers or c because for all layers below the event layer which are not low c velocity layers the critical distance exceeds delta. in such c cases tref, didjkk, and xovmax are set very large, kk is set to c zero, and refract returns to the calling program. c c input: nl - number of layers c v(l) - velocity of layer l c vsq(l) - v(l) ** 2 c thk(l) - thickness of layer l c jl - event layer c tkj - depth of event in event layer c delta - horizontal distance between event and receiver c c output: kk - refracting layer for fastest refracted ray c tref - travel time of fastest refracted ray c didjkk - critical distance for refraction in layer kk c xovmax - an upper bound on delta for which the direct ray can c be the first arrival c internal arrays: c c tr(m) - travel time for refraction in layer m c tinj(m) - traveltime intercept c tid(m) - terms in travel time intercept which are c independent of tkj c didj(m) - critical distance c did(m) - terms in critical distance which are c independent of tkj c c c call subr. tiddid to evaluate tid(m) and c did(m), the terms in the travel time intercept and c critical distance for a ray refracted in layer m c which are independent of tkj. c c c determine tref, kk, didjkk c implicit none c integer nl,jl,kk,j1,m,lx,m1,l,jx real tkj,delta,tref,didjkk,xovmax real sqt,tim real v(nl),vsq(nl),thk(nl) real tid(100),did(100),tinj(100),didj(100),tr(100) call tiddid(jl,nl,v,vsq,thk,tid,did) tref=100000. j1=jl+1 do 23151m=j1,nl if(.not.(tid(m).eq.100000.))goto 23153 tr(m)=100000. goto 23154 23153 continue sqt=sqrt(vsq(m)-vsq(jl)) tinj(m)=tid(m)-tkj*sqt/(v(m)*v(jl)) didj(m)=did(m)-tkj*v(jl)/sqt tr(m)=tinj(m)+delta/v(m) if(.not.(didj(m).gt.delta))goto 23155 tr(m)=100000. 23155 continue 23154 continue if(.not.(tr(m).lt.tref))goto 23157 tref=tr(m) kk=m didjkk=didj(kk) 23157 continue 23151 continue 23152 continue c c if there is no refracted ray: c if(.not.(tref.eq.100000.))goto 23159 didjkk=100000. xovmax=100000. kk=0 return 23159 continue c c if there is a refracted ray, determine xovmax: c find lx, the 1st layer below the event layer which c is not a low velocity layer c m=jl+1 continue 23161 if(.not.(tid(m).eq.100000.))goto 23162 m=m+1 goto 23161 23162 continue lx=m c c check whether the event is in the 1st layer c if(.not.(jl.eq.1))goto 23163 xovmax=tinj(lx)*v(lx)*v(1)/(v(lx)-v(1)) return 23163 continue m=jl c c find jx, the 1st layer above and including the event c layer which is not a low velocity layer c continue 23165 continue tid(m)=0. m1=m-1 do 23168l=1,m1 if(.not.(vsq(m).le.vsq(l)))goto 23170 tid(m)=100000. goto 23171 23170 continue sqt=sqrt(vsq(m)-vsq(l)) tim=thk(l)*sqt/(v(l)*v(m)) tid(m)=tid(m)+tim 23171 continue 23168 continue 23169 continue m=m-1 c c decide whether or not jx=1 and calculate xovmax c 23166 if(.not.(tid(m+1).lt.100000..or.m.eq.1))goto 23165 23167 continue if(.not.(tid(m+1).lt.100000.))goto 23172 jx=m+1 xovmax=(tinj(lx)-tid(jx))*v(lx)*v(jx)/(v(lx)-v(jx)) goto 23173 23172 continue c c jx=1 c xovmax=tinj(lx)*v(lx)*v(1)/(v(lx)-v(1)) 23173 continue return end ! of subr. refract c subroutine TIDDID (jl,nl,v,vsq,thk,tid,did) c c tiddid determines the travel time intercept and critical c distance for a seismic ray in a layered earth model c originating at the top of layer jl, refracting in c layer m, and terminating at the top of layer 1. c c input: jl - event layer c nl - number of layers c v(l) - velocity of layer l c vsq(l) - velocity squared c thk(l) - thickness of layer l c output: c tid(m) - travel time intercept for c refraction in layer m c did(m) - critical distance c implicit none c integer jl,nl c integer j1,m,m1,l real tid1,tid2,did1,did2,sqt,tim,dimm real v(nl),vsq(nl),thk(nl) real tid(100),did(100) j1=jl+1 do 23174m=j1,nl tid(m)=0. did(m)=0. tid1=0. tid2=0. did1=0. did2=0. m1=m-1 do 23176l=1,m1 if(.not.(vsq(m).le.vsq(l)))goto 23178 c c if m is a low velocity layer, set tid and did to c very large values c tid(m)=100000. did(m)=100000. goto 23179 23178 continue sqt=sqrt(vsq(m)-vsq(l)) tim=thk(l)*sqt/(v(l)*v(m)) dimm=thk(l)*v(l)/sqt if(.not.(l.lt.jl))goto 23180 c c sum for layers above event layer c tid1=tid1+tim did1=did1+dimm goto 23181 23180 continue c c sum for layers below and including the event layer c tid2=tid2+tim did2=did2+dimm 23181 continue 23179 continue 23176 continue 23177 continue if(.not.(tid(m).ne.100000.))goto 23182 c c calculate tid and did if m is not a low velocity layer c tid(m)=tid1+2*tid2 did(m)=did1+2*did2 23182 continue 23174 continue 23175 continue return end ! of subr. tiddid c subroutine REFPATH (xe,ye,ze,xr,yr,zr,delta,nl,v,vsq,thk, &tkj,jl,kk,didjkk,rp,nrp,refrerr) c c refpath assigns raypaths with coordinates rp(1,i), rp(2,i), c rp(3,i) along a refracted seismic raypath in a flat layered earth. c c input: xe,ye,ze - event coordinates c xr,yr,zr - receiver coordinates c delta - horizontal distance between the event c and the receiver c nl - total number of layers in model c (used only to dimension v, vsq, and thk) c v(l) - velocity of layer l c vsq(l) = v(l) ** 2 c thk(l) - thickness of layer l c jl - event layer c tkj - depth of event from top of event layer c kk - refracting layer c didjkk - critical distance for the refracted ray c c output: rp(1,2,or 3,i) - raypoint coordinates c nrp - number of raypoints c cek max. nr of raypoints =50 c implicit none c real xe,ye,ze,xr,yr,zr,delta,tkj,didjkk,refrerr integer nl,jl,kk,nrp c real thkjl,d1,d2,tng integer nrpd,i,m,nrp1,nrpd2 real v(nl),thk(nl),vsq(nl),rp(3,200) thkjl=thk(jl) c c d1 and d2 are the x and y directions of the raypath c d1=(xr-xe)/delta d2=(yr-ye)/delta nrpd=kk-jl+1 c c nrpd= number of raypoints in down-going part of ray path c nrp=nrpd+kk c c down-going part of path c thk(jl)=thkjl-tkj rp(1,1)=xe rp(2,1)=ye rp(3,1)=ze c m is the number of the layer above raypoint i c do 23204 i=2,nrpd m=jl+i-2 c c tng is the tangent of the incident angle in layer m c tng=v(m)/sqrt(vsq(kk)-vsq(m)) rp(1,i)=rp(1,i-1)+thk(m)*tng*d1 rp(2,i)=rp(2,i-1)+thk(m)*tng*d2 rp(3,i)=rp(3,i-1)+thk(m) 23204 continue 23205 continue c c up-going part of path c rp(1,nrpd+1)=rp(1,nrpd)+(delta-didjkk)*d1 rp(2,nrpd+1)=rp(2,nrpd)+(delta-didjkk)*d2 rp(3,nrpd+1)=rp(3,nrpd) thk(jl)=thkjl nrp1=nrp-1 c c nrpd2 is the number of the raypoint at the c top of layer (kk-1) c nrpd2=nrpd+2 cuk do 23206i=nrpd2,nrp1 do 23206 i=nrpd2,nrp1+1 ! calculate up to the top, then compute error !! c c m is the number of the layer below raypoint i c m=(kk-1)-(i-nrpd2) c c tng is the tangent of the incidence angle in layer m c tng=v(m)/sqrt(vsq(kk)-vsq(m)) rp(1,i)=rp(1,i-1)+thk(m)*tng*d1 rp(2,i)=rp(2,i-1)+thk(m)*tng*d2 rp(3,i)=rp(3,i-1)-thk(m) 23206 continue c refrerr=sqrt( (rp(1,nrp)-xr)**2 + (rp(2,nrp)-yr)**2 + & (rp(3,nrp)-zr)**2 ) *1000. rp(1,nrp)=xr rp(2,nrp)=yr rp(3,nrp)=zr return end ! of subr. refpath c cek end of vel_ray.f c cek begin of vel_tools.f c subroutine CASEFOLD(cn) ! Urs Kradolfer, 20. Feb. 1990 c c Input : character-string of any length c Output: same character-string, but all letters are CAPITAL now c (other characters are not changed) c c --> this subr. needs the function TRIMLEN ! c c Call : call CASEFOLD(charstring) c implicit none character cn*(*) integer i, trimlen,ilen, ival ilen=trimlen(cn) do i=1,ilen ival=ICHAR(cn(i:i)) if(ival.ge.97.and.ival.le.122)then cn(i:i)=CHAR(ival-32) endif enddo RETURN end ! of subr. casefold c c subroutine delaz_velest(alat,alon,blat,blon,del,dist,az) c c computes distance and azimuth from a to b c a and b are in decimal degrees and n-e coordinates c del -- delta in degrees c dist -- distance in km c az -- azimuth from a to b clockwise from north in degrees c implicit none real alat,alon,blat,blon,del,dist,az c real aa,bb,bc,olat,olon,sint,cost,rotate common/corect/ aa,bb,bc,olat,olon common/coords/ sint,cost,rotate COMMON/ORIGI/ REARTH,ELLIP,RLATC,RAD ! neu DOUBLE PRECISION REARTH,ELLIP,RLATC,RAD ! neu c cc double precision pi2,rad,flat double precision pi2, flat double precision alatr,alonr,blatr,blonr double precision tana,geoa,acol,tanb,geob,bcol double precision diflon,cosdel,delr,top,den,azr,colat,radius double precision dtan,datan,dsin,dcos,dacos,datan2 data pi2/1.570796d0/ cc data rad/1.745329d-02/ ! defined in subr. SETORG calt data flat/.993231d0/ ctest data flat/.99330647d0/ ! neu wie in setorg ccc call setorg(orlat,orlon) ! is called separately !! flat=rlatc !!! from subr. SETORG c-----convert to radians alatr=alat*rad alonr=alon*rad blatr=blat*rad blonr=blon*rad c-----convert latitudes to geocentric colatitudes tana=flat*dtan(alatr) geoa=datan(tana) acol=pi2-geoa tanb=flat*dtan(blatr) geob=datan(tanb) bcol=pi2-geob c-----calculate delta diflon=blonr-alonr cosdel=dsin(acol)*dsin(bcol)*dcos(diflon)+dcos(acol)* &dcos(bcol) delr=dacos(cosdel) c-----calculate azimuth from a to b top=dsin(diflon) den=(dsin(acol)/dtan(bcol))-dcos(diflon)*dcos(acol) azr=datan2(top,den) c----- convert to degrees del=delr/rad az=azr/rad if(az.lt.0.0) az=360.+az c-----compute distance in kilometers colat=pi2-(alatr+blatr)/2.d0 cold radius=6371.277d0* cold & (1.d0+(3.37853d-3)*((1.d0/3.d0)-((dcos(colat))**2))) radius=6378.163d0* ! neu wie in setorg & (1.d0+(3.35278d-3)*((1.d0/3.d0)-((dcos(colat))**2))) ! neu wie in setorg dist=delr*radius return c c 1/298.26 = 0.0033527795 = flattening ( WGS72 ) c end ! of subr. delaz c subroutine GEOKO(x,y,xlat,xlon,i) ! Urs Kradolfer, 24.3.87 c -> 1 c <- -1 c c Conversion of Swiss-coordinates X,Y [km] to LAT,LON [deg] i = +1 c Conversion of LAT,LON [deg] to Swiss-coordinates X,Y [km] i = -1 c implicit none real x,y,xlat,xlon integer i real seichmy if(.not.(i.eq.1.or.i.eq.-1)) stop'GEOKO>>> specify conversion !!!' c if(i.eq.1) call EBELL(x,y,xlon,xlat,seichMY) if(i.eq.-1) call ELLEB(xlon,xlat,x,y) c end c subroutine ELLEB(L,B,x,y) implicit none real b,x,y REAL L C C SCHWEIZ. PROJEKTIONSSYSTEM FORMELN VON H. ODERMATT C TRANSFORMATION ELLIPSOID - EBENE C L,B UNTERSCHIEDE IN LAENGE UND BREITE ZU BERN (SEXAG.SEK.) C Y,X LANDESKOORDINATEN IN METER ( BERN 0/0) C MY MERIDIANKONVERGENZ ( SEXAG. SEK.) C integer i DOUBLE PRECISION D(5),E(5),F(5),RW(5),IW(5),P,Q,A,C,bb,bl DATA BB,BL/169028.66,26782.5/ A= L*3600.-BL C= B*3600.-BB D(1)= 0.68382546262761 E(1)= 2.363591607471D-2 D(2)=-3.91798328045D-8 E(2)= 0. D(3)= 1.4965410352D-15 E(3)= 4.527219881D-17 D(4)=-8.039471422D-23 E(4)=-3.89081120D-24 D(5)= 7.0021390D-30 E(5)= 2.3407700D-31 F(1)= 4.515344386039D1 F(2)= 1.17912305209D-4 F(3)= 5.8474201864D-10 F(4)= 2.73386187D-15 F(5)= 1.4308547D-20 C P=30.91849390613 * A Q=C*F(5) I=5 1 I=I-1 Q=C*(Q+F(I)) IF(I.GT.1) GOTO 1 C RW(1)=Q IW(1)=P DO 2 I=2,5 RW(I)=Q*RW(I-1)-P*IW(I-1) IW(I)=P*RW(I-1)+Q*IW(I-1) 2 CONTINUE C y=D(5)*RW(5) x=D(5)*IW(5) I=5 3 I=I-1 y=y+D(I)*RW(I) x=x+D(I)*IW(I) IF(I.GT.1) GOTO 3 y= y/1000.+200. ! output in kilometers x= x/1000.+600. C RETURN END ! of subr. ELLEB c subroutine EBELL(YL,XB,L,B,MY) C C SCHWEIZ. PROJEKTIONSSYSTEM FORMELN VON H. ODERMATT C TRANSFORMATION EBENE ELLIPSOID C YL,XB LANDESKOORDINATEN IN METER (BERN 600/200) C L,B LAENGE UND BREITE (GRAD) C MY MERIDIEANKONVERGENZ (SEXAG.SEK.) C implicit none REAL YL,XB,L,B,MY integer i DOUBLE PRECISION A(8),BB(8),C(8),RZ(8),QZ(8),P,Q,X,Y,DB,DL cccc dimension A(8),BB(8),C(8),RZ(8),QZ(8) cccc real P,Q,X,Y,DB,DL C X=1000.*XB-200000. Y=1000.*YL-600000. C A(1)=1.4623614572021 BB(1)=3.4564252673326D-2 A(2)=1.225255821052D-7 BB(2)=2.89600437564D-9 A(3)=1.3687923002D-14 BB(3)=4.651046030D-16 A(4)=1.971224191D-21 BB(4)=6.43850954D-23 A(5)=2.97898051D-28 BB(5)=9.600412D-30 A(6)=4.650273D-35 BB(6)=1.50512D-36 C A(7)=7.48203D-42 A(7)=0.D00 C BB(7)=2.422D-43 BB(7)=0.D00 C A(8)=1.229D-48 A(8)=0.D00 C(1)= 2.2146704979846D-2 C(2)=-1.280815253730D-9 C(3)= 7.4775676024D-18 C(4)= 4.691943327D-24 C(5)=-3.6550101D-31 C(6)= 3.71615D-39 C C(7)= 1.6901D-45 C(7)= 0.D00 C C(8)= 1.96D-52 C(8)= 0.D00 RZ(1)= X QZ(1)= Y cuk DO 1 I=2,8 ! sufficiant to loop until 6 only do 1 I=2,6 ! otherwise VAX has an overflow... RZ(I)= X*RZ(I-1)-Y*QZ(I-1) QZ(I)= Y*RZ(I-1)+X*QZ(I-1) 1 CONTINUE I=8 Q=A(I)*RZ(I) P=A(I)*QZ(I) MY=0. 2 I=I-1 Q=Q+A(I)*RZ(I) P=P+A(I)*QZ(I) MY=MY+BB(I)*QZ(I) IF(I.GT.1) GOTO 2 DL=3.2343101932327D-2 * P DB=Q*C(8) I=8 3 I=I-1 DB=Q*(DB+C(I)) IF(I.GT.1) GOTO 3 C cc write(6,*)'vor L= und B= in subr. ebell!' L=(DL + 26782.5D00)/3600. B=(DB + 169028.66D00)/3600. RETURN END ! of subr. EBELL c subroutine SDC(x,y,xlat,xlon,i) ! 7. Jan. 1988 c c SDC needs subroutines SETORG, DIST and REDIST c c implicit none real x,y,xlat,xlon integer i c real olat,olon,aa,bb,bc,sint,cost,rotate integer icoordsystem common/GEO_COORSYSTEM/olat,olon, & rearth,ellip,rlatc,rad, & aa,bb,bc,sint,cost,rotate, icoordsystem double precision rearth,ellip,rlatc,rad c c cc call setorg() ! is called separately !! c if(.not.(i.eq.-1.or.i.eq.1)) stop'SDC>>> specify conversion !!!' c if(i.eq.1) call redist(x,y,xlat,xlon) if(i.eq.-1) call dist(xlat,xlon,x,y) c end ! of subr. SDC c subroutine DIST(xlat,xlon,xkm,ykm) ! 7. Jan. 1988 c implicit none real xlat,xlon,xkm,ykm c real olat,olon,aa,bb,bc,sint,cost,rotate real q,yp,xx integer icoordsystem common/GEO_COORSYSTEM/olat,olon, & rearth,ellip,rlatc,rad, & aa,bb,bc,sint,cost,rotate, icoordsystem double precision rearth,ellip,rlatc,rad c DOUBLE PRECISION LAT1,LAT2,LAT3 c conversion of latitude and longitude to kilometers relative c to center of coordinates c q=60*xlat-olat yp=q+olat lat1=datan(rlatc*dtan(RAD*yp/60.0)) lat2=datan(rlatc*dtan(RAD*OLAT/60.0)) LAT3=(LAT2+LAT1)/2. xx=60*xlon-olon q=q*aa xx=xx*bb*dcos(LAT3) cc** rotate coordinate system clockwise yp=cost*q-sint*xx xx=cost*xx+sint*q q=yp c xkm=xx ykm=q c return end ! of subr. dist c subroutine REDIST(Xkm,Ykm,XLAT,XLON) ! 7. Jan. 1988 C by Edi C CALCULATES DISTANCE BETWEEN TWO POINTS, INPUT IN RECTANGULAR XY-COOR. C OUTPUT IN LATITUDE/LONGITUDE C C CONVERSION OF KILOMETERS TO LATITUDE AND LONGITUDE c implicit none real xkm,ykm,xlat,xlon c real olat,olon,aa,bb,bc,sint,cost,rotate real xx,yy,y,x,q,lat,yp,bcl,p,lon integer icoordsystem common/GEO_COORSYSTEM/olat,olon, & rearth,ellip,rlatc,rad, & aa,bb,bc,sint,cost,rotate, icoordsystem double precision rearth,ellip,rlatc,rad c DOUBLE PRECISION LAT1,LAT2,LAT3,clat1 ! neu C c xx=xkm yy=ykm c***** Following code is commented-out c and replaced by correct code to undo rotation c WLE 1/3/95 c rphi=0.0 ! 5.4.91 u.k. cc c SINT=DSIN(RPHI*RAD) c COST=DCOS(RPHI*RAD) c TANT=DTAN(RPHI*RAD) cC---- ROTATE COORDINATES CLOCKWISE BACK BY RPHI c IF(RPHI.LT.0.1) GOTO 120 c Y=YY*COST-XX*SINT c X=XX/SINT+Y*TANT c GOTO 130 c 120 X=XX c Y=YY c rotate coordinate system into original orientation x=xx*cost-yy*sint y=yy*cost+xx*sint c WLE 1/3/95 130 CONTINUE IF(ABS(AA).LT.0.0000001) GOTO 900 Q=Y/AA LAT=(Q+OLAT)/60. XLAT=Q+OLAT - 60.*LAT YP=60.*LAT+XLAT LAT1=DATAN(RLATC*DTAN(YP*RAD/60.0)) LAT2=DATAN(RLATC*DTAN(OLAT*RAD/60.)) LAT3=(LAT1+LAT2)/2. CLAT1=DCOS(LAT3) BCL=BB*CLAT1 IF(ABS(BCL).LT.0.000001) GOTO 900 P=X/(BB*CLAT1) LON=(P+OLON)/60. XLON=P+OLON - 60.*LON xlat=lat+xlat/60. xlon=lon+xlon/60. RETURN 900 WRITE(6,1000) AA,BB,CLAT1 1000 FORMAT(/,2X,' SUBR. REDISt: AA=',F10.5,2X,'BB=',F10.5,2X, 1'COS(LAT1)=',F10.7,5X,'DIVISION BY ZERO, RUN STOPS HERE',/) stop'REDIST>>> division by zero!!' END ! of subr. redist c subroutine SETORG(orlat,orlon,rrotate,ifil) c implicit none real orlat,orlon,rrotate integer ifil c real olat,olon,aa,bb,bc,sint,cost,rotate integer icoordsystem common/GEO_COORSYSTEM/olat,olon, & rearth,ellip,rlatc,rad, & aa,bb,bc,sint,cost,rotate, icoordsystem double precision rearth,ellip,rlatc,rad c c double precision r,lat1,lat2,dela,delb,PHI,BETA c c O(r)LAT & O(r)LON : origin of cartesian coordinate system c north w e s t c c cEK Dez94 rotate=0.0 !...... c rotate=rrotate cEK if(orlat.eq.0.0.and.orlon.eq.0.0)then olat=46.95240 ! BERN North olon=-7.439583 ! BERN West else olat=orlat olon=orlon endif c olat=olat*60. ! minutes N olon=olon*60. ! minutes W c rad=0.017453292d0 C C OLD ELLIPSOID: C rlatc = 0.99330647d0 C data rearth /6378.163d0/, ellip /298.26d0/ C C NEW ELLIPSOID FOR WHOLE EARTH: WGS72 == WORLD GEODETIC SYSTEM 1972 C C ALSO SET RLATC ACCORDING TO ORIGIN C REARTH=6378.135D0 ELLIP=298.26 ! (flattening) C c rlatc = tan(geocentric LAT) / TAN(GEOGRAPHIC LAT) C C C CALCULATE RLATC: CONVERSION FROM GEOGRAPHICAL LAT TO GEOCENTRICAL LAT C PHI=OLAT*RAD/60.0 ! phi=geogr. lat BETA=PHI-DSIN(PHI*2.)/ELLIP ! beta=geoc. lat RLATC=DTAN(BETA)/DTAN(PHI) c C C WRITE ELLIPSOIDE CONSTANTS C if(ifil.gt.0)then write(ifil,*) write(ifil,*) write(ifil,*)'SHORT DISTANCE CONVERSION on ELLIPSOIDE of'// & ' WORLD GEODETIC SYSTEM 1972 (WGS72)' write(ifil,*)'=========================================='// & '===================================' write(ifil,*) write(ifil,'('' Radius at equator (REARTH)= '',f10.5, & '' km'')') rearth write(ifil,'('' 1. / (ellipticity) = '',f10.3)') ellip write(ifil,*) write(ifil,*)'Origin of cartesian coordinates [degrees]:' if(orlat.eq.0.0.and.orlon.eq.0.0)then write(ifil,*)' (Origin = city of BERNE, Switzerland)' endif write(ifil,'(1x,f12.7,'' N'',5x,f12.7,'' W'')') & olat/60.,olon/60. write(ifil,*) write(ifil,*)' Rotation angle (in degr.) clockwise from' write(ifil,'(''North rotate= '',f6.1)') rotate write(ifil,*) endif c c calculate aa & bb c length of one minute of lat and lon in km c lat1=datan(rlatc*dtan(olat*rad/60.0)) ! geoc. lat for OLAT lat2=datan(rlatc*dtan((olat+1.)*rad/60.0)) ! geoc. lat for (OLAT+1min) dela=lat2 - lat1 r=rearth*(1.0 - (dsin(lat1)**2)/ellip) ! kugelradius fuer lat=OLAT aa=r*dela ! aa = 1 min geogr. lat delb=dacos(dsin(lat1)**2 + dcos(rad/60.)*dcos(lat1)**2) bc=r*delb ! bc = 1 min geogr. lon bb=r*delb/dcos(lat1) if(ifil.gt.0)then write(ifil,'('' Radius of sphere at OLAT = '',f10.3,'' km'')')r write(ifil,*) write(ifil,*)'Conversion of GEOGRAPHICAL LATITUDE to '// & 'GEOCENTRICAL LATITUDE:' write(ifil,*)'RLATC = TAN(GEOCENTR.LAT) / TAN(GEOGRAPH.LAT)' write(ifil,'(1x,''RLATC = '',f12.8)') rlatc write(ifil,*) write(ifil,4) aa, bc 4 format (10x,'Short distance conversions:',/, & 10x,'one min lat ~ ', f7.4,' km ',/, & 10x,'one min lon ~ ', f7.4,' km ',/) write(ifil,*) write(ifil,*) endif C c*** convert coordinates with rotation cosines sint=sin(rotate*rad) cost=cos(rotate*rad) 31 continue c return end ! of subr. setorg c subroutine TIMECLEAR(iyr,imo,iday,ihr,imin,sec,itime) c c Urs Kradolfer, Winter 1987/88 c implicit none c integer iyr,iyr1,imo,iday,ihr,imin, juliam,itime real sec,sec1 c if(iyr.lt.1900)then iyr1=iyr+1900 else iyr1=iyr endif itime=JULIAM(iyr1,imo,iday,ihr,imin) 1 sec1=sec if(sec.lt.0)then sec=sec1+60. itime=itime-1 endif if(sec.gt.60.)then sec=sec1-60. itime=itime+1 endif if(sec.lt.0.0.or.sec.gt.60.0) goto 1 call DATUM(itime,iyr1,imo,iday,ihr,imin) if(iyr.lt.1900)then iyr=iyr1-1900 ! if input-year was of form 87 give it out so ! else iyr=iyr1 endif c return c end ! of subr. timeclear c INTEGER FUNCTION JULIAM(IYR,IMO,IDY,IHR,IMN) C UMRECHNEN VON JAHR-MONAT-TAG-STUNDEN-MINUTEN IN MINUTEN: C (WENN IMN 4-BYTE INTEGER, DANN JAHR < 4000) implicit none integer iyr,imo,idy,ihr,imn integer KMO(12) integer leap,ky,km,kd,ky4,ky1,ky0,kl,l DATA KMO/0,31,59,90,120,151,181,212,243,273,304,334/ DATA LEAP/1/ KY= IYR KM= IMO KD= IDY IF(KM.LE.0) KM= 1 10 JULIAM= 365*KY KD= KMO(KM)+KD KY4= KY/4 KY1= KY/100 KY0= KY/1000 KL= LEAP*(KY4-KY1+KY0) L=0 IF(KY4*4.EQ.KY.AND.(KY1*100.NE.KY.OR.KY0*1000.EQ.KY))L= LEAP IF(L.NE.0.AND.KM.LT.3) KL= KL-LEAP JULIAM= JULIAM+KD+KL JULIAM= JULIAM*24+IHR JULIAM= JULIAM*60+IMN return END ! of integer function juliam c subroutine DATUM(ITF,IYR,IMO,IDY,IHR,IMN) C UMRECHNEN DES DATUMS IN MINUTEN (CF. JULIAM) IN YR-MO-DY-HR-MI C (MIT IMN<2**31, JAHR < 4000 c implicit none integer iyr,imo,idy,ihr,imn c integer id,l,iyr4,iyrh,iyrt,ld,i integer KMO(12) INTEGER ITF,K,KH DATA KMO/31,28,31,30,31,30,31,31,30,31,30,31/ K= ITF/60 IMN= ITF-K*60 KH= K/24 IHR= K-KH*24 IYR= KH/365 5 ID= KH-IYR*365 L= 0 IYR4= IYR/4 IYRH= IYR/100 IYRT= IYR/1000 LD= IYR4-IYRH+IYRT IF(IYR4*4.EQ.IYR.AND.(IYRH*100.NE.IYR.OR.IYRT*1000.EQ.IYR)) L= 1 ID= ID-LD+L IF(ID.GT.0) GOTO 10 if(id.eq.0.and.ihr.eq.0.and.imn.eq.0) then idy= 0 imo= 0 return endif IYR= IYR-1 GOTO 5 10 KMO(2)= 28+L DO 20 I=1,12 ID= ID- KMO(I) IF(ID.LE.0) GOTO 30 20 CONTINUE I=12 30 IDY= ID+KMO(I) IMO= I RETURN end ! of subr. datum c integer function TRIMLEN(t) ! Urs Kradolfer, June 1986 c c Call: nc=TRIMLEN(char) c c --> nc says, how many characters the input-string has c (ignoring trailing blanks!). c implicit none character t*(*) do 1 trimlen=LEN(t),1,-1 1 if(t(trimlen:trimlen).ne.' ')RETURN trimlen=1 end ! of integer function trimlen c subroutine FREEUNIT(iunit) implicit none c c Purpose: Get a free FORTRAN-unit c c Output: iunit a free (file-)unit number c c Urs Kradolfer, 16.7.90 c integer iunit logical lopen c do iunit=10,999 if(iunit.eq.999) stop'FREEUNIT>>> no free unit found!' inquire(unit=iunit,opened=lopen) if(.not.lopen) RETURN enddo c RETURN c end ! of subr. freeunit c cek end of vel_tools.f c cek begin of vel_topo.f c subroutine CHTOP(xx,yy,zk, & topo1file,topo2file) ! Dummy routine cEK c this routine for a given pair of coordinates (xx,yy) provides c the elevation (zk in km) by reading it off from topo-arrays cEK c If necessary, replace it with appropriate routine and c topo information c implicit none real xx,yy,zk character*(*) topo1file,topo2file c c zk=0.0 r e t u r n end c subroutine REGION (ityp,x,y,cname,nreg, & regnamfile,regkoordfile) ! Urs Kradolfer, 6.7.87 c c originally from Manfred Baer c c modified 6.7.87, 28.6.91 Urs Kradolfer c implicit none c character*(*) regnamfile, regkoordfile character*32 cname, place integer ityp,nreg, iii, iregread real x,y, xlat,xlon c save iregread c if(iregread.eq.0)then call REGREAD(regnamfile,regkoordfile) iregread=1 endif c nreg=0 c if(ityp.eq.1) goto 1 if(ityp.eq.2.or.ityp.eq.3) goto 2 stop'REGION>>> illegal coordinate-type!' 1 continue place=' ' call REGCH(x,y,place,nreg) if(nreg.eq.0)then call GEOKO(x,y,xlat,xlon,1) goto 22 else cname=place endif goto 999 c 2 continue xlat=x xlon=y 22 place=' ' c call REGNU(0,xlat,xlon,GELAT,GELON,PLACE,NREG) if(ityp.eq.1) iii=0 if(ityp.eq.2) iii=0 if(ityp.eq.3) iii=1 call REGWORLD(iii,xlat,xlon,place,nreg) if(place.eq.' ')then cname='*****' else cname=place endif goto 999 c 999 continue return end ! of subr. region c subroutine REGREAD(regnamfile,regkoordfile) implicit none integer indfe,lt50,lt25 real xnrlon character*(*) regnamfile,regkoordfile character irname*24300 common /regioncom/ indfe(730),lt50(111),lt25(421), & irname,xnrlon(14400) c integer trimlen,nstart,nr integer nc integer i,j,k integer iu1, iu2 character*40 cregion cu character*64 inputfile c cu inputfile='/users/kradi/velest/regionsnamen.dat' call FREEUNIT(iu1) cVMS open(iu1,file=regnamfile,status='OLD',readonly) open(iu1,file=regnamfile,status='OLD') nstart=0 do i=1,729 indfe(i)=nstart read(iu1,'(i5,2x,a)') nr,cregion if(nr.ne.i) then write(6,'(''sequence error at:'',i5,a,i5)') nr,cregion,i stop'REGREAD>>> error reading file REGIONSNAMEN.DAT' endif nc=TRIMLEN(cregion) irname(nstart+1:nstart+nc)=cregion(1:nc) nstart=nstart+nc enddo indfe(730)=nstart do i=1,420 lt25(i)=nstart read(iu1,'(i5,2x,a)') nr,cregion if(i.le.400) then k=i+999 else k=1019+(i-401)*20 endif if(k.ne.nr) then write(6,'(''sequence error at:'',i5,a,i5)') nr,cregion,i stop'REGREAD>>> error reading file REGIONSNAMEN.DAT' endif nc=TRIMLEN(cregion) irname(nstart+1:nstart+nc)=cregion(1:nc) nstart=nstart+nc enddo lt25(421)=nstart do i=1,110 lt50(i)=nstart read(iu1,'(i5,2x,a)') nr,cregion if(i.le.100) then k=i+199 else k=209+(i-101)*10 endif if(k.ne.nr) then write(6,'(''sequence error at:'',i5,a,i5)') nr,cregion,i stop'REGREAD>>> error reading file REGIONSNAMEN.DAT' endif nc=TRIMLEN(cregion) irname(nstart+1:nstart+nc)=cregion(1:nc) nstart=nstart+nc enddo lt50(111)=nstart close(iu1) c write(6,'(''anzahl worte fuer regions namen:'',i6)') nstart c jetzt: flinn-engdahl-regionen cu inputfile='/users/kradi/velest/regionskoord.dat' call FREEUNIT(iu2) cVMS open(iu2,file=regkoordfile,status='OLD',readonly) open(iu2,file=regkoordfile,status='OLD') do j=1,14400,8 read(iu2,'(8f9.3)') (xnrlon(i),i=j,j+7) enddo close(iu2) c return end ! of subr. regread c subroutine REGCH(x,y,place,nreg) implicit none real x,y integer nreg integer indfe,lt50,lt25,nx,ny,nrpu,i1,i2 real xnrlon,dx,dy,xx,yy character irname*24300 COMMON /REGIONcom/ INDFE(730),LT50(111),LT25(421), & irname,XNRLON(14400) character place*32 c nreg=0 IF(X.LT.480.) RETURN IF(X.GE.865.) RETURN IF(Y.LE. 62.) RETURN IF(Y.GT.302.) RETURN dx=17.5 dy=12.0 xx=X-480. yy=302.-Y nx=xx/dx NY=yy/dy nrpu=ny*20+nx nreg=nrpu if(nx.ge.20) then nrpu=400+ny nreg=ny*20 + 19 endif i1=lt25(nrpu+1)+1 i2=lt25(nrpu+2) nreg=nreg+1000 place=irname(i1:i2) return END ! of subr. regch c subroutine REGWORLD(ityp,cord1,cord2,place,nreg) implicit none integer ityp,nreg,last,num,in,nlo,latin,mhemis,i,iuk integer nval,i1,i2 real cord1,cord2,xnrlon,galat,galon,pi real galor,galar,gelat,gelon,xazr,xdr,q,as real pirad,pi2,gelac,xlatr,gelor,ck1,ck2,ac real alon,xlat,xlon,xreg integer indfe,lt50,lt25 character irname*24300 COMMON /REGIONcom/ INDFE(730),LT50(111),LT25(421), & irname,XNRLON(14400) C PROGRAM TO COMPUTE REGION NUMBER AND NAME BASED ON THE INPUT C ITYP <=0 LATITUDE&LONGITUDE C ITYP > 0 DISTANCE & AZIMUTH C THE REGION NAMES ARE FROM FLINN & ENGDAHL#S TABLES character place*32 real BUF(40) character*1 cbk DATA GALAT/46.7706/,GALON/8.09428/ data cbk/' '/ C PI=3.141593 PIRAD=PI/180. PI2=PI*2. LAST=89 C C CONVERT ARRAY COORDINATES TO RADIANS GALOR=GALON*PIRAD GALAR=GALAT*PIRAD IF(ITYP) 850,850,860 C 850 GELAT=CORD1 GELON=CORD2 NUM=1 GO TO 212 C 860 XAZR=CORD2*PIRAD XDR= CORD1*PIRAD NUM=1 C Q=SIN(GALAR)*COS(XDR)+COS(GALAR)*SIN(XDR)*COS(XAZR) IF(ABS(Q).GT.1.) GO TO 891 AS=ASIN(Q) GO TO 890 C 891 CONTINUE GELON=0. GELAT=0. NUM=NUM-1 GO TO 212 C 890 GELAC=AS XLATR=GELAC IF(COS(GELAC))45,46,45 45 IF(COS(GALAR)) 47,46,47 46 GELOR=0.0 GO TO 34 C 47 CONTINUE CK1=(COS(XDR)-SIN(GALAR)*SIN(XLATR))/ *(COS(GALAR)*COS(XLATR)) C CK2=(SIN(XAZR)*SIN(XDR))/COS(XLATR) IF(CK1.GE.0.) GO TO 37 IF(CK2.GE.0.) GO TO 882 C IN=1 GO TO 881 C 882 IN=2 GO TO 883 C 37 IF(CK2.GE.0.) GO TO 885 C IN=3 GO TO 881 C 885 IN=4 C 883 IF(ABS(CK1).GT.1.0) GO TO 887 AC=ACOS(CK1) GO TO 888 C 881 IF(ABS(CK2).GT.1.0) GO TO 887 AS=ASIN(CK2) C 888 GO TO (33,32,31,36),IN C 33 GELOR=GALOR-PI-AS GO TO 34 C 32 GELOR=GALOR+AC GO TO 34 C 31 GELOR=GALOR+AS GO TO 34 C 36 GELOR=GALOR+AC GO TO 34 C 887 CONTINUE GELOR=0.0 C C CONVERT LONGITUDE AND LATITUDE FROM RADIANS TO DEGREES C AND REDUCE LONGITUDE TO A FORM LESS THAN 360 DEGREES C 34 CONTINUE ALON=ABS(GELOR) 506 IF(ALON.LT.PI2) GO TO 116 ALON=ALON-PI2 GO TO 506 C 116 GELOR=SIGN(ALON,GELOR) IF(ABS(GELOR).GT.PI) GELOR=GELOR-SIGN(PI2,GELOR) C C LONGITUDE IN DEGREES C GELON=GELOR/PIRAD C C LATITUDE IS CONVERTED FROM GEOCENTRIC TO GEODETIC COORDINATES C GELAT=GELAC/PIRAD C 212 IF(NUM.EQ.1) GO TO 5000 place=' ' GO TO 900 C 5000 CONTINUE C C CLEAR BUFFER C C ASSIGN REGION NUMBER AND NAME C place=' ' 215 XLAT=GELAT XLON=GELON IF(XLON.LT.0.) XLON=XLON+360. C C DETERMINE EARTH QUADRANT C IF(XLAT.LT.0.) GO TO 4 IF(XLON.GT.180.) GO TO 6 C C LATITUDE POSITIVE,LONGITUDE 0-180 C MHEMIS=0 GO TO 9 C C LATITUDE POSITIVE,LONGITUDE 181-360 C 6 MHEMIS=3600 XLON=360.-XLON GO TO 9 C 4 IF(XLON.GT.180.) GO TO 8 C C LATITUDE NEGATIVE,LONGITUDE 0-180 C MHEMIS=7200 GO TO 9 C C LATITUDE NEGATIVE,LONGITUDE 181-360 C 8 MHEMIS=10800 XLON=360.-XLON C 9 CONTINUE C C CHECK FOR ZERO LATITUDE C IF(ABS(XLAT).GE.1.0) GO TO 13 LATIN=0 GO TO 17 C 13 LATIN=ABS(XLAT) IF(LATIN.GT.LAST) LATIN=LAST C 17 CONTINUE C NLO=ABS(XLON) I=MHEMIS + 40*LATIN + 1 do iuk=1,40 buf(iuk)=xnrlon(i+iuk-1) enddo NVAL=BUF(1)*1000.+1.1 DO 56 I=2,NVAL IF(NLO.LT.int(BUF(I))) GOTO 57 56 CONTINUE I=NVAL+1 57 NREG=BUF(I-1) XREG=BUF(I-1)-NREG NREG=XREG*1000. + 0.1 I1=INDFE(NREG)+1 I2=INDFE(NREG+1) place=irname(i1:i2) C 900 continue return C END ! of subr. regworld c cek end of vel_topo.f c cek begin of matrinv.f c SUBROUTINE matrinv(N,A,B) c c MATRINV invertiert eine SYMMETRISCHE NxN-Matrix c c Aufruf: call MATRINV(N,A,B) c c N = Anz. Zeilen/Kolonnen der Matrix c A = zu invertierende Matrix (Input) c B = inv(A) (Output) c DIMENSION A(N*N),B(N*N) B(1)= 1.0/A(1) IF(N-1) 60,60,2 2 NN= N*N DO 4 I=2,NN 4 B(I)= 0.0 MM=1 KN= 0 DO 50 M=2,N K= M-1 MM= MM+N+1 KN= KN+N EK= A(MM) MI= M-N DO 10 I=1,K MI= MI+N IJ= I-N JM= KN DO 10 J= 1,K IJ= IJ+N JM= JM+1 10 EK= EK-A(MI)*B(IJ)*A(JM) B(MM)= 1.0/EK MI= M-N IM= KN DO 30 I=1,K IM= IM+1 IJ= I-N JM= KN DO 20 J= 1,K IJ= IJ+N JM= JM+1 20 B(IM)= B(IM)-B(IJ)*A(JM)*B(MM) MI= MI+N 30 B(MI)= B(IM) IM= KN DO 40 I=1,K IM= IM+1 MJ= M-N IJ= I-N DO 40 J=1,K MJ=MJ+N IJ= IJ+N 40 B(IJ)= B(IJ)+B(IM)*B(MJ)*EK 50 CONTINUE 60 continue return END c cek end of matrinv.f c subroutine CPUTIMER(cpusec) ! Urs Kradolfer, 16.9.91 c c file: cputimer_unix.f c c runs on: HP-UX , UNIX System V (AT&T) c and on: SunOS , BSD UNIX c c first call: start counting of CPU-time c subsequent calls: report elapsed CPU-time [sec] since first call c c Call: call CPUTIMER(cpusec) where cpusec is a real variable c c implicit none integer icpu, clock real cpusec external clock !$pragma C(clock) c icpu=clock() cpusec=float(icpu)/1000000. c end ! of subroutine cputimer c c subroutine DATETIME(dattim) ! Urs Kradolfer, 16.9.91 c c File: datetime_sun.f c c return UNIX-date and time c c runs on: SunOS , BSD UNIX c c Call: call DATETIME(dattim) c c returned value: dattim is a character*20 c c implicit none c character datum*26, dattim*20 c integer it, itime, ctime, time c external ctime !$pragma C(ctime) c external sprintf !$pragma C(sprintf) c external time !$pragma C(time) c c it=time(itime) c it=ctime(itime) c call sprintf(datum,'%s',%val(it)) c dattim=datum(5:24) c c end ! of subroutine datetime c