bato
/
fomosto-psgrn-pscmp
forked from pyrocko/fomosto-psgrn-pscmp
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fix potential problems with long input lines

Browse Source
master
Sebastian Heimann 7 years ago
parent 926a8e7cae
commit 187808137f
9 changed files with 142 additions and 155 deletions
Show Stats Download Patch File Download Diff File

2
src/pscmp/Makefile.am
Unescape Escape View File

@ -1,2 +1,2 @@
bin_PROGRAMS = fomosto_pscmp2008a
fomosto_pscmp2008a_SOURCES = cmbfix.f cmbopt.f dc3d.f disazi.f getdata.f mscorr.f prestress.f pscdisc.f pscglob.h pscgrn.f pscmain.f pscokada.f pscout.f roots3.f
fomosto_pscmp2008a_SOURCES = cmbfix.f cmbopt.f dc3d.f disazi.f mscorr.f prestress.f pscdisc.f pscglob.h pscgrn.f pscmain.f pscokada.f pscout.f roots3.f skip_comments.f

30
src/pscmp/getdata.f
Unescape Escape View File

@ -1,30 +0,0 @@
subroutine getdata(unit,line)
implicit none
c
c First implemented in Potsdam, Feb, 1999
c Last modified: Potsdam, Nov, 2001, by R. Wang
c
integer unit
character line*180,char*1
c
integer i
c
c this subroutine reads over all comment lines starting with "#".
c
char='#'
100 continue
if(char.eq.'#')then
read(unit,'(a)')line
i=1
char=line(1:1)
200 continue
if(char.eq.' ')then
i=i+1
char=line(i:i)
goto 200
endif
goto 100
endif
c
return
end

41
src/pscmp/pscgrn.f
Unescape Escape View File

@ -39,7 +39,6 @@ c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
double precision zs,las,mus,rhos,etks,etms,alfs
double precision psss,shss,psds,shds,pscl,psep
double precision d1,d2,d3,d4,d5,d6,d7
character*180 dataline
c
c OPEN GREEN'S FUNCTIONS FILES
c ============================
@ -81,45 +80,45 @@ c
unit(i,istp)=10+14*(istp-1)+i
open(unit(i,istp),file=greens(i,istp),status='old')
if(i*istp.eq.1)then
call getdata(unit(i,istp),dataline)
read(dataline,*)nr,r1,r2,sampratio
call skip_comments(unit(i,istp))
read(unit(i,istp),*)nr,r1,r2,sampratio
if(nr.gt.NRMAX)then
stop 'srror: NRMAX too small defined!'
endif
call getdata(unit(i,istp),dataline)
read(dataline,*)zrec,larec,murec,rhorec,etkrec,
call skip_comments(unit(i,istp))
read(unit(i,istp),*)zrec,larec,murec,rhorec,etkrec,
& etmrec,alfrec
call getdata(unit(i,istp),dataline)
read(dataline,*)nzs,zs1,zs2
call skip_comments(unit(i,istp))
read(unit(i,istp),*)nzs,zs1,zs2
if(nzs.gt.NZSMAX)then
stop 'srror: NZSMAX too small defined!'
endif
call getdata(unit(i,istp),dataline)
read(dataline,*)nt,twindow
call skip_comments(unit(i,istp))
read(unit(i,istp),*)nt,twindow
if(nt.gt.NTMAX)then
stop 'srror: NTMAX too small defined!'
endif
else
call getdata(unit(i,istp),dataline)
read(dataline,*)n,d1,d2,d3
call skip_comments(unit(i,istp))
read(unit(i,istp),*)n,d1,d2,d3
if(n.ne.nr.or.d1.ne.r1.or.d2.ne.r2.or.d3.ne.sampratio)then
stop 'srror: different observation sampling in Greens!'
endif
call getdata(unit(i,istp),dataline)
read(dataline,*)d1,d2,d3,d4,d5,d6,d7
call skip_comments(unit(i,istp))
read(unit(i,istp),*)d1,d2,d3,d4,d5,d6,d7
if(d1.ne.zrec.or.d2.ne.larec.or.
& d3.ne.murec.or.d4.ne.rhorec.or.
& d5.ne.etkrec.or.d6.ne.etmrec.or.
& d7.ne.alfrec)then
stop 'srror: diff. observation site parameters in Greens!'
endif
call getdata(unit(i,istp),dataline)
read(dataline,*)n,d1,d2
call skip_comments(unit(i,istp))
read(unit(i,istp),*)n,d1,d2
if(n.ne.nzs.or.d1.ne.zs1.or.d2.ne.zs2)then
stop 'srror: different source sampling in Greens!'
endif
call getdata(unit(i,istp),dataline)
read(dataline,*)n,d1
call skip_comments(unit(i,istp))
read(unit(i,istp),*)n,d1
if(n.ne.nt.or.d1.ne.twindow)then
stop 'srror: different time sampling in Greens!'
endif
@ -230,11 +229,11 @@ c
do i=1,14
if(select(i,istp))then
if(i.eq.1)then
call getdata(unit(i,istp),dataline)
read(dataline,*)zs,las,mus,rhos,etks,etms,alfs
call skip_comments(unit(i,istp))
read(unit(i,istp),*)zs,las,mus,rhos,etks,etms,alfs
else
call getdata(unit(i,istp),dataline)
read(dataline,*)d1,d2,d3,d4,d5,d6,d7
call skip_comments(unit(i,istp))
read(unit(i,istp),*)d1,d2,d3,d4,d5,d6,d7
if(d1.ne.zs.or.d2.ne.las.or.
& d3.ne.mus.or.d4.ne.rhos.or.
& d5.ne.etks.or.d6.ne.etms.or.

101
src/pscmp/pscmain.f
Unescape Escape View File

@ -29,7 +29,6 @@ c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
double complex clonrec1,clonrec2
double complex clonrec(NRECMAX)
character*80 infile
character*180 dataline
logical onlysc,neweq
c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c END DECLARATIONS
@ -71,14 +70,14 @@ c00000000000000000000000000000000000000000000000000000000000000000000000
c READ IN PARAMETERS FOR OBSERVATION ARRAY
c ========================================
c00000000000000000000000000000000000000000000000000000000000000000000000
call getdata(10,dataline)
read(dataline,*)ilonrec
call skip_comments(10)
read(10,*)ilonrec
if(ilonrec.eq.0)then
c
c irregular observation positions
c
call getdata(10,dataline)
read(dataline,*)nrec
call skip_comments(10)
read(10,*)nrec
if(nrec.lt.1)then
stop ' Error: wrong input for nrec!'
else if(nrec.gt.NRECMAX)then
@ -94,10 +93,10 @@ c
c
c 1D observation profile
c
call getdata(10,dataline)
read(dataline,*)nrec
call getdata(10,dataline)
read(dataline,*)clonrec1,clonrec2
call skip_comments(10)
read(10,*)nrec
call skip_comments(10)
read(10,*)clonrec1,clonrec2
if(nrec.lt.1)then
stop ' Error: wrong input for nrec!'
else if(nrec.gt.NRECMAX)then
@ -120,10 +119,10 @@ c
c
c 2D rectanglar observation array
c
call getdata(10,dataline)
read(dataline,*)nlatrec,latrec1,latrec2
call getdata(10,dataline)
read(dataline,*)nlonrec,lonrec1,lonrec2
call skip_comments(10)
read(10,*)nlatrec,latrec1,latrec2
call skip_comments(10)
read(10,*)nlonrec,lonrec1,lonrec2
nrec=nlatrec*nlonrec
if(nrec.lt.1)then
stop ' Error: wrong input for nrec!'
@ -155,36 +154,36 @@ c00000000000000000000000000000000000000000000000000000000000000000000000
c READ IN OUTPUT PARAMETERS
c =========================
c00000000000000000000000000000000000000000000000000000000000000000000000
call getdata(10,dataline)
read(dataline,*)i
if(i.eq.1)read(dataline,*)insar,xlos,ylos,zlos
call getdata(10,dataline)
read(dataline,*)i
if(i.eq.1)read(dataline,*)icmb,friction,skempton,
call skip_comments(10)
read(10,*)i
if(i.eq.1)read(10,*)insar,xlos,ylos,zlos
call skip_comments(10)
read(10,*)i
if(i.eq.1)read(10,*)icmb,friction,skempton,
& strike0,dip0,rake0,(sigma0(j),j=1,3)
call getdata(10,dataline)
read(dataline,*)outdir
call skip_comments(10)
read(10,*)outdir
c
call getdata(10,dataline)
read(dataline,*)(itout(i),i=1,3)
call getdata(10,dataline)
read(dataline,*)(toutfile(i),i=1,3)
call getdata(10,dataline)
read(dataline,*)(itout(i),i=4,9)
call getdata(10,dataline)
read(dataline,*)(toutfile(i),i=4,9)
call getdata(10,dataline)
read(dataline,*)(itout(i),i=10,14)
call getdata(10,dataline)
read(dataline,*)(toutfile(i),i=10,14)
call getdata(10,dataline)
read(dataline,*)nsc
call skip_comments(10)
read(10,*)(itout(i),i=1,3)
call skip_comments(10)
read(10,*)(toutfile(i),i=1,3)
call skip_comments(10)
read(10,*)(itout(i),i=4,9)
call skip_comments(10)
read(10,*)(toutfile(i),i=4,9)
call skip_comments(10)
read(10,*)(itout(i),i=10,14)
call skip_comments(10)
read(10,*)(toutfile(i),i=10,14)
call skip_comments(10)
read(10,*)nsc
if(nsc.gt.NSCMAX)then
stop ' Error: NSCMAX defined too small!'
endif
do isc=1,nsc
call getdata(10,dataline)
read(dataline,*)tsc(isc),scoutfile(isc)
call skip_comments(10)
read(10,*)tsc(isc),scoutfile(isc)
if(tsc(isc).lt.0.d0)then
stop ' Error: wrong scenario time!'
endif
@ -201,21 +200,21 @@ c00000000000000000000000000000000000000000000000000000000000000000000000
c READ IN PARAMETERS FOR EARTH MODEL CHOICE
c =========================================
c00000000000000000000000000000000000000000000000000000000000000000000000
call getdata(10,dataline)
read(dataline,*)grndir
call skip_comments(10)
read(10,*)grndir
c
call getdata(10,dataline)
read(dataline,*)(green(i),i=1,3)
call getdata(10,dataline)
read(dataline,*)(green(i),i=4,9)
call getdata(10,dataline)
read(dataline,*)(green(i),i=10,14)
call skip_comments(10)
read(10,*)(green(i),i=1,3)
call skip_comments(10)
read(10,*)(green(i),i=4,9)
call skip_comments(10)
read(10,*)(green(i),i=10,14)
c00000000000000000000000000000000000000000000000000000000000000000000000
c READ IN PARAMETERS FOR RECTANGULAR SOURCES
c ==========================================
c00000000000000000000000000000000000000000000000000000000000000000000000
call getdata(10,dataline)
read(dataline,*)ns
call skip_comments(10)
read(10,*)ns
if(ns.lt.1)then
stop ' Error: wrong number of subfaults!'
endif
@ -224,8 +223,8 @@ c00000000000000000000000000000000000000000000000000000000000000000000000
endif
neq=0
do is=1,ns
call getdata(10,dataline)
read(dataline,*)i,latref(is),lonref(is),zref(is),
call skip_comments(10)
read(10,*)i,latref(is),lonref(is),zref(is),
& length(is),width(is),strike(is),dip(is),
& nptch_s(is),nptch_d(is),tstart(is)
if(nptch_s(is)*nptch_d(is).gt.NPTCHMAX)then
@ -238,8 +237,8 @@ c00000000000000000000000000000000000000000000000000000000000000000000000
width(is)=width(is)*KM2M
tstart(is)=tstart(is)*DAY2SEC
do iptch=1,nptch_s(is)*nptch_d(is)
call getdata(10,dataline)
read(dataline,*)ptch_s(is,iptch),ptch_d(is,iptch),sx,sy,sz
call skip_comments(10)
read(10,*)ptch_s(is,iptch),ptch_d(is,iptch),sx,sy,sz
ptch_s(is,iptch)=ptch_s(is,iptch)*KM2M
ptch_d(is,iptch)=ptch_d(is,iptch)*KM2M
slip_s(is,iptch)=sx

23
src/pscmp/skip_comments.f
Unescape Escape View File

@ -0,0 +1,23 @@
subroutine skip_comments(unit)
implicit none
integer unit, iostat
character line*(1)
666 continue
read (unit, '(a)', iostat=iostat) line
if (iostat .ne. 0) then
stop 'error occured during read'
end if
if (line(1:1) .ne. '#') then
backspace (unit)
goto 777
end if
goto 666
777 continue
return
end

2
src/psgrn/Makefile.am
Unescape Escape View File

@ -1,2 +1,2 @@
bin_PROGRAMS = fomosto_psgrn2008a
fomosto_psgrn2008a_SOURCES = axb.f bessj0.f bessj1.f bessj.f caxcb.f cdc3d0.f cdsvd500.f cmemcpy.f four1.f getdata.f hsmatinv.f hsmatrix.f memcpy.f outint.f psgbsj.f psgglob.h psghksh.f psghskern.f psghssrce.f psgkern.f psglayer.f psgmain.f psgmatinv.f psgmatrix.f psgmoduli.f psgproppsv.f psgpropsh.f psgpsv.f psgsh.f psgsource.f psgspec.f psgsublay.f psgwvint.f
fomosto_psgrn2008a_SOURCES = axb.f bessj0.f bessj1.f bessj.f caxcb.f cdc3d0.f cdsvd500.f cmemcpy.f four1.f hsmatinv.f hsmatrix.f memcpy.f outint.f psgbsj.f psgglob.h psghksh.f psghskern.f psghssrce.f psgkern.f psglayer.f psgmain.f psgmatinv.f psgmatrix.f psgmoduli.f psgproppsv.f psgpropsh.f psgpsv.f psgsh.f psgsource.f psgspec.f psgsublay.f psgwvint.f skip_comments.f

26
src/psgrn/getdata.f
Unescape Escape View File

@ -1,26 +0,0 @@
subroutine getdata(unit,line)
implicit none
integer unit
character line*180,char*1
c
integer i
c
c this subroutine reads over all comment lines starting with "#".
c
char='#'
100 continue
if(char.eq.'#')then
read(unit,'(a)')line
i=1
char=line(1:1)
200 continue
if(char.eq.' ')then
i=i+1
char=line(i:i)
goto 200
endif
goto 100
endif
c
return
end

49
src/psgrn/psgmain.f
Unescape Escape View File

@ -16,7 +16,6 @@ c
character*35 comptxt(14)
character*80 inputfile,fname(14),outdir
character*163 green(14,4)
character*180 dataline
integer time
c
c read input file file
@ -52,11 +51,11 @@ c
c parameters for source-observation array
c =======================================
c
call getdata(10,dataline)
read(dataline,*)zrec,ioc
call skip_comments(10)
read(10,*)zrec,ioc
zrec=zrec*km2m
call getdata(10,dataline)
read(dataline,*)nr,r1,r2,sampratio
call skip_comments(10)
read(10,*)nr,r1,r2,sampratio
if(sampratio.lt.1.d0)then
stop 'Error: max. to min. sampling ratio < 1!'
endif
@ -89,8 +88,8 @@ c
enddo
endif
c
call getdata(10,dataline)
read(dataline,*)nzs,zs1,zs2
call skip_comments(10)
read(10,*)nzs,zs1,zs2
if(zs1.gt.zs2)then
swap=zs1
zs1=zs2
@ -120,8 +119,8 @@ c
zs2=zs1+dble(nzs-1)*dzs
endif
c
call getdata(10,dataline)
read(dataline,*)nt,twindow
call skip_comments(10)
read(10,*)nt,twindow
if(twindow.le.0.d0)then
stop ' Error in input: wrong time window!'
else if(nt.le.0)then
@ -137,12 +136,12 @@ c
c wavenumber integration parameters
c =================================
c
call getdata(10,dataline)
read(dataline,*)accuracy
call skip_comments(10)
read(10,*)accuracy
if(accuracy.le.0.d0.or.accuracy.ge.1.d0)accuracy=0.1d0
c
call getdata(10,dataline)
read(dataline,*)grfac
call skip_comments(10)
read(10,*)grfac
if(grfac.le.grfacmin)then
grfac=0.d0
endif
@ -150,8 +149,8 @@ c
c parameters for output files
c ===========================
c
call getdata(10,dataline)
read(dataline,*)outdir
call skip_comments(10)
read(10,*)outdir
c
do lend=80,1,-1
if(outdir(lend:lend).ne.' ')goto 100
@ -162,12 +161,12 @@ c
stop 'Error: wrong format for output directory!'
endif
c
call getdata(10,dataline)
read(dataline,*)(fname(i),i=1,3)
call getdata(10,dataline)
read(dataline,*)(fname(i),i=4,9)
call getdata(10,dataline)
read(dataline,*)(fname(i),i=10,14)
call skip_comments(10)
read(10,*)(fname(i),i=1,3)
call skip_comments(10)
read(10,*)(fname(i),i=4,9)
call skip_comments(10)
read(10,*)(fname(i),i=10,14)
do i=1,14
do lenf=80,1,-1
if(fname(i)(lenf:lenf).ne.' ')goto 110
@ -198,8 +197,8 @@ c
c global model parameters
c =======================
c
call getdata(10,dataline)
read(dataline,*)l
call skip_comments(10)
read(10,*)l
if(l.gt.lmax)then
stop 'the max. no of layers (lmax) too small defined!'
endif
@ -209,8 +208,8 @@ c =============================
c
kgmax=0.d0
do i=1,l
call getdata(10,dataline)
read(dataline,*)j,h(i),vp,vs,rho(i),etk(i),etm(i),alf(i)
call skip_comments(10)
read(10,*)j,h(i),vp,vs,rho(i),etk(i),etm(i),alf(i)
if(alf(i).gt.1.d0.or.alf(i).le.0.d0)then
stop 'Error in psgmain: wrong value for parameter alpha!'
endif

23
src/psgrn/skip_comments.f
Unescape Escape View File

@ -0,0 +1,23 @@
subroutine skip_comments(unit)
implicit none
integer unit, iostat
character line*(1)
666 continue
read (unit, '(a)', iostat=iostat) line
if (iostat .ne. 0) then
stop 'error occured during read'
end if
if (line(1:1) .ne. '#') then
backspace (unit)
goto 777
end if
goto 666
777 continue
return
end
Write Preview
Loading…
Cancel
Save