├── .gitignore ├── MAKEALL.bash ├── MINEOS_paths ├── README ├── bin └── .gitignore ├── lib └── .gitignore └── src ├── libcip ├── MAKE_ciplib.mk └── ciplib.f ├── libtau ├── README ├── emiasp91.f ├── emprem.f ├── gtt91.man ├── iasp91 ├── iasp91.hed ├── iasp91.man ├── iasp91.tbl ├── iaspmod ├── libsun.f ├── libtau.f ├── libvax.f ├── limits.inc ├── makefile ├── remodl.f ├── remodl.f.10.7.91 ├── remodl.hed ├── remodl.tbl ├── remodl1.lis ├── remodl2.lis ├── run.plotxy ├── setbrn.f ├── setbrn1.lis ├── setbrn2.lis ├── setbrn3.lis ├── ttim1.lis ├── ttimes.f ├── ttimes.trace ├── ttimes91.man ├── ttlim.inc └── zstp91.man ├── libtim ├── README ├── abstime.f ├── jday.f ├── jtime.f ├── juldoy.f ├── makefile ├── tcalc.f ├── time.f ├── timej.f └── timeph.f ├── libutil ├── README ├── angles.f ├── azimth.f ├── cipget.f ├── cipnum.f ├── cipped.f ├── cipscn.f ├── cipstr.f ├── cipsub.f ├── ciptok.f ├── ciptyp.f ├── daymo.f ├── doy.f ├── dsec_time.f ├── dsec_time_inv.f ├── ellip.f ├── fcn.f ├── gcpath.f ├── gcpath_e.f ├── get_bath.f ├── get_unit.f ├── interple.f ├── interpol.f ├── ival.f ├── kblnk.f ├── klen.f ├── lexist.f ├── llen.f ├── lnblnk.f ├── lpyr.f ├── makefile ├── maxsp.f ├── midpnt.f ├── midpnt_e.f ├── moment_a.f ├── moment_rtf.f ├── mtimes.f ├── mtimes_e.f ├── nblen.f ├── numerical.h ├── parameter.f ├── pick_filter.f ├── rspln.f ├── sadd.bug ├── sadd.f ├── sdcoht.f ├── sdiff.f ├── sec_time.bug ├── sec_time.f ├── sec_time_inv.f ├── sort.f ├── splint.f ├── spread.f ├── swap.f ├── ttimes.f └── xyz2geo.f ├── mineos ├── MAKE_eig_recover.mk ├── MAKE_frechet.mk ├── MAKE_mineos_nohang.mk ├── MAKE_mineos_q.mk ├── MAKE_mineos_strip.mk ├── MAKE_mineos_table.mk ├── baylis.f ├── bfs.f ├── dermf.f ├── derms.f ├── detqn_nohang.f ├── draw_frechet_gv.f ├── drspln.f ├── dsplin.f ├── eifout.f ├── eig_recover.f ├── entry.f ├── fprop.f ├── fprpmn.f ├── fpsm.f ├── frechet.f ├── frechet_cv.f ├── frechet_cv_ACFLN.f ├── frechet_cv_G.f ├── frechet_gv.f ├── fsbdry.f ├── fsbm.f ├── gauslv.f ├── grav.f ├── intgds.f ├── kblnk.f ├── match.f ├── mineos.f ├── mineos_q.anis.f ├── mineos_qcorrectphv.f ├── mineos_strip.f ├── mineos_table.f ├── model.f ├── modout.f ├── ortho.f ├── parameter.h ├── parameter_frechet.h ├── remedy_nohang.f ├── rkdot.f ├── rotspl_nohang.f ├── rprop.f ├── rps.f ├── sdepth.f ├── sfbdry.f ├── sfbm.f ├── sprop.f ├── sprpmn.f ├── spsm.f ├── startl.f ├── steps.f ├── svd.f ├── tprop.f ├── tps.f ├── trknt.f ├── whead.f ├── wtable.f └── zknt.f └── plot_wk ├── MAKE_plot_wk.mk ├── amp.f ├── branch_sort.f ├── class.f ├── color.f ├── cvtaper.f ├── excite.f ├── fix_class_c.f ├── fix_class_k.f ├── fix_class_p.f ├── fix_class_r.f ├── fix_class_v.f ├── interple.f ├── interpol.f ├── mask_phase.mk ├── numerical.h ├── parameter.f ├── parameter.h ├── plot_wk.f ├── response.f ├── search.f ├── seek.f ├── summary.f ├── table.f └── wind.f /.gitignore: -------------------------------------------------------------------------------- 1 | *.csv 2 | *.mat 3 | *.o 4 | *.a 5 | -------------------------------------------------------------------------------- /MAKEALL.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Script to make all the MINEOS executables and libraries 3 | 4 | #====================== SET PATHS ======================# 5 | source MINEOS_paths 6 | 7 | # cd to source directory 8 | cd src 9 | 10 | #====================== COMPILE LIBRARIES ======================# 11 | # These are written out in full for a bit of extra transparency 12 | 13 | # CIP 14 | cd libcip 15 | make -f MAKE_ciplib.mk 16 | cd .. 17 | 18 | # TAU 19 | cd libtau 20 | make 21 | cd .. 22 | 23 | # TIM 24 | cd libtim 25 | make 26 | cd .. 27 | 28 | # UTIL 29 | cd libutil 30 | make 31 | cd .. 32 | 33 | #====================== COMPILE MINEOS executables ======================# 34 | 35 | cd mineos 36 | for imk in MAKE* 37 | do 38 | # make with an -i flag to ignore errors 39 | echo $imk 40 | rm *.o 41 | make -i -f $imk 42 | rm *.o 43 | done 44 | cd .. 45 | 46 | #plot_wk 47 | cd plot_wk 48 | rm *.o 49 | make -f MAKE_plot_wk.mk 50 | rm *.o 51 | cd .. 52 | 53 | # cd back to parent directory 54 | cd .. 55 | -------------------------------------------------------------------------------- /MINEOS_paths: -------------------------------------------------------------------------------- 1 | #!\bin\bash 2 | 3 | export MINEOSBIN=$(pwd)/bin 4 | export MINEOSLIB=$(pwd)/lib 5 | -------------------------------------------------------------------------------- /bin/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except this file 4 | !.gitignore 5 | -------------------------------------------------------------------------------- /lib/.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore everything in this directory 2 | * 3 | # Except this file 4 | !.gitignore 5 | -------------------------------------------------------------------------------- /src/libcip/MAKE_ciplib.mk: -------------------------------------------------------------------------------- 1 | FFLAGS= $(MYFFLAGS) 2 | LIBNAM= $(MINEOSLIB)/libcip.a 3 | .f.a: 4 | gfortran $(FFLAGS) -c $< 5 | ar rv $@ $*.o 6 | rm -f $*.o 7 | # 8 | # List all the target objects 9 | # 10 | # $(LIBNAM): \ 11 | # $(LIBNAM)(ciplib.o) 12 | # ranlib $(LIBNAM) 13 | # 14 | $(LIBNAM): \ 15 | $(LIBNAM)(ciplib.o) 16 | # 17 | # Set index. 18 | # 19 | $(LIBNAM): ; ranlib $(LIBNAM) 20 | -------------------------------------------------------------------------------- /src/libtau/emiasp91.f: -------------------------------------------------------------------------------- 1 | subroutine emdlv(r,vp,vs) 2 | c set up information on earth model (specified by 3 | c subroutine call emiasp) 4 | c set dimension of cpr,rd equal to number of radial 5 | c discontinuities in model 6 | save 7 | character*(*) name 8 | character*20 modnam 9 | dimension cpr(11) 10 | common/emdlc/np,rd(11) 11 | data np,rd/11,1217.1,3482.0,3631.,5611.,5711.,5961.,6161., 12 | 1 6251.,6336.,6351.,6371./,rn,vn/1.5696123e-4,6.8501006/ 13 | data modnam/'iasp91'/ 14 | c 15 | call emiask(rn*r,rho,vp,vs) 16 | vp=vn*vp 17 | vs=vn*vs 18 | return 19 | c 20 | entry emdld(n,cpr,name) 21 | n=np 22 | do 1 i=1,np 23 | 1 cpr(i)=rd(i) 24 | name=modnam 25 | return 26 | end 27 | c 28 | subroutine emiask(x0,ro,vp,vs) 29 | c 30 | c $$$$$ calls no other routine $$$$$ 31 | c 32 | c Emiask returns model parameters for the IASPEI working model 33 | c (September 1990.1). 34 | c Given non-dimensionalized radius x0, emiasp returns 35 | c non-dimensionalized density, ro, compressional velocity, vp, and 36 | c shear velocity, vs. Non-dimensionalization is according to the 37 | c scheme of Gilbert in program EOS: x0 by a (the radius of the 38 | c Earth), ro by robar (the mean density of the Earth), and velocity 39 | c by a*sqrt(pi*G*robar) (where G is the universal gravitational 40 | c constant. 41 | c 42 | c 43 | save 44 | dimension r(14),d(13,4),p(13,4),s(13,4) 45 | data r/0. ,1217.1 ,3482.0 ,3631. ,5611. ,5711. , 46 | 1 5961. ,6161. ,6251. ,6336. ,6351. ,6371. , 47 | 2 6371.,6371./ 48 | data d/13.01219,12.58416, 6.8143 , 6.8143 , 6.8143 ,11.11978, 49 | 1 7.15855, 7.15855, 7.15855, 2.92 , 2.72 , 2*0., 50 | 2 0. ,-1.69929,-1.66273,-1.66273,-1.66273,-7.87054, 51 | 2 -3.85999,-3.85999,-3.85999,4*0., 52 | 3 -8.45292,-1.94128,-1.18531,-1.18531,-1.18531,8*0., 53 | 4 0. ,-7.11215,11*0./ 54 | data p/11.12094,10.03904,14.49470,25.1486 ,25.969838,29.38896, 55 | 1 30.78765,25.41389, 8.785412, 6.5 , 5.8 ,2*0., 56 | 2 0. , 3.75665, -1.47089,-41.1538, -16.934118,-21.40656, 57 | 2-23.25415,-17.69722,-0.7495294, 4*0., 58 | 3 -4.09689,-13.67046, 0.0 ,51.9932,9*0., 59 | 4 0. , 0. , 0. ,-26.6083,9*0./ 60 | data s/ 3.56454, 0. , 8.16616,12.9303 ,20.768902,17.70732, 61 | 1 15.24213,5.750203, 6.706232, 3.75 , 3.36 ,2*0., 62 | 2 0. , 0. ,-1.58206,-21.2590,-16.531471,-13.50652, 63 | 2-11.08553,-1.274202,-2.248585, 4*0., 64 | 3 -3.45241, 0. , 0.0 ,27.8988 ,9*0., 65 | 4 0. , 0. , 0. ,-14.1080,9*0./ 66 | data xn,rn,vn/6371.,.18125793,.14598326/,i/1/ 67 | c 68 | x=amax1(x0,0.) 69 | x1=xn*x 70 | 2 if(x1.ge.r(i)) go to 1 71 | i=i-1 72 | go to 2 73 | 1 if(x1.le.r(i+1).or.i.ge.11) go to 3 74 | i=i+1 75 | if(i.lt.11) go to 1 76 | 3 ro=rn*(d(i,1)+x*(d(i,2)+x*(d(i,3)+x*d(i,4)))) 77 | vp=vn*(p(i,1)+x*(p(i,2)+x*(p(i,3)+x*p(i,4)))) 78 | vs=vn*(s(i,1)+x*(s(i,2)+x*(s(i,3)+x*s(i,4)))) 79 | return 80 | end 81 | -------------------------------------------------------------------------------- /src/libtau/emprem.f: -------------------------------------------------------------------------------- 1 | subroutine emdlv(r,vp,vs) 2 | c set up information on earth model (specified by 3 | c subroutine call emiasp) 4 | c set dimension of cpr,rd equal to number of radial 5 | c discontinuities in model 6 | save 7 | character*(*) name 8 | character*20 modnam 9 | dimension cpr(13) 10 | common/emdlc/np,rd(13) 11 | data np,rd/13,1221.5,3480.0,3630.,5600.,5701.,5771.,5971., 12 | 1 6151.,6291.,6346.6,6356.,6368.,6371./ 13 | data rn,vn/1.5696123e-4,6.8501006/ 14 | data modnam/'prem'/ 15 | c 16 | call emiask(rn*r,rho,vp,vs) 17 | vp=vn*vp 18 | vs=vn*vs 19 | return 20 | c 21 | entry emdld(n,cpr,name) 22 | n=np 23 | do 1 i=1,np 24 | 1 cpr(i)=rd(i) 25 | name=modnam 26 | return 27 | end 28 | c 29 | subroutine emiask(x0,ro,vp,vs) 30 | c 31 | c $$$$$ calls no other routine $$$$$ 32 | c 33 | c Emiask returns model parameters for the IASPEI working model 34 | c (September 1990.1). 35 | c Given non-dimensionalized radius x0, emiasp returns 36 | c non-dimensionalized density, ro, compressional velocity, vp, and 37 | c shear velocity, vs. Non-dimensionalization is according to the 38 | c scheme of Gilbert in program EOS: x0 by a (the radius of the 39 | c Earth), ro by robar (the mean density of the Earth), and velocity 40 | c by a*sqrt(pi*G*robar) (where G is the universal gravitational 41 | c constant. 42 | c 43 | c 44 | save 45 | dimension r(14),d(13,4),p(13,4),s(13,4) 46 | c 47 | c23456789012345678901234567890123456789012345678901234567890123456789012 48 | c 49 | data r/0.0,1221.5,3480.0,3630.0,5600.0,5701.0, 50 | 1 5771.0,5971.0,6151.0,6291.0,6346.6,6356.0,6368.0,6371.0/ 51 | data d/13.0885 ,12.5815 , 7.9565 , 7.9565 , 7.9565 , 5.3197 , 52 | 1 11.2494 , 7.1089 , 2.691 , 2.691 , 2.90 , 2.6 , 1.02, 53 | 2 0. ,-1.2638 ,-6.4761 ,-6.4761 ,-6.4761 ,-1.4836 , 54 | 2 -8.0298 ,-3.8045 , 0.6924 , 0.6924, 0.0 , 2*0., 55 | 3 -8.8381 ,-3.6426 , 5.5283 , 5.5283 , 5.5283 , 8*0., 56 | 4 0. ,-5.5281 ,-3.0807 ,-3.0807 ,-3.0807 , 8*0./ 57 | data p/11.2622 ,11.0487 ,15.3891 ,24.9520 ,29.2766 ,19.0957 , 58 | 1 39.7027 ,20.3926 , 4.1875 , 4.1875 , 6.8 , 5.8 , 5.80, 59 | 2 0. ,-4.0362 ,-5.3181 ,-40.4673,-23.6027,-9.8672 , 60 | 2-32.6166,-12.2569, 3.9382 , 3.9382 , 0. , 2*0., 61 | 3 -6.3640 , 4.8023 , 5.5242 ,51.4832 , 5.5242 , 8*0., 62 | 4 0. ,-13.5732,-2.5514 ,-26.6419,-2.5514 , 8*0./ 63 | data s/ 3.6678 , 0.0 , 6.9254 ,11.1671 ,22.3459 , 9.9839 , 64 | 122.3512 , 8.9496 , 2.1519 , 2.1519 , 3.9 , 3.2 , 3.2, 65 | 2 0.0 , 0.0 , 1.4672 ,-13.7818,-17.2473,-4.9324 , 66 | 2-18.5856,-4.4597 , 2.3481 , 2.3481 , 0.0 , 2*0., 67 | 3 -4.4475 , 0.0 ,-2.0834 ,17.4575 ,-2.0834 , 8*0., 68 | 4 0.0 , 0.0 , 0.9783 ,-9.2777 , 0.9783 , 8*0./ 69 | data xn,rn,vn/6371.,.18125793,.14598326/,i/1/ 70 | c 71 | c 72 | c do ii = 1, 13 73 | c do kk = 1, 4 74 | c write(6,'(4f10.5)') r(ii), d(ii,kk), p(ii,kk), s(ii,kk) 75 | c end do 76 | c end do 77 | c 78 | x=amax1(x0,0.) 79 | x1=xn*x 80 | 2 if(x1.ge.r(i)) go to 1 81 | i=i-1 82 | go to 2 83 | 1 if(x1.le.r(i+1).or.i.ge.13) go to 3 84 | i=i+1 85 | if(i.lt.13) go to 1 86 | 3 ro=rn*(d(i,1)+x*(d(i,2)+x*(d(i,3)+x*d(i,4)))) 87 | vp=vn*(p(i,1)+x*(p(i,2)+x*(p(i,3)+x*p(i,4)))) 88 | vs=vn*(s(i,1)+x*(s(i,2)+x*(s(i,3)+x*s(i,4)))) 89 | return 90 | end 91 | -------------------------------------------------------------------------------- /src/libtau/iasp91: -------------------------------------------------------------------------------- 1 | DATA FOR PROGRAM DTETRA 2 | IASP91 MODEL - FINAL VERSION 3 | 1 6371.0 (2E10.5,10X,I2) 4 | 6371.00 5.80000 3.36000 5 | 6351.00 5.80000 3.36000 6 | 6351.00 6.50000 3.75000 7 | 6336.00 6.50000 3.75000 8 | 6336.00 8.04000 4.47000 9 | 6300.00 8.04420 4.48270 10 | 6251.00 8.05000 4.50000 11 | 6251.00 8.05000 4.50000 12 | 6200.00 8.19170 4.51020 13 | 6161.00 8.30000 4.51800 14 | 6161.00 8.30000 4.52200 15 | 6100.00 8.52270 4.62810 16 | 6000.00 8.88770 4.80210 17 | 5961.00 9.03000 4.87000 18 | 5961.00 9.36000 5.07000 19 | 5900.00 9.56500 5.19930 20 | 5800.00 9.90100 5.41130 21 | 5711.00 10.20000 5.60000 22 | 5711.00 10.79000 5.95000 23 | 5700.00 10.81920 5.97850 24 | 5611.00 11.05580 6.20950 25 | 5611.00 11.05580 6.20950 26 | 5600.00 11.07560 6.21800 27 | 5500.00 11.25060 6.29290 28 | 5400.00 11.41720 6.36350 29 | 5300.00 11.57610 6.43020 30 | 5200.00 11.72790 6.49330 31 | 5100.00 11.87320 6.55320 32 | 5000.00 12.01270 6.61010 33 | 4900.00 12.14690 6.66430 34 | 4800.00 12.27640 6.71630 35 | 4700.00 12.40200 6.76630 36 | 4600.00 12.52410 6.81470 37 | 4500.00 12.64350 6.86170 38 | 4400.00 12.76070 6.90780 39 | 4300.00 12.87640 6.95320 40 | 4200.00 12.99110 6.99830 41 | 4100.00 13.10550 7.04340 42 | 4000.00 13.22030 7.08880 43 | 3900.00 13.33590 7.13480 44 | 3800.00 13.45310 7.18190 45 | 3700.00 13.57250 7.23020 46 | 3631.00 13.65640 7.26450 47 | 3631.00 13.65640 7.26450 48 | 3600.00 13.66360 7.27220 49 | 3500.00 13.68660 7.29700 50 | 3482.00 13.69080 7.30150 51 | 3482.00 8.00870 0.00000 52 | 3400.00 8.15040 0.00000 53 | 3300.00 8.31710 0.00000 54 | 3200.00 8.47710 0.00000 55 | 3100.00 8.63030 0.00000 56 | 3000.00 8.77680 0.00000 57 | 2900.00 8.91660 0.00000 58 | 2800.00 9.04960 0.00000 59 | 2700.00 9.17580 0.00000 60 | 2600.00 9.29540 0.00000 61 | 2500.00 9.40820 0.00000 62 | 2400.00 9.51420 0.00000 63 | 2300.00 9.61360 0.00000 64 | 2200.00 9.70620 0.00000 65 | 2100.00 9.79200 0.00000 66 | 2000.00 9.87110 0.00000 67 | 1900.00 9.94350 0.00000 68 | 1800.00 10.00920 0.00000 69 | 1700.00 10.06810 0.00000 70 | 1600.00 10.12030 0.00000 71 | 1500.00 10.16570 0.00000 72 | 1400.00 10.20440 0.00000 73 | 1300.00 10.23640 0.00000 74 | 1217.10 10.25780 0.00000 75 | 1217.10 11.09140 3.43850 76 | 1200.00 11.09560 3.44210 77 | 1100.00 11.11880 3.46160 78 | 1000.00 11.14000 3.47950 79 | 900.00 11.15920 3.49560 80 | 800.00 11.17630 3.51010 81 | 700.00 11.19150 3.52290 82 | 600.00 11.20460 3.53390 83 | 500.00 11.21570 3.54330 84 | 400.00 11.22480 3.55090 85 | 300.00 11.23190 3.55690 86 | 200.00 11.23690 3.56110 87 | 100.00 11.23990 3.56370 88 | 1.00 11.24090 3.56450 1 89 | -------------------------------------------------------------------------------- /src/libtau/iasp91.hed: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EHopper/MINEOS/9d54460eedac196c73cddabe8676e19aaaa1563c/src/libtau/iasp91.hed -------------------------------------------------------------------------------- /src/libtau/iasp91.tbl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EHopper/MINEOS/9d54460eedac196c73cddabe8676e19aaaa1563c/src/libtau/iasp91.tbl -------------------------------------------------------------------------------- /src/libtau/iaspmod: -------------------------------------------------------------------------------- 1 | DATA FOR PROGRAM DTETRA 2 | IASP91 MODEL - FINAL VERSION 3 | 1 6371.0 (2E10.5,10X,I2) 4 | 6371.00 5.80000 3.36000 5 | 6351.00 5.80000 3.36000 6 | 6351.00 6.50000 3.75000 7 | 6336.00 6.50000 3.75000 8 | 6336.00 8.04000 4.47000 9 | 6300.00 8.04420 4.48270 10 | 6251.00 8.05000 4.50000 11 | 6251.00 8.05000 4.50000 12 | 6200.00 8.19170 4.51020 13 | 6161.00 8.30000 4.51800 14 | 6161.00 8.30000 4.52200 15 | 6100.00 8.52270 4.62810 16 | 6000.00 8.88770 4.80210 17 | 5961.00 9.03000 4.87000 18 | 5961.00 9.36000 5.07000 19 | 5900.00 9.56500 5.19930 20 | 5800.00 9.90100 5.41130 21 | 5711.00 10.20000 5.60000 22 | 5711.00 10.79000 5.95000 23 | 5700.00 10.81920 5.97850 24 | 5611.00 11.05580 6.20950 25 | 5611.00 11.05580 6.20950 26 | 5600.00 11.07560 6.21800 27 | 5500.00 11.25060 6.29290 28 | 5400.00 11.41720 6.36350 29 | 5300.00 11.57610 6.43020 30 | 5200.00 11.72790 6.49330 31 | 5100.00 11.87320 6.55320 32 | 5000.00 12.01270 6.61010 33 | 4900.00 12.14690 6.66430 34 | 4800.00 12.27640 6.71630 35 | 4700.00 12.40200 6.76630 36 | 4600.00 12.52410 6.81470 37 | 4500.00 12.64350 6.86170 38 | 4400.00 12.76070 6.90780 39 | 4300.00 12.87640 6.95320 40 | 4200.00 12.99110 6.99830 41 | 4100.00 13.10550 7.04340 42 | 4000.00 13.22030 7.08880 43 | 3900.00 13.33590 7.13480 44 | 3800.00 13.45310 7.18190 45 | 3700.00 13.57250 7.23020 46 | 3631.00 13.65640 7.26450 47 | 3631.00 13.65640 7.26450 48 | 3600.00 13.66360 7.27220 49 | 3500.00 13.68660 7.29700 50 | 3482.00 13.69080 7.30150 51 | 3482.00 8.00870 0.00000 52 | 3400.00 8.15040 0.00000 53 | 3300.00 8.31710 0.00000 54 | 3200.00 8.47710 0.00000 55 | 3100.00 8.63030 0.00000 56 | 3000.00 8.77680 0.00000 57 | 2900.00 8.91660 0.00000 58 | 2800.00 9.04960 0.00000 59 | 2700.00 9.17580 0.00000 60 | 2600.00 9.29540 0.00000 61 | 2500.00 9.40820 0.00000 62 | 2400.00 9.51420 0.00000 63 | 2300.00 9.61360 0.00000 64 | 2200.00 9.70620 0.00000 65 | 2100.00 9.79200 0.00000 66 | 2000.00 9.87110 0.00000 67 | 1900.00 9.94350 0.00000 68 | 1800.00 10.00920 0.00000 69 | 1700.00 10.06810 0.00000 70 | 1600.00 10.12030 0.00000 71 | 1500.00 10.16570 0.00000 72 | 1400.00 10.20440 0.00000 73 | 1300.00 10.23640 0.00000 74 | 1217.10 10.25780 0.00000 75 | 1217.10 11.09140 3.43850 76 | 1200.00 11.09560 3.44210 77 | 1100.00 11.11880 3.46160 78 | 1000.00 11.14000 3.47950 79 | 900.00 11.15920 3.49560 80 | 800.00 11.17630 3.51010 81 | 700.00 11.19150 3.52290 82 | 600.00 11.20460 3.53390 83 | 500.00 11.21570 3.54330 84 | 400.00 11.22480 3.55090 85 | 300.00 11.23190 3.55690 86 | 200.00 11.23690 3.56110 87 | 100.00 11.23990 3.56370 88 | 1.00 11.24090 3.56450 1 89 | -------------------------------------------------------------------------------- /src/libtau/libsun.f: -------------------------------------------------------------------------------- 1 | subroutine warn(msg) 2 | character*(*) msg 3 | write(*,100) msg 4 | 100 format(1x,a) 5 | return 6 | end 7 | subroutine tnoua(ia) 8 | c 9 | c $$$$$ calls no other routine $$$$$ 10 | c 11 | c Subroutine tnoua writes the character string ia to the standard 12 | c output without the trailing newline (allowing user input on the 13 | c same line). Programmed on 17 September 1980 by R. Buland. 14 | c 15 | save 16 | character*(*) ia 17 | write(*,100)ia 18 | 100 format(a,$) 19 | return 20 | end 21 | subroutine dasign(lu,mode,ia,len) 22 | c 23 | c $$$$$ calls no other routine $$$$$ 24 | c 25 | c Subroutine dasign opens (connects) logical unit lu to the disk file 26 | c named by the character string ia with mode mode. If iabs(mode) = 1, 27 | c then open the file for reading. If iabs(mode) = 2, then open the 28 | c file for writing. If iabs(mode) = 3, then open a scratch file for 29 | c writing. If mode > 0, then the file is formatted. If mode < 0, 30 | c then the file is unformatted. All files opened by dasign are 31 | c assumed to be direct access. Programmed on 3 December 1979 by 32 | c R. Buland. 33 | c 34 | save 35 | character*(*) ia 36 | logical exst 37 | c 38 | if(mode.ge.0) nf=1 39 | if(mode.lt.0) nf=2 40 | ns=iabs(mode) 41 | if(ns.le.0.or.ns.gt.3) ns=3 42 | go to (1,2),nf 43 | 1 go to (11,12,13),ns 44 | 11 open(lu,file=ia,status='old',form='formatted', 45 | 1 access='direct',recl=len) 46 | return 47 | 12 inquire(file=ia,exist=exst) 48 | if(exst) go to 11 49 | 13 open(lu,file=ia,status='new',form='formatted', 50 | 1 access='direct',recl=len) 51 | return 52 | 2 go to (21,22,23),ns 53 | 21 open(lu,file=ia,status='old',form='unformatted',access='direct', 54 | 1 recl=len) 55 | return 56 | 22 inquire(file=ia,exist=exst) 57 | if(exst) go to 21 58 | 23 open(lu,file=ia,status='new',form='unformatted',access='direct', 59 | 1 recl=len) 60 | return 61 | end 62 | subroutine vexit(ierr) 63 | call exit(ierr) 64 | end 65 | -------------------------------------------------------------------------------- /src/libtau/limits.inc: -------------------------------------------------------------------------------- 1 | c The "j" parameters (1 st line) are intended to be user settable: 2 | c jmod Maximum number of (rough) model points. 3 | c jslo Maximum number of discrete ray parameters. 4 | c jdep Maximum number of discrete model slowness samples. 5 | c Note: jdep always need to be larger than jslo by 6 | c approximately 50% to account for multi-valuedness 7 | c due to high slowness zones. 8 | c jsrc Maximum number of discrete model slowness samples above 9 | c the maximum source depth of interest. 10 | c jbrh Maximum number of tau branches (model discontinuities 11 | c plus one). 12 | c jlvz Maximum number of low velocity zones. 13 | c jseg Maximum number of different types of travel-times 14 | c considered. 15 | c jbrn Maximum number of different travel-time branches to be 16 | c searched. 17 | c jout Maximum length of all travel-time branches strung 18 | c together. 19 | c 20 | parameter(jmod=160,jslo=350,jdep=450,jsrc=150,jbrh=20,jlvz=5) 21 | parameter(jseg=30,jbrn=100,jout=2250) 22 | c The parameters actually used are all derivatives of the "j" 23 | c parameters and cannot be changed by the user. 24 | parameter(nmd0=jmod,nsl1=jslo+1,ndp1=jdep+1,nsr0=jsrc) 25 | parameter(nbr1=jbrh+2,nbr2=jbrh*2,ncp0=2*(jbrh+jlvz),nlvz0=jlvz) 26 | -------------------------------------------------------------------------------- /src/libtau/makefile: -------------------------------------------------------------------------------- 1 | OBJTAU = libtau.o libsun.o 2 | FFLAGS=$(MYFFLAGS) 3 | #FFLAGS = -O3 4 | LFLAGS = -L$(MINEOSLIB) 5 | LLIBS = -ltau 6 | ARFLAGS= rcv 7 | 8 | libtau.a: ${OBJTAU} 9 | gfortran $(FFLAGS) -c libtau.f 10 | gfortran $(FFLAGS) -c libsun.f 11 | ar ${ARFLAGS} $(MINEOSLIB)/libtau.a ${OBJTAU} 12 | ranlib $(MINEOSLIB)/libtau.a 13 | setbrn: setbrn.o 14 | gfortran $(FFLAGS) $(MINEOSLIB)/libtau.a setbrn.o -o $(MINEOSBIN)/setbrn 15 | ttimes: ttimes.o 16 | gfortran $(FFLAGS) $(LFLAGS) ttimes.o $(LLIBS) -o $(MINEOSBIN)/ttimes 17 | 18 | 19 | $(OBJTAU): libtau.f libsun.f 20 | gfortran $(FFLAGS) -c $*.f 21 | -------------------------------------------------------------------------------- /src/libtau/remodl.hed: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EHopper/MINEOS/9d54460eedac196c73cddabe8676e19aaaa1563c/src/libtau/remodl.hed -------------------------------------------------------------------------------- /src/libtau/remodl.tbl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EHopper/MINEOS/9d54460eedac196c73cddabe8676e19aaaa1563c/src/libtau/remodl.tbl -------------------------------------------------------------------------------- /src/libtau/run.plotxy: -------------------------------------------------------------------------------- 1 | frame 2 | file iaspmod 3 | skip 3 4 | mode 20 1 2 5 | affi -1. 6371. 1. 0 6 | read 7 | file iaspmod 8 | skip 3 9 | mode 20 1 3 10 | affi -1. 6371. 1. 0 11 | read 12 | file /home/perry/seismo/lind/models/prem/prem.card 13 | mode 20 1 3 14 | affi -0.001 6371. 0.001 0 15 | dash .1 .1 16 | read 17 | file /home/perry/seismo/lind/models/prem/prem.card 18 | mode 20 1 4 19 | affi -0.001 6371. 0.001 0 20 | dash .1 .1 21 | read 22 | file /home/perry/seismo/lind/models/prem/prem.card 23 | mode 20 1 7 24 | affi -0.001 6371. 0.001 0 25 | dash .1 .1 26 | read 27 | file /home/perry/seismo/lind/models/prem/prem.card 28 | mode 20 1 8 29 | affi -0.001 6371. 0.001 0 30 | dash .1 .1 31 | read 32 | xlab Depth (km) 33 | ylab \alpha\ (km/s) and \beta\ (km/s) 34 | titl IASPEI 91 and PREM 35 | plot 36 | stop 37 | -------------------------------------------------------------------------------- /src/libtau/ttim1.lis: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EHopper/MINEOS/9d54460eedac196c73cddabe8676e19aaaa1563c/src/libtau/ttim1.lis -------------------------------------------------------------------------------- /src/libtau/ttimes.f: -------------------------------------------------------------------------------- 1 | program ttimes 2 | save 3 | parameter (max=60) 4 | logical log,prnt(3) 5 | character*8 phcd(max),phlst(10) 6 | character*20 modnam 7 | dimension tt(max),dtdd(max),dtdh(max),dddp(max),mn(max),ts(max) 8 | dimension usrc(2) 9 | data in/1/,modnam/'iasp91'/,phlst(1)/'query'/,prnt(3)/.true./ 10 | c 11 | write(6,*) 'This routine for calculating travel times for' 12 | write(6,*) 'specific distances uses a set of precalculated' 13 | write(6,*) 'tau-p tables for the iasp91 model stored as' 14 | write(6,*) ' iasp91.hed, iasp91.tbl' 15 | write(6,*) 16 | prnt(1) = .false. 17 | prnt(2) = .false. 18 | call assign(10,2,'ttim1.lis') 19 | call tabin(in,modnam) 20 | write(6,*) 'The source depth has to be specified and also' 21 | write(6,*) 'the phase codes or keywords for the required branches' 22 | write(6,*) 'ALL will give all available branches' 23 | write(6,*) 'P gives P-up,P,Pdiff,PKP, and PKiKP' 24 | write(6,*) 'P+ gives P-up,P,Pdiff,PKP,PKiKP,PcP,pP,pPdiff,pPKP,' 25 | write(6,*) ' pPKiKP,sP,sPdiff,sPKP, and sPKiKP' 26 | write(6,*) 'S gives S-up,S,Sdiff, and SKS' 27 | write(6,*) 'S+ gives S-up,S,Sdiff,SKS,sS,sSdiff,sSKS,pS,pSdiff,' 28 | write(6,*) ' and pSKS ' 29 | write(6,*) 'basic gives P+ and S+ as well as ' 30 | write(6,*) ' ScP, SKP, PKKP, SKKP, PP, and PKPPKP ' 31 | write(6,*) 32 | write(6,*) 'or give a generic phase name' 33 | write(6,*) 34 | write(6,*) 'You will have to enter a distance,' 35 | write(6,*) 'if this is negative a new depth is calculated' 36 | write(6,*) 'TO EXIT: give negative depth' 37 | write(6,*) 38 | call brnset(1,phlst,prnt) 39 | c choose source depth 40 | 3 call query('Source depth (km):',log) 41 | read(*,*)zs 42 | if(zs.lt.0.) go to 13 43 | call depset(zs,usrc) 44 | c loop on delta 45 | 1 write(*,*) 46 | call query('Enter delta:',log) 47 | read(*,*)delta 48 | if(delta.lt.0.) go to 3 49 | write(6,*) 50 | %' delta # code time(s) (min s) dT/dD', 51 | %' dT/dh d2T/dD2' 52 | call trtm(delta,max,n,tt,dtdd,dtdh,dddp,phcd) 53 | if(n.le.0) go to 2 54 | do 4 i=1,n 55 | mn(i)=int(tt(i)/60.) 56 | ts(i)=amod(tt(i),60.) 57 | 4 continue 58 | c 59 | write(*,100)delta,(i,phcd(i),tt(i),mn(i),ts(i),dtdd(i),dtdh(i), 60 | 1 dddp(i),i=1,n) 61 | 100 format(/1x,f6.2,i5,2x,a,f9.2,i4,f7.2,f11.4,1p2e11.2/ 62 | 1 (7x,i5,2x,a,0pf9.2,i4,f7.2,f11.4,1p2e11.2)) 63 | go to 1 64 | 2 write(*,101)delta 65 | 101 format(/1x,'No arrivals for delta =',f7.2) 66 | go to 1 67 | c end delta loop 68 | 13 call retrns(in) 69 | call retrns(10) 70 | call exit(0) 71 | end 72 | -------------------------------------------------------------------------------- /src/libtau/ttimes.trace: -------------------------------------------------------------------------------- 1 | Note: Line numbers for system and library calls may be incorrect 2 | Begin traceback... 3 | Called from 0xf76b2c4c , at 0xf7ffdf20, args=0x1 0x0 0xf7795a44 0xf7803c40 4 | Called from 0xf7740d40 , at 0xf7ffe020, args=0x4001 0xf7fff987 0xf7803c40 0x747469 5 | Called from 0xf76b2c4c , at 0xf7ffe930, args=0x1 0x0 0xf7795a44 0xf7803c40 6 | Called from 0xf76bb8e0 , at 0xf7ffea30, args=0x0 0xdc750 0x80 0x89 7 | Called from 0xf7745fc8 , at 0xf7fff340, args=0x7f868 0xffffffff 0xf7804a20 0xf7804918 8 | Called from 0xf774619c , at 0xf7fff3a0, args=0xf7745f3c 0xf76bdc80 0x1 0xf78061d8 9 | Called from 0x2ac0 , at 0xf7fff400, args=0x56a94 0x1 0xa19b0 0x4 10 | Called from 0xf7740c38 , at 0xf7fff800, args=0x0 0x7f87c 0x1 0x2e000000 11 | Called from 0x2064 , at 0xf7fff860, args=0x0 0x10 0xf7fff8cc 0x56000 12 | End traceback... 13 | -------------------------------------------------------------------------------- /src/libtau/ttimes91.man: -------------------------------------------------------------------------------- 1 | .TH TTIMES91 2 | .SH NAME: 3 | ttimes91 \- travel time table access using tau-splines 4 | .SH SYNOPSIS 5 | .B ttimes91 6 | .SH DESCRIPTION 7 | ttimes91 is a simple user interface to access the travel times for 8 | a wide variety of seismic phases at a given distance for specified 9 | source depth, with user control over the selection of phases. 10 | .LP 11 | ttimes91 is set up to automatically access the tau-spline tables for 12 | the 1991 IASPEI Seismological Tables based on the velocity model 13 | iasp91 (direct access files - iasp91.hed, iasp91.tbl). 14 | Other sets of tables can be accessed by invoking ttimes91 15 | with an argument e.g. 16 | .br 17 | ttimes91 iasp89 18 | .br 19 | for tables (iasp89.hed, iasp89.tbl). 20 | .SS Phase specification 21 | The phase specification scheme is briefly described when ttimes91 22 | is run. Initially the specification procedure is set up in 23 | query mode and responses need to be made at the star prompt (*), 24 | a null response terminates the specification. 25 | The selection of phases can be done either by giving a sequence 26 | of generic phase names or by specifying keywords. 27 | The available keywords are: 28 | .nf 29 | P gives P-up, P, Pdiff, PKP and PKiKP 30 | P+ gives P-up, P, Pdiff, PKP, PKiKP, PcP, pP, pPdiff, pPKP, 31 | pPKiKP, sP, sPdiff, sPKP, sPKiKP 32 | S gives S-up, S, Sdiff, SKS 33 | S+ gives S-up, S, Sdiff, SKS, sS, SSdiff, sSKS, 34 | pS, pSdiff, pSKS 35 | basic gives P+, S+ and ScP, SKP, PKKP, SKKP, PP and PKPPKP 36 | all gives all available phases 37 | .fi 38 | .SS Depth specification 39 | Once the choice of phase branches has been made the depth needs 40 | to be specified and the specified tau-splines appropriate for 41 | that depth are then formed. 42 | .SS Distance specification 43 | The user is prompted for epicentral distance (delta) and the 44 | travel time, slowness, curvature and depth derivative are displayed 45 | for each phase. 46 | .LP 47 | A new depth can be chosen by setting the distance negative, and 48 | the procedure terminated but setting the depth negative as well. 49 | .SH SEE ALSO 50 | gtt91 51 | .SH AUTHORS 52 | R. Buland, 53 | National Earthquake Information Centre, U.S. Geological Survey 54 | Golden, Colorado 55 | .br 56 | B.L.N. Kennett, 57 | Research School of Earth Sciences, Australian National University 58 | Canberra, Australia 59 | -------------------------------------------------------------------------------- /src/libtau/ttlim.inc: -------------------------------------------------------------------------------- 1 | c The "j" parameters (1 st line) are intended to be user settable: 2 | c jsrc Maximum number of discrete model slowness samples above 3 | c the maximum source depth of interest. 4 | c jseg Maximum number of different types of travel-times 5 | c considered. 6 | c jbrn Maximum number of different travel-time branches to be 7 | c searched. 8 | c jout Maximum length of all travel-time branches strung 9 | c together. 10 | c jtsm Maximum length of the tau depth increments. 11 | c jxsm Maximum number of x-values needed for the depth 12 | c increments. 13 | c jbrnu Maximum length of the up-going branches. 14 | c jbrna Maximum length of branches which may need 15 | c re-interpolation. 16 | c 17 | parameter(jsrc=150,jseg=30,jbrn=100,jout=2250,jtsm=350,jxsm=jbrn, 18 | 1 jbrnu=jbrn,jbrna=jbrn) 19 | c A few derived parameters are also needed. 20 | parameter(jrec=jtsm+jxsm,jtsm0=jtsm+1) 21 | -------------------------------------------------------------------------------- /src/libtau/zstp91.man: -------------------------------------------------------------------------------- 1 | .TH ZSTP91 2 | .SH NAME: 3 | zstp91 \- graphical interface to travel time tables using tau-splines 4 | .SH SYNOPSIS 5 | .B zstp91 < zst.cmd 6 | .SH DESCRIPTION 7 | zstp91 is a simple user interface to access the travel times for 8 | a wide variety of seismic phases and display them in a selected 9 | time and distance window. 10 | .br 11 | User control is provided over the selection of phases. 12 | .SS Running zstp91 13 | zstp91 is run from a command file specifying the parameters for the 14 | phase control as well as the features of the distance-time window 15 | and frame. The run sequence is 16 | .br 17 | zstp91 < zst.cmd 18 | .br 19 | where zst.cmd is a command file. 20 | For example to produce plots for all available phases over the 21 | span from 0 to 180 degrees for travel times up to 30 minutes, and a 22 | source depth of 200km. 23 | .nf 24 | .ta 2.0 25 | iasp91 Model file 26 | 200. depth 27 | 1. 180. delta min,max 28 | 2 pen colour 29 | 0. reduction slowness 30 | FR Frame: FR-full frame, NL-no labels 31 | 5.0 x-orig 32 | 2.0 y-orig 33 | 3 font choice 34 | 0.00 180.00 Dmin, Dmax 35 | 15.00 length of D-axis 36 | 0.00 40.00 Trmin,Trmax 37 | 25.00 length of T-axis 38 | 20.00 10.000 Large Tic spacing D,T 39 | 5.00 1.000 Small Tic spacing D,T 40 | 0 0 # of dec. in label D,T 41 | 0.4300 0.47500 character size text,title 42 | Delta deg X-txt 43 | Time min Y-txt 44 | iasp91 200 km source Title 45 | .fi 46 | .SS Phase specification in zstp91: 47 | Groups of seismic phases can be selected via the keywords 48 | used for ttimes91 49 | The available keywords are: 50 | .nf 51 | P gives P-up, P, Pdiff, PKP and PKiKP 52 | P+ gives P-up, P, Pdiff, PKP, PKiKP, PcP, pP, pPdiff, pPKP, 53 | pPKiKP, sP, sPdiff, sPKP, sPKiKP 54 | S gives S-up, S, Sdiff, SKS 55 | S+ gives S-up, S, Sdiff, SKS, sS, SSdiff, sSKS, 56 | pS, pSdiff, pSKS 57 | basic gives P+, S+ and ScP, SKP, PKKP, SKKP, PP and PKPPKP 58 | all gives all available phases 59 | .fi 60 | .SH SEE ALSO 61 | gtt91 62 | .SH AUTHORS 63 | B.L.N. Kennett, 64 | Research School of Earth Sciences, Australian National University 65 | Canberra, Australia 66 | .br 67 | using the travel time routines developed by: 68 | .br 69 | R. Buland, 70 | National Earthquake Information Centre, U.S. Geological Survey 71 | Golden, Colorado 72 | -------------------------------------------------------------------------------- /src/libtim/README: -------------------------------------------------------------------------------- 1 | subroutine timeph added on 1/97 by JM, 2 | timeph is actually the same as subroutine time, but 3 | the name time is an intrinsic function in HP fortran 4 | so the name had to be changed. Both subroutines are 5 | currently left in the library, but as coded are recompilled 6 | on the HP's it will be neccessary to switch their call statements 7 | to call timeph to access the subroutine. 8 | -------------------------------------------------------------------------------- /src/libtim/abstime.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | real*8 function abstime(jyr,jmo,jdy,jhr,jmn,sec) 4 | c 5 | c Purpose: 6 | c To convert a date and time specification in seconds starting 7 | c from 1900 1 1 0 0 0.0. 8 | c 9 | c WARNINGS: - since the routine does not account for the secular 10 | c leap year, its validity extends only to 2099. 11 | c - the routine does not have a control on the century 12 | c and for instance it assumes 1979 to be 79. 13 | c - if a date is not defined (ie. it looks like 0 0 0 0 14 | c 0 0.0) the routine gives back 0.0. 15 | c - if the date is expressed as day of the year, enter 0 16 | c for the month. 17 | c 18 | c Arguments: 19 | c jyr year. 20 | c jmo month. (0 - if day of the year) 21 | c jdy day. 22 | c jhr hour. 23 | c jmn minute. 24 | c sec second. 25 | c abstime time in seconds from 1900 1 1 0 0 0.0. 26 | c 27 | c 28 | real*8 sec 29 | dimension n(0:12),l(0:12) 30 | data n/1,0,31,59,90,120,151,181,212,243,273,304,334/ 31 | data l/1,0,31,60,91,121,152,182,213,244,274,305,335/ 32 | c 33 | c Transform date and time in seconds from 1900 1 1 0 0 0.0. 34 | c 35 | if (jyr.ge.1900) then 36 | jyear=jyr-1900 37 | else 38 | jyear=jyr 39 | endif 40 | if (jyear.eq.0) then 41 | n0=0 42 | lc=0 43 | lcdiff=0 44 | else 45 | n0=1 46 | lc=(jyear-1)/4 47 | lcdiff=(jyear-1)-(lc*4) 48 | endif 49 | if (lcdiff.eq.3) then 50 | jdd=l(jmo)+jdy-1 51 | else 52 | jdd=n(jmo)+jdy-1 53 | endif 54 | abstime=lc*126230400.0d+00+(lcdiff+n0)*31536000.0d+00 55 | * +jdd*86400.0d+00+jhr*3600.0d+00+jmn*60.0d+00+sec 56 | if (jmo.eq.0.and.jdy.ne.0) abstime=abstime-86400d+00 57 | c 58 | c 59 | return 60 | end 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/libtim/jday.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | integer*4 function jday(jyr,jmo,jdy) 4 | c 5 | c Purpose: 6 | c To find out the day of the year (julian day). 7 | c The routine returns zero if some implausible value is entered. 8 | c 9 | c Arguments: 10 | c jyr year. 11 | c jmo month. 12 | c jdy day. 13 | c jday day of the year (julian day). 14 | c 15 | c 16 | logical*4 leap 17 | integer*4 jyr,jmo,jdy 18 | integer*4 ilp100,ilp400 19 | integer*4 n(12),l(12) 20 | integer*4 jdym(12) 21 | c 22 | data n/0,31,59,90,120,151,181,212,243,273,304,334/ 23 | data l/0,31,60,91,121,152,182,213,244,274,305,335/ 24 | data jdym/31,29,31,30,31,30,31,31,30,31,30,31/ 25 | c 26 | c Check for absurd values end eventually return. 27 | c 28 | if (jmo.le.0.or.jmo.ge.13) then 29 | jday=0 30 | return 31 | else if (jdy.le.0.or.jdy.gt.jdym(jmo)) then 32 | jday=0 33 | return 34 | endif 35 | c 36 | c Check if it is a leap year. 37 | c 38 | leap=.false. 39 | ilp=mod(jyr,4) 40 | if (ilp.eq.0) then 41 | leap=.true. 42 | ilp100=mod(jyr,100) 43 | ilp400=mod(jyr,400) 44 | if (ilp100.eq.0.and.ilp400.ne.0) leap=.false. 45 | endif 46 | c 47 | c Find out the day of the year. 48 | c 49 | if (leap) then 50 | jday=l(jmo)+jdy 51 | else 52 | jday=n(jmo)+jdy 53 | endif 54 | c 55 | c Last check. 56 | c 57 | if (.not.leap.and.(jmo.eq.2.and.jdy.eq.29)) then 58 | jday=0 59 | endif 60 | c 61 | c 62 | return 63 | end 64 | 65 | 66 | -------------------------------------------------------------------------------- /src/libtim/jtime.f: -------------------------------------------------------------------------------- 1 | double precision function jtime(jday,jhr,jmin,sec) 2 | c 3 | c calculate time in days from jday,jhr,jmin,jsec 4 | c 5 | real*8 tempo 6 | integer jday,jhr,jmin 7 | real sec 8 | jtime = dble(jday) 9 | & + ((((dble(sec)/60.d0)+dble(jmin))/60.d0)+dble(jhr))/24.d0 10 | c 11 | return 12 | end 13 | -------------------------------------------------------------------------------- /src/libtim/juldoy.f: -------------------------------------------------------------------------------- 1 | integer function juldoy(iyear,idoy) 2 | c 3 | c compute Julian day from year and day of year 4 | c 5 | integer idoy, iyear, iyr, iyr1, jyear 6 | c 7 | jyear = iyear - 1900 8 | iyr1 = 0 9 | iyr = int((jyear-1)/4) 10 | juldoy = 2415020 + 365*jyear + idoy + iyr 11 | c 12 | return 13 | end 14 | -------------------------------------------------------------------------------- /src/libtim/makefile: -------------------------------------------------------------------------------- 1 | # Compiler options. 2 | FC = gfortran 3 | FFLAGS = $(MYFFLAGS) 4 | #For HP 5 | # FFLAGS = $(MYFFLAGS) +O3 +U77 +E5 6 | # 7 | # Library pathname. 8 | # 9 | LIBNAM= $(MINEOSLIB)/libtim.a 10 | # 11 | # Compile, archive and clean. 12 | # 13 | .f.a: 14 | $(FC) $(FFLAGS) -c $< 15 | ar rv $@ $*.o 16 | rm -f $*.o 17 | # 18 | # List all the target objects. 19 | # 20 | $(LIBNAM): \ 21 | $(LIBNAM)(abstime.o) \ 22 | $(LIBNAM)(jday.o) \ 23 | $(LIBNAM)(jtime.o) \ 24 | $(LIBNAM)(juldoy.o) \ 25 | $(LIBNAM)(tcalc.o) \ 26 | $(LIBNAM)(time.o) \ 27 | $(LIBNAM)(timeph.o) \ 28 | $(LIBNAM)(timej.o) 29 | # 30 | # Set index. 31 | # 32 | $(LIBNAM): ; ranlib $(LIBNAM) 33 | -------------------------------------------------------------------------------- /src/libtim/tcalc.f: -------------------------------------------------------------------------------- 1 | double precision function tcalc(iy,id,ih,im,sec) 2 | c 3 | c calculate time 4 | c 5 | real*8 jtime 6 | real*4 sec 7 | integer jdcalc, juldoy, iy, id, ih, im 8 | jdcalc = juldoy(iy,id) 9 | tcalc = jtime(jdcalc,ih,im,sec) 10 | c 11 | return 12 | end 13 | -------------------------------------------------------------------------------- /src/libtim/timej.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | subroutine timej(abstime,jyr,jjd,jhr,jmn,sec) 4 | c 5 | c Purpose: 6 | c To transform a period of time, expressed as seconds from 1900 7 | c 1 0 0 0.0, in a date (julian day) and time. 8 | c 9 | c WARNINGS: - the routine works only up to the year 1999. 10 | c - the routine does not have a control on the century 11 | c and for istance it assumes 1979 to be 79. 12 | c 13 | c 02/02/03 -- modified to return 4-digit year -- above two warnings 14 | c obsolete. see comments for syr in catbin program 15 | c (usr/local/src/Cmt). Currently up to date through 2004. 16 | c Arguments: 17 | c abstime time in seconds from 1900 1 0 0 0.0. 18 | c jyr year. 19 | c jjd day of the year (julian day). 20 | c jhr hour. 21 | c jmn minute. 22 | c sec second. 23 | c 24 | c 25 | implicit real*8 (a-h,o-z) 26 | dimension syr(0:110) 27 | c 28 | c The data statement of syr is splitted because of compliation 29 | c problems. 30 | c 31 | data (syr(i),i=0,48)/0.0d+00, 32 | *0.31536000d+08,0.63072000d+08,0.94608000d+08,0.12614400d+09, 33 | *0.15776640d+09,0.18930240d+09,0.22083840d+09,0.25237440d+09, 34 | *0.28399680d+09,0.31553280d+09,0.34706880d+09,0.37860480d+09, 35 | *0.41022720d+09,0.44176320d+09,0.47329920d+09,0.50483520d+09, 36 | *0.53645760d+09,0.56799360d+09,0.59952960d+09,0.63106560d+09, 37 | *0.66268800d+09,0.69422400d+09,0.72576000d+09,0.75729600d+09, 38 | *0.78891840d+09,0.82045440d+09,0.85199040d+09,0.88352640d+09, 39 | *0.91514880d+09,0.94668480d+09,0.97822080d+09,0.10097568d+10, 40 | *0.10413792d+10,0.10729152d+10,0.11044512d+10,0.11359872d+10, 41 | *0.11676096d+10,0.11991456d+10,0.12306816d+10,0.12622176d+10, 42 | *0.12938400d+10,0.13253760d+10,0.13569120d+10,0.13884480d+10, 43 | *0.14200704d+10,0.14516064d+10,0.14831424d+10,0.15146784d+10/ 44 | data (syr(i),i=49,110)/ 45 | *0.15463008d+10,0.15778368d+10,0.16093728d+10,0.16409088d+10, 46 | *0.16725312d+10,0.17040672d+10,0.17356032d+10,0.17671392d+10, 47 | *0.17987616d+10,0.18302976d+10,0.18618336d+10,0.18933696d+10, 48 | *0.19249920d+10,0.19565280d+10,0.19880640d+10,0.20196000d+10, 49 | *0.20512224d+10,0.20827584d+10,0.21142944d+10,0.21458304d+10, 50 | *0.21774528d+10,0.22089888d+10,0.22405248d+10,0.22720608d+10, 51 | *0.23036832d+10,0.23352192d+10,0.23667552d+10,0.23982912d+10, 52 | *0.24299136d+10,0.24614496d+10,0.24929856d+10,0.25245216d+10, 53 | *0.25561440d+10,0.25876800d+10,0.26192160d+10,0.26507520d+10, 54 | *0.26823744d+10,0.27139104d+10,0.27454464d+10,0.27769824d+10, 55 | *0.28086048d+10,0.28401408d+10,0.28716768d+10,0.29032128d+10, 56 | *0.29348352d+10,0.29663712d+10,0.29979072d+10,0.30294432d+10, 57 | *0.30610656d+10,0.30926016d+10,0.31241376d+10,0.31556736d+10, 58 | *0.31872960d+10,0.32188320d+10,0.32503680d+10,0.32819040d+10, 59 | *0.33135264d+10,0.33450624d+10,0.33765984d+10,0.34081344d+10, 60 | *0.34397568d+10,0.1d+11/ 61 | data sjd/0.86400d+05/ 62 | data shr/0.3600d+04/ 63 | data smn/0.60d+02/ 64 | c 65 | abstim=abstime 66 | c 67 | c Outermost loop to find out the year. 68 | c 69 | do i=0,105 70 | if (abstim.ge.syr(i).and.abstim.lt.syr(i+1)) then 71 | jyr=1900+i 72 | abstim=abstim-syr(i) 73 | c 74 | c Second outermost loop to find out the day of the year. 75 | c 76 | do l=1,366 77 | sjdyr=(l-1)*sjd 78 | sjdyrp1=l*sjd 79 | if(abstim.ge.sjdyr.and.abstim.lt.sjdyrp1) then 80 | jjd=l 81 | abstim=abstim-sjdyr 82 | c 83 | c Second innermost loop to find out the hour. 84 | c 85 | do k=0,23 86 | shrjd=k*shr 87 | shrjdp1=(k+1)*shr 88 | if(abstim.ge.shrjd.and.abstim.lt.shrjdp1) then 89 | jhr=k 90 | abstim=abstim-shrjd 91 | c 92 | c Innermost loop to find out minute and second. 93 | c 94 | do n=0,59 95 | smnhr=n*smn 96 | smnhrp1=(n+1)*smn 97 | if(abstim.ge.smnhr.and.abstim.lt.smnhrp1) then 98 | jmn=n 99 | sec=abstim-smnhr 100 | c 101 | c Date and time are setted: return. 102 | c 103 | return 104 | endif 105 | enddo 106 | endif 107 | enddo 108 | endif 109 | enddo 110 | endif 111 | enddo 112 | c 113 | c 114 | end 115 | -------------------------------------------------------------------------------- /src/libutil/README: -------------------------------------------------------------------------------- 1 | Added to library by R.K. 2 | 3 | lexist.f - logical function to determine whether file exists. 4 | 5 | nblen.f - integer function returns the length of the string 6 | to the last non-blank character. 7 | 8 | 9 | Change made by R.K. 10 | 11 | cipsub.f - chenge the character dimension of veriables 'words' and 'sword' 12 | from *20 to *80. (5/26/95) 13 | 14 | 15 | Change made by Peter Puster: 16 | ttimes.f - location of travel time tables now defined using environment 17 | variable SEISM (currently this should be set to: 18 | SEISM=/quake/data1/gsdf.local/maps) (3/9/96) 19 | -------------------------------------------------------------------------------- /src/libutil/angles.f: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | subroutine angles(x,y,z,theta,phi) 5 | c 6 | c finds the angles theta and phi of a spherical polar coordinate 7 | c system from the cartesion coordinates x, y, and z. 8 | c 9 | c Mark Riedesel, 1983 10 | c 11 | include 'numerical.h' 12 | c 13 | eps = 1.e-4 14 | rtod = radd 15 | c 16 | arg1=sqrt(x*x+y*y) 17 | theta=atan2(arg1,z) 18 | if(abs(x).le.eps.and.abs(y).le.eps) then 19 | phi=0. 20 | else 21 | phi=atan2(y,x) 22 | end if 23 | phi=phi*rtod 24 | theta=theta*rtod 25 | return 26 | end 27 | -------------------------------------------------------------------------------- /src/libutil/azimth.f: -------------------------------------------------------------------------------- 1 | subroutine azimth(slat,slon,rlat,rlon,delta,azim,bazim) 2 | c 3 | c This routine uses Euler angles to find the geocentric 4 | c distance, azimuth, and back azimuth for a source-reciever 5 | c pair. 6 | c 7 | c Input 8 | c slat - source geographic latitude in decimal degrees 9 | c slon - source longitude in decimal degrees 10 | c rlat - receiver geographic latitude in decimal degrees 11 | c rlon - receiver longitude in decimal degrees 12 | c 13 | c Output 14 | c delta - source-reciever distance in decimal degrees of arc 15 | c azim - azimuth from the source to the reciever in degrees 16 | c bazim - back azimuth from the receiver to the source in degrees 17 | c 18 | c Mark Riedesel, January 30, 1986 19 | c 20 | include 'numerical.h' 21 | dtor = drad 22 | e = 1.0/flt 23 | c 24 | c convert to geocentric coordinates and from latitude to 25 | c colatitude 26 | c 27 | slatra = dtor*slat 28 | w = sin(slatra) 29 | s = ((2.-e)*w +4.*e*(w**3))*e*cos(slatra) 30 | scolat = pi2 - slatra + s 31 | c 32 | rlatra = dtor*rlat 33 | w = sin(rlatra) 34 | s = ((2.-e)*w +4.*e*(w**3))*e*cos(rlatra) 35 | rcolat = pi2 - rlatra + s 36 | c 37 | slonra=slon*dtor 38 | rlonra=rlon*dtor 39 | c2=cos(scolat) 40 | s2=sin(scolat) 41 | c1=cos(slonra) 42 | s1=sin(slonra) 43 | c 44 | c find the azimuth and distance by rotating the source to the 45 | c North pole 46 | c 47 | slatrc=sin(rcolat) 48 | x0=slatrc*cos(rlonra) 49 | y0=slatrc*sin(rlonra) 50 | z0=cos(rcolat) 51 | c 52 | x1=c1*x0+s1*y0 53 | y1=-s1*x0+c1*y0 54 | z1=z0 55 | x2=c2*x1-s2*z1 56 | y2=y1 57 | z2=c2*z1+s2*x1 58 | c 59 | call angles(x2,y2,z2,delta,azim) 60 | azim = 180.-azim 61 | c 62 | c find the back azimuth by rotating the reciever to the 63 | c North pole 64 | c 65 | c2=cos(rcolat) 66 | s2=sin(rcolat) 67 | c1=cos(rlonra) 68 | s1=sin(rlonra) 69 | c 70 | slatrc=sin(scolat) 71 | x0=slatrc*cos(slonra) 72 | y0=slatrc*sin(slonra) 73 | z0=cos(scolat) 74 | c 75 | x1=c1*x0+s1*y0 76 | y1=-s1*x0+c1*y0 77 | z1=z0 78 | x2=c2*x1-s2*z1 79 | y2=y1 80 | z2=c2*z1+s2*x1 81 | c 82 | call angles(x2,y2,z2,delta,bazim) 83 | bazim = 180.-bazim 84 | return 85 | end 86 | -------------------------------------------------------------------------------- /src/libutil/cipget.f: -------------------------------------------------------------------------------- 1 | subroutine cipget( prompt,token ) 2 | c 3 | c purpose: 4 | c This routine performs the routine parsing of all input 5 | c into tokens. It maintains it's own typein buffer and 6 | c simply returns a new token each time it is called 7 | c args: 8 | c prompt string printed when new input is needed 9 | c token token returned to calling program 10 | c 11 | c versions and revisions: 12 | c for UNIX R.Goff Jan. 1982 13 | c 14 | character*(*) prompt,token 15 | character*80 typbuf 16 | data typbuf/' '/ 17 | c 18 | c see if a buffer flush is desired 19 | c 20 | if( prompt .eq. 'flush' ) then 21 | typbuf=' ' 22 | ibp = 0 23 | return 24 | end if 25 | c 26 | c see if no re-prompting is desired 27 | c 28 | if( prompt .eq. 'noprompt' ) then 29 | call ciptok( typbuf,ibp,token ) 30 | return 31 | end if 32 | go to 200 33 | c 34 | c prompt for new input 35 | c 36 | 100 call ciptyp( prompt,typbuf ) 37 | ibp = 0 38 | if( typbuf .eq. ' ' ) then 39 | token = ' ' 40 | return 41 | end if 42 | c 43 | c get a token from input buffer 44 | c 45 | 200 call ciptok( typbuf,ibp,token ) 46 | if( token .eq. 'eoi' ) go to 100 47 | c 48 | c return token to caller 49 | c 50 | return 51 | end 52 | -------------------------------------------------------------------------------- /src/libutil/cipnum.f: -------------------------------------------------------------------------------- 1 | subroutine cipnum( token,rnum,iflag ) 2 | c 3 | c purpose: 4 | c Interpret a token as a number. A real number is returned if 5 | c numeric interpretation is possible. 6 | c 7 | c args: 8 | c 9 | c token character string to be interpreted 10 | c rnum result if numeric - else = 0 11 | c iflag =0 if o.k. else = ichar(first non-numeric) 12 | c 13 | c versions and revisions: 14 | c for UNIVAC R.Goff Sept. 1981 15 | c for VAX/UNIX R.Goff Jan. 1981 16 | c 17 | character*(*) token 18 | character*15 numstr 19 | c 20 | c find length of token 21 | c 22 | lt = index( token,' ' ) - 1 23 | if( lt .le. 0 ) lt = len( token ) 24 | c 25 | c scan token for bum chars 26 | c 27 | do 100 i = 1,lt 28 | if( lge(token(i:i),'0') .and. lle(token(i:i),'9') ) go to 100 29 | if( token(i:i) .eq. 'e' ) go to 100 30 | if( token(i:i) .eq. '.' ) go to 100 31 | if( token(i:i) .eq. '+' ) go to 100 32 | if( token(i:i) .eq. '-' ) go to 100 33 | c 34 | c return bum char in iflag 35 | c 36 | rnum = 0. 37 | iflag = ichar( token(i:i) ) 38 | return 39 | c 40 | 100 continue 41 | c 42 | c move it to numstr right justified 43 | c 44 | numstr = ' ' 45 | numstr(16-lt:15) = token(1:lt) 46 | c 47 | c use an internal read to decode it 48 | c 49 | read( numstr,200 ) rnum 50 | 200 format(e15.0) 51 | c 52 | c success 53 | c 54 | iflag = 0 55 | return 56 | end 57 | -------------------------------------------------------------------------------- /src/libutil/cipped.f: -------------------------------------------------------------------------------- 1 | subroutine cipped(nr,rnam,rval,ni,inam,ival) 2 | c 3 | c purpose: 4 | c To facilitate the editing of arrays of numbers. This routine 5 | c allows the user to display a table of run-time 6 | c parameters and update them as needed. They are referred to by 7 | c names supplied by the calling program. 8 | c 9 | c args: 10 | c nr number of parameters in real table 11 | c rnam array of character variables containing name of 12 | c individual parameters in the same order as rval 13 | c rval array of real valued parameters 14 | c ni number of integer parameters 15 | c inam array of character variables containing names of 16 | c integer valued parameters 17 | c ival array of integer valued parameters 18 | c 19 | character*(*) rnam(*),inam(*) 20 | character*20 token 21 | c 22 | c changed 5/13/92 lsg 23 | c 24 | c character*80 typbuf 25 | character*256 typbuf 26 | c 27 | real*4 rval(*) 28 | integer*4 ival(*) 29 | c 30 | c get an editor command 31 | c 32 | 100 call cipget('pedit:',typbuf) 33 | ibp=0 34 | call ciptok(typbuf,ibp,token) 35 | 105 call cipscn( token,'la l u',2,igo) 36 | if( igo .gt. 0 ) go to 200 37 | if( igo .eq. 0 ) then 38 | print *,token,' ???' 39 | call cipget('flush',token) 40 | go to 100 41 | end if 42 | go to ( 110,120,130,140,140,140 ),-igo 43 | c 44 | c give them some help with the commands 45 | c 46 | 110 print * 47 | print *,'parameter editing commands are:' 48 | print * 49 | print *,'l list by name' 50 | print *,'la list all' 51 | print *,'u update by name' 52 | print *,'quit quit editor' 53 | print * 54 | go to 100 55 | c 56 | c they asked to quit this nonesense 57 | c 58 | 120 return 59 | c 60 | c no menu for now 61 | c 62 | 130 print *,'no menu available' 63 | go to 100 64 | c 65 | c don't recognize yes no or blank 66 | c 67 | 140 print *,token,' ???' 68 | go to 100 69 | c 70 | c they have specified a legal command 71 | c 72 | 200 go to ( 400,300,500 ),igo 73 | c 74 | c list by name 75 | c 76 | 300 call cipget('name:',token) 77 | 305 do 310 ir = 1,nr 78 | if( token .eq. rnam(ir) ) go to 320 79 | 310 continue 80 | do 315 ii = 1,ni 81 | if( token .eq. inam(ii) ) go to 340 82 | 315 continue 83 | go to 105 84 | c 85 | c found it 86 | c 87 | 320 print 330,rnam(ir),'=',rval(ir) 88 | 330 format(a12,a,f10.3) 89 | go to 390 90 | 340 print 350,inam(ii),'=',ival(ii) 91 | 350 format(a12,a,i6) 92 | 390 call cipget('noprompt',token) 93 | if( token .ne. 'eoi' ) go to 305 94 | go to 100 95 | c 96 | c list all parameters in table 97 | c 98 | 400 continue 99 | print*,' ' 100 | print 420,(inam(i),ival(i),i=1,ni) 101 | print*,' ' 102 | print 410,(rnam(i),rval(i),i=1,nr) 103 | print*,' ' 104 | 410 format(4(a12,f10.3,' ')) 105 | 420 format(4(a12,i6,' ')) 106 | go to 100 107 | c 108 | c update by name 109 | c 110 | 500 call ciptok(typbuf,ibp,token) 111 | if (token .eq. 'eoi') then 112 | call cipget('name:',token) 113 | endif 114 | 505 do 510 ir = 1,nr 115 | if( token .eq. rnam(ir) ) go to 520 116 | 510 continue 117 | do 515 ii = 1,ni 118 | if( token .eq. inam(ii) ) go to 540 119 | 515 continue 120 | go to 105 121 | c 122 | c found it 123 | c 124 | 520 call ciptok(typbuf,ibp,token) 125 | if (token .eq. 'eoi') then 126 | call cipget('real value:',token) 127 | endif 128 | call cipnum(token,rnum,iflag ) 129 | if( iflag .ne. 0 ) go to 600 130 | rval(ir) = rnum 131 | go to 590 132 | 540 call ciptok(typbuf,ibp,token) 133 | if (token .eq. 'eoi') then 134 | call cipget('integer value:',token) 135 | endif 136 | call cipnum(token,rnum,iflag) 137 | if( iflag .ne. 0 ) go to 600 138 | ival(ii) = nint(rnum) 139 | 590 call cipget('noprompt',token) 140 | if( token .ne. 'eoi' ) go to 505 141 | go to 100 142 | 600 print *,token,' is not a legal numeric' 143 | call cipget('flush',token) 144 | go to 100 145 | c 146 | end 147 | -------------------------------------------------------------------------------- /src/libutil/cipscn.f: -------------------------------------------------------------------------------- 1 | subroutine cipscn(token,clist,ncm,igo ) 2 | c 3 | c purpose: 4 | c To scan a list ( clist ) of possible commands for the 5 | c occurence of token. The list of possible commands is a 6 | c single character variable with the commands strung together 7 | c and delimited by blanks or commas just as a typed in line 8 | c would appear. A default list of commands is also scanned 9 | c if token is not found in the user supplied list. Shortened 10 | c typeins of at least ncm characters will cause a match. 11 | c 12 | c args: 13 | c token the typed in command ( see ciptok ) 14 | c clist the list of possible commands 15 | c ncm integer indicating how many characters to match 16 | c igo integer returned for use in a computed go to 17 | c igo = 1 first command matched etc. 18 | c igo = 0 no match made 19 | c igo < 0 default command matched 20 | c 21 | c versions and revisions: 22 | c for UNIVAC R.Goff Sept. 1981 23 | c for VAX/UNIX R.Goff Dec. 1981 24 | c 25 | character*(*) token,clist 26 | character*20 comand 27 | character*80 dclist 28 | data dclist/'help,quit,menu,yes,no,stop,,'/ 29 | c 30 | c use ciptok to parse clist 31 | c 32 | lt = index( token,' ' ) -1 33 | if( lt .le. 0 ) lt = len( token ) 34 | icp = 0 35 | igo = 0 36 | 100 call ciptok( clist,icp,comand ) 37 | if( comand .eq. 'eoi' ) go to 200 38 | igo = igo + 1 39 | lc = index( comand,' ' ) -1 40 | if( lc .le. 0 ) lc = len( comand ) 41 | lm = min( lc,ncm ) 42 | if( lt .lt. lm ) go to 100 43 | c 44 | c changing this line to allow for matches when 45 | c a longer token is typed 46 | c 47 | c if( token(1:lt) .eq. comand(1:lt) ) return 48 | c 49 | if( token(1:lm) .eq. comand(1:lm) ) return 50 | go to 100 51 | c 52 | c search the default list now 53 | c 54 | 200 igo = 0 55 | icp = 0 56 | 300 call ciptok( dclist,icp,comand ) 57 | if( comand .eq. 'eoi' ) go to 400 58 | igo = igo - 1 59 | lc = index( comand,' ' ) -1 60 | if( lc .le. 0 ) lc = len( comand ) 61 | lm = min( lc,ncm ) 62 | if( lt .lt. lm ) go to 300 63 | if( token(1:lt) .eq. comand(1:lt) ) return 64 | go to 300 65 | c 66 | c take care of 'eoi' and 'eot' 67 | c 68 | 400 if( token .eq. 'eoi' ) then 69 | igo = -99 70 | return 71 | end if 72 | if( token .eq. 'eot' ) then 73 | igo = -999 74 | return 75 | end if 76 | c 77 | c not in there either 78 | c 79 | igo = 0 80 | return 81 | end 82 | -------------------------------------------------------------------------------- /src/libutil/cipstr.f: -------------------------------------------------------------------------------- 1 | subroutine cipstr( typbuf,ibp,string ) 2 | c 3 | c purpose: 4 | c To retrieve that portion of a typed-in line to the right 5 | c of the buffer pointer ( including imbedded blanks or 6 | c commas ) for use in titles or headings. 7 | c 8 | c args: 9 | c typbuf typein buffer returned by ciptyp 10 | c ibp buffer pointer ( same as in ciptok ) 11 | c string character string returned 12 | c 13 | c versions and revisions: 14 | c for UNIVAC R.Goff Sept. 1981 15 | c for VAX/UNIX R.Goff jan. 1982 16 | c 17 | character*(*) typbuf,string 18 | c 19 | c find length of typein buffer 20 | c 21 | l=len (typbuf) 22 | c 23 | c see if buffer pointer is in bounds 24 | c 25 | if (ibp.lt.0) then 26 | ibp=0 27 | string=' ' 28 | return 29 | end if 30 | if (ibp.ge.l) then 31 | ibp=l 32 | string='eoi' 33 | return 34 | end if 35 | c 36 | c strip off leading blanks 37 | c 38 | ist=ibp 39 | 100 ist=ist+1 40 | if (typbuf(ist:ist).ne.' ') go to 200 41 | if (ist.lt.l) go to 100 42 | c 43 | c ran out of buffer 44 | c 45 | ibp=l 46 | string='eoi' 47 | return 48 | 200 string=typbuf(ist:l) 49 | ibp=l 50 | return 51 | end 52 | -------------------------------------------------------------------------------- /src/libutil/cipsub.f: -------------------------------------------------------------------------------- 1 | subroutine cipsub( skell,subs,string ) 2 | c 3 | c purpose: 4 | c Build a string by taking skeleton string and substituting 5 | c words into it where indicated by substitution metasequences 6 | c similar to those used in shell scripts. This routine is 7 | c args: 8 | c skell skeleton string 9 | c subs words to use in substitutions 10 | c string output string which is built 11 | c 12 | c example: 13 | c skell = '/u1/sss/minster/$1/$2.dat' 14 | c subs = 'sssdata event1' 15 | c string = 'u1/sss/minster/sssdata/event1.dat' 16 | c author: 17 | c R. Goff S-Cubed Jan. 1982 18 | c 19 | character*(*) skell,subs,string 20 | character*80 words(9) 21 | character*80 sword 22 | dimension iend(20),iwrd(20) 23 | c 24 | c first tear the subs string into words 25 | c 26 | ibp = 0 27 | do 100 iwd = 1,9 28 | 100 call ciptok( subs,ibp,words(iwd) ) 29 | c 30 | c find places where substitution is indicated 31 | c 32 | nsub = 0 33 | do 200 i = 1,len(skell) 34 | if( skell(i:i) .ne. '$' ) go to 200 35 | iarg = ichar( skell(i+1:i+1) ) - ichar( '0' ) 36 | if( iarg .lt. 0 .or. iarg .gt. 9 ) go to 200 37 | nsub = nsub + 1 38 | if( nsub .gt. 20 ) go to 300 39 | iend(nsub) = i - 1 40 | iwrd(nsub) = iarg 41 | 200 continue 42 | c 43 | c now build the string 44 | c 45 | 300 string = ' ' 46 | ie = 0 47 | last = 1 48 | do 400 isub = 1,nsub 49 | is = ie + 1 50 | ie = is + iend(isub) - last 51 | string(is:ie) = skell(last:iend(isub)) 52 | last = iend(isub) + 3 53 | sword = words(iwrd(isub)) 54 | if( sword.eq.'eoi' ) go to 400 55 | lw = index(sword,' ') - 1 56 | if( lw .le. 0 ) lw = len(sword) 57 | is = ie + 1 58 | ie = is + lw - 1 59 | string(is:ie) = sword(1:lw) 60 | 400 continue 61 | is = ie + 1 62 | string(is:len(string) ) = skell(last:len(skell) ) 63 | return 64 | end 65 | -------------------------------------------------------------------------------- /src/libutil/ciptok.f: -------------------------------------------------------------------------------- 1 | subroutine ciptok( typbuf,ibp,token ) 2 | c 3 | c purpose: 4 | c To take a typed in string of characters and break it 5 | c up into smaller strings called tokens. Tokens are 6 | c fields delimited by blanks or commas. Multiple or 7 | c redundant blanks are treated as one blank however 8 | c two successive commas will result in a blank token 9 | c being returned to the calling program whether are not 10 | c there are blanks in between them. 11 | c 12 | c args: 13 | c typbuf buffer containing the string to be parsed 14 | c ibp buffer pointer ( 0 or -> delimiter ) 15 | c token token found ( or eoi for end of input ) 16 | c 17 | c versions and revisions: 18 | c for UNIVAC R.Goff Sept. 1981 19 | c for VAX/UNIX R.Goff Dec. 1981 20 | c 21 | character*(*) typbuf,token 22 | character*1 olddel 23 | c 24 | c see that buffer pointer is in bounds 25 | c 26 | l = len( typbuf ) 27 | if( ibp .lt. 0 ) then 28 | ibp = 0 29 | token = ' ' 30 | return 31 | end if 32 | if( ibp .ge. l ) then 33 | ibp = l 34 | token = 'eoi' 35 | return 36 | end if 37 | c 38 | c pick up old delimiter 39 | c 40 | olddel = ' ' 41 | if( ibp .gt. 0 ) olddel = typbuf( ibp:ibp ) 42 | c 43 | c skip white space 44 | c 45 | 100 ibp = ibp + 1 46 | if( typbuf(ibp:ibp) .ne. ' ' ) go to 200 47 | if( ibp .lt. l ) go to 100 48 | c 49 | c end of buffer - token = 'eoi' 50 | c 51 | 150 token = 'eoi' 52 | return 53 | c 54 | c check for two commas 55 | c 56 | 200 if( typbuf(ibp:ibp) .ne. ',' ) go to 300 57 | if( olddel .eq. ',' ) then 58 | token = ' ' 59 | return 60 | end if 61 | olddel = ',' 62 | if( ibp .ge. l ) go to 150 63 | go to 100 64 | c 65 | c copy token to output 66 | c 67 | 300 ist = ibp 68 | 400 ibp = ibp + 1 69 | if( typbuf(ibp:ibp) .eq. ' ' ) go to 500 70 | if( typbuf(ibp:ibp) .eq. ',' ) go to 500 71 | if( ibp .lt. l ) go to 400 72 | token = typbuf( ist:l ) 73 | return 74 | 500 token = typbuf( ist:ibp-1 ) 75 | return 76 | end 77 | -------------------------------------------------------------------------------- /src/libutil/ciptyp.f: -------------------------------------------------------------------------------- 1 | subroutine ciptyp( insol,typbuf ) 2 | c 3 | c purpose: 4 | c To solicit and accept typeins from the keyboard. This routine 5 | c prints a prompt on the screen leaving the cursor just to the 6 | c left of it waiting for the user to type the answer. Since no 7 | c facility for suppresion of cr/lf is provided in the ANSI 8 | c standard for FORTRAN 77 this routine uses some machine dependant 9 | c extentions to the language. 10 | c 11 | c args: 12 | c insol character string used for the prompt 13 | c typbuf character variable which will receive the typein 14 | c 15 | c versions and revisions: 16 | c for UNIVAC R.Goff Sept 1981 17 | c for VAX/UNIX R.Goff Dec. 1981 18 | c 19 | character*(*) insol,typbuf 20 | c 21 | c print the prompt 22 | c 23 | print 100,insol 24 | 100 format( a ) 25 | c 26 | c retieve the typein 27 | c 28 | read (*,200,end=300)typbuf 29 | 200 format( a ) 30 | return 31 | 300 typbuf = 'eot' 32 | end 33 | -------------------------------------------------------------------------------- /src/libutil/daymo.f: -------------------------------------------------------------------------------- 1 | INTEGER FUNCTION DAYMO(DOFY, MONTH, DAY, YEAR) 2 | C 3 | C Function daymo determines the month and day 4 | C of the month,given the year and day of year. 5 | C It returns 1 if it was successful,0 otherwise. 6 | C If dofy is not within legal limits,month and 7 | C day will be returned as zero. 8 | C 9 | C 10 | C Calls: 11 | C lpyr 12 | C 13 | C Programmed by Madeleine Zirbes 14 | C September 15,1980 15 | C 16 | C DAY OF YEAR - INPUT 17 | INTEGER DOFY 18 | C MONTH - OUTPUT 19 | INTEGER MONTH 20 | C DAY OF MONTH - OUTPUT 21 | INTEGER DAY 22 | C YEAR - INPUT 23 | INTEGER YEAR 24 | C 25 | C DAY OF YEAR 26 | INTEGER IDAY 27 | C FUNCTION 28 | INTEGER LPYR 29 | C NUMBER OF DAYS IN MONTH 30 | INTEGER MDAYS(12) 31 | DATA MDAYS/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ 32 | C 33 | IDAY = DOFY 34 | IF (.NOT.(IDAY .LT. 1)) GOTO 2060 35 | MONTH = 0 36 | DAY = 0 37 | DAYMO = (0) 38 | RETURN 39 | C 40 | 2060 CONTINUE 41 | IF (.NOT.(LPYR(YEAR) .EQ. 1)) GOTO 2080 42 | MDAYS(2) = 29 43 | GOTO 2090 44 | 2080 CONTINUE 45 | MDAYS(2) = 28 46 | C 47 | 2090 CONTINUE 48 | DO 2100 MONTH = 1, 12 49 | DAY = IDAY 50 | IDAY = IDAY - MDAYS(MONTH) 51 | IF (.NOT.(IDAY .LE. 0)) GOTO 2120 52 | DAYMO = (1) 53 | RETURN 54 | 2120 CONTINUE 55 | C 56 | 2100 CONTINUE 57 | MONTH = 0 58 | DAY = 0 59 | DAYMO = (0) 60 | RETURN 61 | C 62 | END 63 | -------------------------------------------------------------------------------- /src/libutil/doy.f: -------------------------------------------------------------------------------- 1 | INTEGER FUNCTION DOY(MONTH, DAY, YEAR) 2 | C 3 | C Function doy determines the day of the 4 | C year,given the month,day and year. 5 | C If month or day are illegal,the return 6 | C value of the function is zero. 7 | C 8 | C 9 | C Calls: 10 | C lpyr 11 | C 12 | C Programmed by Madeleine Zirbes 13 | C September 15,1980 14 | C 15 | C MONTH - INPUT 16 | INTEGER MONTH 17 | C DAY OF MONTH - INPUT 18 | INTEGER DAY 19 | C YEAR - INPUT 20 | INTEGER YEAR 21 | C FUNCTION 22 | INTEGER LPYR 23 | INTEGER INC 24 | INTEGER NDAYS(12) 25 | DATA NDAYS/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334/ 26 | C 27 | IF (.NOT.(MONTH .LT. 1 .OR. MONTH .GT. 12)) GOTO 2140 28 | DOY = (0) 29 | RETURN 30 | 2140 CONTINUE 31 | IF (.NOT.(DAY .LT. 1 .OR. DAY .GT. 31)) GOTO 2160 32 | DOY = (0) 33 | RETURN 34 | 2160 CONTINUE 35 | IF (.NOT.(LPYR(YEAR) .EQ. 1 .AND. MONTH .GT. 2)) GOTO 2180 36 | INC = 1 37 | GOTO 2190 38 | 2180 CONTINUE 39 | INC = 0 40 | 2190 CONTINUE 41 | DOY = (NDAYS(MONTH) + DAY + INC) 42 | RETURN 43 | END 44 | -------------------------------------------------------------------------------- /src/libutil/dsec_time.f: -------------------------------------------------------------------------------- 1 | subroutine dsec_time(iyr,idoy,ihr,imin,sec,ibyr,tsec) 2 | c 3 | c subroutine to convert time to sec relative to a base year 4 | c input time in gfs format (yr,day,hr,min,sec) and a reference 5 | c year for t=0 6 | c returns tsec, time in sec 7 | c 8 | c dsec is double precision version -- returns tsec in real*8 9 | c 10 | integer*4 iyr, idoy, ihr, imin, ibyr 11 | real*4 sec 12 | real*8 ttmp,tsec,spday,sphr,spmin 13 | c 14 | include 'numerical.h' 15 | c 16 | c first account for day, hour, minutes, and seconds 17 | c subtract 1 from idoy since idoy starts at 1, not zero 18 | c 19 | ttmp = dble(idoy-1)*spday + dble(ihr)*sphr 20 | . + dble(imin)*spmin 21 | . + dble(sec) 22 | c 23 | c now calculate the year offset 24 | c 25 | icount = 0 26 | do ii = 1, iyr-ibyr 27 | ierr = lpyr(ibyr + ii - 1) 28 | if (ierr .eq. 1) then 29 | iday = 366 30 | else 31 | iday = 365 32 | end if 33 | icount = icount + iday 34 | c print*,ibyr + ii - 1,iday,icount 35 | end do 36 | ttmp = ttmp + dble(icount)*spday 37 | tsec = ttmp 38 | c 39 | return 40 | end 41 | -------------------------------------------------------------------------------- /src/libutil/dsec_time_inv.f: -------------------------------------------------------------------------------- 1 | subroutine dsec_time_inv(tsec,ibyr,iyr,idoy,ihr,imin,sec) 2 | c 3 | c subroutine to convert time in sec relative to a base year 4 | c to time in y,d,h,m,s. Inverts the action of sec_tim.f. 5 | c 6 | c input tsec and ibyr (reference year for t=0) 7 | c outut time in yr,d,h,m,s 8 | c 9 | c Double precision -- expects tsec as real*8 10 | c 11 | c 12 | integer*4 iyr, idoy, ihr, imin, ibyr, lpyr 13 | real*4 sec 14 | real*8 tsec, spyr,spday, sphr 15 | c 16 | include 'numerical.h' 17 | c 18 | c first account for year offset 19 | 20 | ierr = lpyr(ibyr) 21 | if (ierr .eq. 1) then 22 | iday = 366 23 | else 24 | iday = 365 25 | end if 26 | 27 | spyr = dble(iday)*spday 28 | c nyr = int(tsec/spyr) 29 | c print*,nyr 30 | 31 | c add 1 to base year, and subtract correct number of seconds, 32 | c for each whole year of offset. Requires checking for leap 33 | c year and calculating spyr with each step. Loop is not 34 | c entered if tsec is less than a year. 35 | 36 | iyr = ibyr 37 | do while (tsec.ge.spyr) 38 | c i = 1,nyr 39 | tsec = tsec - spyr 40 | iyr = iyr + 1 41 | ierr = lpyr(iyr) 42 | if (ierr .eq. 1) then 43 | iday = 366 44 | else 45 | iday = 365 46 | end if 47 | spyr = dble(iday)*spday 48 | end do 49 | 50 | c year should now be correct, and tsec is less than 1 year. Note 51 | c that idoy starts at 1 since there is no day 0. 52 | 53 | idoy = 1 + int(tsec/spday) 54 | tsec = tsec - dble(idoy-1)*spday 55 | ihr = int(tsec/sphr) 56 | tsec = tsec - dble(ihr)*sphr 57 | imin = int(tsec/spmin) 58 | sec = real(tsec) - real(imin)*spmin 59 | 60 | if(idoy.gt.iday .or. ihr.gt.24 .or. imin.gt.60 61 | & .or. sec.gt.60. .or. iday.lt.0 .or. ihr.lt.0 .or. 62 | & imin.lt.0 .or. sec.lt.0.) then 63 | print*,'**********' 64 | print*,'ERROR in sec_time_inv -- failed to reduce' 65 | print*,'**********' 66 | end if 67 | 68 | c 69 | return 70 | end 71 | -------------------------------------------------------------------------------- /src/libutil/fcn.f: -------------------------------------------------------------------------------- 1 | c 2 | function fcn(p) 3 | real l1,l2,l3,mm1,mm2,mm3 4 | common/b2/l1,l2,l3,mm1,mm2,mm3,factor 5 | r=p*factor 6 | g= abs(l3) 7 | if(g.lt.0.01) go to 1 8 | ang=-(l1* cos(r)+l2* sin(r))/l3 9 | ang= atan(ang) 10 | fcn=ang/factor 11 | return 12 | 1 ang=-(mm1* cos(r)+mm2* sin(r))/mm3 13 | ang= atan(ang) 14 | fcn=ang/factor 15 | return 16 | end 17 | -------------------------------------------------------------------------------- /src/libutil/gcpath.f: -------------------------------------------------------------------------------- 1 | subroutine gcpath(slat,slon,sbear,dist,ndist,gcloc) 2 | *===================================================================== 3 | * PURPOSE: To compute locations along a great circle path. 4 | * assuming spherically-symmetric Earth 5 | *===================================================================== 6 | * INPUT ARGUMENTS: 7 | * SLAT: Source latitude in degrees, north positive. [f] 8 | * SLON: Source longtiude in degrees, east positive. [f] 9 | * SBEAR: Source bearing (i.e. local azimuth along path.) [f] 10 | * DIST: Array of distances from source in km along path. [f] 11 | * NDIST: Length of DIST array. [i] 12 | *===================================================================== 13 | * OUTPUT ARGUMENTS: 14 | * GCLOC: Array containing the latitudes and longitudes of GCP 15 | * line segments. The first row contains the latitudes, 16 | * the second row the longitudes. [fa] 17 | *===================================================================== 18 | * MODULE/LEVEL: MAP/4 19 | *===================================================================== 20 | * GLOBAL INPUT: 21 | * MAP: RADIUS, TORAD, TODEG 22 | *===================================================================== 23 | * REFERENCES: 24 | * - Derivation of the spherical geomety equations used in this sub- 25 | * routine are due to Dave Harris and can be found in the MAP folder. 26 | *===================================================================== 27 | 28 | dimension dist(*), gcloc(2,*) 29 | include 'numerical.h' 30 | 31 | * PROCEDURE: 32 | 33 | * - Compute constants that depend only upon the source location. 34 | 35 | theta=drad*slat 36 | ct=cos(theta) 37 | st=sin(theta) 38 | 39 | phi=drad*slon 40 | cp=cos(phi) 41 | sp=sin(phi) 42 | 43 | bear=drad*sbear 44 | cb=cos(bear) 45 | sb=sin(bear) 46 | 47 | * - Loop on each element in distance array. 48 | 49 | do 1000 j=1,ndist 50 | 51 | delta=dist(j)/rnk 52 | cd=cos(delta) 53 | sd=sin(delta) 54 | 55 | ez=cd*st+sd*cb*ct 56 | ey=cd*ct*cp+sd*(-cb*st*cp-sb*sp) 57 | ex=cd*ct*sp+sd*(-cb*st*sp+sb*cp) 58 | 59 | gcloc(2,j)=radd*atan2(ex,ey) 60 | 1000 gcloc(1,j)=radd*atan2(ez,sqrt(ex*ex+ey*ey)) 61 | 62 | 8888 return 63 | 64 | *===================================================================== 65 | * MODIFICATION HISTORY: 66 | * 870105: SUN version. 67 | * 850430: Combined the latitudes and longitudes of the GCP line 68 | * segments into one array. 69 | * 840807: Original version (due to Dave Harris.) 70 | *===================================================================== 71 | * DOCUMENTED/REVIEWED: 850212 72 | *===================================================================== 73 | 74 | end 75 | -------------------------------------------------------------------------------- /src/libutil/gcpath_e.f: -------------------------------------------------------------------------------- 1 | subroutine gcpath_e(slat,slon,sbear,dist,ndist,gcloc) 2 | *===================================================================== 3 | * PURPOSE: To compute locations along a great circle path. 4 | * assuming elliptical Earth 5 | *===================================================================== 6 | * INPUT ARGUMENTS: 7 | * SLAT: Source latitude in degrees, north positive. [f] 8 | * SLON: Source longtiude in degrees, east positive. [f] 9 | * SBEAR: Source bearing (i.e. local azimuth along path.) [f] 10 | * DIST: Array of distances from source in km along path. [f] 11 | * NDIST: Length of DIST array. [i] 12 | *===================================================================== 13 | * OUTPUT ARGUMENTS: 14 | * GCLOC: Array containing the latitudes and longitudes of GCP 15 | * line segments. The first row contains the latitudes, 16 | * the second row the longitudes. [fa] 17 | *===================================================================== 18 | * MODULE/LEVEL: MAP/4 19 | *===================================================================== 20 | * GLOBAL INPUT: 21 | * MAP: RADIUS, TORAD, TODEG 22 | *===================================================================== 23 | * REFERENCES: 24 | * - Derivation of the spherical geomety equations used in this sub- 25 | * routine are due to Dave Harris and can be found in the MAP folder. 26 | *===================================================================== 27 | 28 | *====== 29 | * ADDITION TO DEAL WITH GEOCENTRIC COORDINATES 30 | *====== 31 | 32 | dimension dist(*), gcloc(2,*) 33 | real*4 ex, ey, ez, alpha, beta 34 | * 35 | include 'numerical.h' 36 | * 37 | e = 1.0/flt 38 | a = (1.0 - e)**2 39 | b = 1.0/a 40 | 41 | * PROCEDURE: 42 | 43 | * - Compute constants that depend only upon the source location. 44 | 45 | theta=drad*slat 46 | * 47 | beta = atan( a * tan(theta)) 48 | theta = beta 49 | * 50 | ct=cos(theta) 51 | st=sin(theta) 52 | 53 | phi=drad*slon 54 | cp=cos(phi) 55 | sp=sin(phi) 56 | 57 | bear=drad*sbear 58 | cb=cos(bear) 59 | sb=sin(bear) 60 | 61 | * - Loop on each element in distance array. 62 | 63 | do 1000 j=1,ndist 64 | 65 | delta=dist(j)/rnk 66 | cd=cos(delta) 67 | sd=sin(delta) 68 | 69 | ez=cd*st+sd*cb*ct 70 | ey=cd*ct*cp+sd*(-cb*st*cp-sb*sp) 71 | ex=cd*ct*sp+sd*(-cb*st*sp+sb*cp) 72 | 73 | c beta = atan2(ez,sqrt(ex*ex+ey*ey)) 74 | c alpha = atan( b * tan(beta) ) 75 | 76 | beta = ez/sqrt(ex*ex+ey*ey) 77 | alpha = atan( b * beta ) 78 | 79 | gcloc(2,j)=radd*atan2(ex,ey) 80 | 1000 gcloc(1,j)=radd*alpha 81 | 82 | 8888 return 83 | 84 | *===================================================================== 85 | * MODIFICATION HISTORY: 86 | * 870105: SUN version. 87 | * 850430: Combined the latitudes and longitudes of the GCP line 88 | * segments into one array. 89 | * 840807: Original version (due to Dave Harris.) 90 | *===================================================================== 91 | * DOCUMENTED/REVIEWED: 850212 92 | *===================================================================== 93 | 94 | end 95 | -------------------------------------------------------------------------------- /src/libutil/get_bath.f: -------------------------------------------------------------------------------- 1 | subroutine get_bath(elat,elon,fbath) 2 | c 3 | c given elat and elon of a point, return value of bathymetry 4 | c 5 | integer*2 ibath1(4320),ibath2(4320) 6 | character*256 filen 7 | c 8 | filen='/seismo/data1/datalib/dbdb5/dbdb5.data.sun' 9 | lu = 173 10 | c 11 | c open DBDB5 bathymetry file and set up some parameters 12 | c - 5 min by 5 min 13 | c 14 | open(lu,file=filen,form='unformatted',recl=8640,access='direct') 15 | spd = 1.0/12.0 16 | xlatm = 90.0 17 | xlonm = 0.0 18 | xlat = elat 19 | if (elon .lt. 0.0) then 20 | xlon = elon + 360 21 | else 22 | xlon = elon 23 | end if 24 | c 25 | c determine the latitude records 26 | c 27 | rlat = (xlatm - xlat)/spd + 1.0 28 | i1 = int(rlat) 29 | i2 = i1 + 1 30 | xlati = xlatm - xlat - float(i1 - 1)*spd 31 | read(lu,rec=i1) (ibath1(i),i=1,4320) 32 | read(lu,rec=i2) (ibath2(i),i=1,4320) 33 | c 34 | c determine the longitude elements 35 | c 36 | rlon = (xlon - xlonm)/spd + 1.0 37 | i1 = int(rlon) 38 | i2 = i1 + 1 39 | xloni = xlon - xlonm - float(i1 - 1)*spd 40 | c 41 | c we have bounded the value - interpolate 42 | c 43 | f1 = ibath1(i1) 44 | f2 = ibath2(i1) 45 | f3 = ibath1(i2) 46 | f4 = ibath2(i2) 47 | f5 = f1 + (xloni/spd)*(f3 - f1) 48 | f6 = f2 + (xloni/spd)*(f4 - f2) 49 | fbath = f5 + (xlati/spd)*(f6 - f5) 50 | c 51 | close(lu) 52 | return 53 | end 54 | -------------------------------------------------------------------------------- /src/libutil/get_unit.f: -------------------------------------------------------------------------------- 1 | subroutine get_unit(typbuf,ibp,sub,index,scale) 2 | c 3 | c return scale factor depending on units 4 | c index = 1 for time units 5 | c index = 2 for frequency units 6 | c 7 | character*(*) typbuf 8 | character*(*) sub 9 | integer*4 ibp, index 10 | real*4 scale 11 | c 12 | include 'numerical.h' 13 | c 14 | c time units - convert everything to seconds 15 | c 16 | if (index .eq. 1) then 17 | call ciptok(typbuf,ibp,sub) 18 | if (sub .eq. 'eoi') then 19 | scale = spmin 20 | elseif (sub .eq. 'x') then 21 | scale = spmin 22 | elseif (sub(1:1) .eq. 's') then 23 | scale = 1.0 24 | elseif (sub(1:1) .eq. 'm') then 25 | scale = spmin 26 | elseif (sub(1:1) .eq. 'h') then 27 | scale = sphr 28 | elseif (sub(1:1) .eq. 'd') then 29 | scale = spday 30 | else 31 | scale = spmin 32 | endif 33 | c 34 | c frequency units - convert everything to mhz 35 | c -- note that this implies scale/value for "s" 36 | c 37 | elseif (index .eq. 2) then 38 | call ciptok(typbuf,ibp,sub) 39 | if (sub .eq. 'eoi') then 40 | scale = 1.0 41 | elseif (sub .eq. 'x') then 42 | scale = 1.0 43 | elseif (sub(1:1) .eq. 's') then 44 | scale = 1000. 45 | elseif (sub(1:1) .eq. 'h') then 46 | scale = 1000. 47 | elseif (sub(1:1) .eq. 'r') then 48 | scale = rad 49 | else 50 | scale = 1.0 51 | endif 52 | end if 53 | return 54 | end 55 | -------------------------------------------------------------------------------- /src/libutil/interple.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | real function interple(n1, n2, x, dx, xlast, y, m, b) 5 | c 6 | c given the coefficients for linear interpolation 7 | c this routine calculates y for an input x 8 | c 9 | c inputs: 10 | c n1: lower bound 11 | c n2: upper bound 12 | c x(n): array of x-values 13 | c dx: point a which the function is to be evaluated 14 | c y(n): function to be interpolated 15 | c m(n-1): slopes 16 | c b(n-1): intercepts 17 | c returned 18 | c y: interpolated value 19 | c 20 | real x(*), dx, y(*) 21 | real b(*), m(*), xlast 22 | c 23 | do i = n1, n2 24 | if (dx .eq. x(i)) then 25 | if (dx .eq. x(i+1)) then 26 | if (xlast .eq. 0.) then 27 | interple = y(i+1) 28 | return 29 | elseif (xlast .lt. x(i)) then 30 | interple = y(i) 31 | return 32 | else 33 | interple = y(i+1) 34 | return 35 | endif 36 | else 37 | interple = y(i) 38 | return 39 | endif 40 | elseif ((dx .gt. x(i)) .and. (dx .lt. x(i+1))) then 41 | if (m(i) .ge. 999.0) then 42 | if (xlast .lt. dx) then 43 | interple = y(i) 44 | else 45 | interple = y(i+1) 46 | endif 47 | else 48 | interple = m(i)*dx + b(i) 49 | endif 50 | return 51 | endif 52 | end do 53 | 20 continue 54 | c 55 | c outside array bounds - extrapolate 56 | c 57 | if (dx .lt. x(n1)) then 58 | interple = m(n1)*dx + b(n1) 59 | elseif (dx .gt. x(n2)) then 60 | interple = m(n2)*dx + b(n2) 61 | else 62 | print*,' error in interpolation' 63 | endif 64 | return 65 | end 66 | -------------------------------------------------------------------------------- /src/libutil/interpol.f: -------------------------------------------------------------------------------- 1 | subroutine interpol(n1, n2, x, y, m, b) 2 | c 3 | c computes the coefficients for linear interpolation 4 | c y = mx + b 5 | c 6 | c inputs: 7 | c n1: lower bound for interpolation 8 | c n2: upper bound for interpolation 9 | c x(n): points at which the function is evaluated 10 | c y(n): function to be interpolated 11 | c outputs: 12 | c m(n): slopes of lines 13 | c b(n): intercepts 14 | c 15 | save 16 | real*4 x(*), y(*) 17 | real*4 b(*), m(*) 18 | c 19 | do i = n1, n2-1 20 | dx = x(i+1) - x(i) 21 | dy = y(i+1) - y(i) 22 | if (dx .eq. 0.) then 23 | m(i) = 999.0 24 | else 25 | m(i) = dy/dx 26 | endif 27 | b(i) = y(i) - m(i)*x(i) 28 | c b(i) = y(i) 29 | end do 30 | return 31 | end 32 | -------------------------------------------------------------------------------- /src/libutil/ival.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | integer function ival(ifunc) 5 | c 6 | c returns 1 ifunc .gt. 0 7 | c 0 otherwise 8 | c 9 | integer ifunc 10 | c 11 | if (ifunc .gt. 0) then 12 | ival = 1 13 | else 14 | ival = 0 15 | endif 16 | c 17 | return 18 | end 19 | -------------------------------------------------------------------------------- /src/libutil/kblnk.f: -------------------------------------------------------------------------------- 1 | subroutine kblnk(string,k) 2 | c 3 | c returns the position of the first blank in a string 4 | c 5 | character*(*) string 6 | character*1 blank 7 | data blank/' '/ 8 | c 9 | k=0 10 | l=len(string) 11 | do i=1,l 12 | if(string(i:i) .eq. blank) go to 2 13 | k=i 14 | end do 15 | 2 return 16 | end 17 | -------------------------------------------------------------------------------- /src/libutil/klen.f: -------------------------------------------------------------------------------- 1 | subroutine klen(string,k) 2 | c 3 | c returns effect length of string - based on longue 4 | c 5 | character*(*) string 6 | character*1 blank 7 | data blank/' '/ 8 | c 9 | k=0 10 | l=len(string) 11 | do i=l,1,-1 12 | if (string(i:i) .ne. blank) go to 2 13 | end do 14 | i=0 15 | 2 continue 16 | k=i 17 | return 18 | end 19 | -------------------------------------------------------------------------------- /src/libutil/lexist.f: -------------------------------------------------------------------------------- 1 | 2 | logical function lexist (filename) 3 | 4 | c Function to determine whether "filename" exists. 5 | 6 | 7 | character*(*) filename 8 | integer*4 nblen 9 | 10 | if (nblen(filename) .eq. 0) then 11 | lexist = .false. 12 | else 13 | inquire (file = filename, exist = lexist) 14 | if (.not. lexist) then 15 | print*, filename (1:nblen (filename)), ' does not exist.' 16 | else 17 | end if 18 | end if 19 | 20 | return 21 | 22 | end 23 | -------------------------------------------------------------------------------- /src/libutil/llen.f: -------------------------------------------------------------------------------- 1 | c================================== 2 | function llen(string) 3 | character*(*) string 4 | llen=lnblnk(string) 5 | return 6 | end 7 | -------------------------------------------------------------------------------- /src/libutil/lnblnk.f: -------------------------------------------------------------------------------- 1 | 2 | function lnblnk(string) 3 | 4 | c**** find the # length of a text string, defined as the 5 | c**** position of the last non-blank character. 6 | 7 | c**** this is a UTX/32 intrinsic 8 | c**** may 88 9 | 10 | character*(*) string 11 | 12 | c**** get # bytes in string 13 | 14 | nbytes = len(string) 15 | 16 | lnb = 0 17 | 18 | do i = nbytes,1,-1 19 | if(string(i:i) .ne. ' ') then 20 | lnb = i 21 | go to 200 22 | end if 23 | end do 24 | 25 | 200 continue 26 | lnblnk = lnb 27 | 28 | return 29 | end 30 | -------------------------------------------------------------------------------- /src/libutil/lpyr.f: -------------------------------------------------------------------------------- 1 | INTEGER FUNCTION LPYR(YEAR) 2 | C 3 | C Function lpyr determines if year 4 | C is a leap year. 5 | C 6 | C This function uses the intrinsic 7 | C function mod. If your machine 8 | C does not supply this function, 9 | C make one - 10 | C mod(i,j) = iabs(i - (i/j)*j) 11 | C 12 | c returns 1 for leap year, 0 otherwise -- jbg 6/97 13 | C 14 | C Calls: 15 | C mod - intrinsic funtion 16 | C 17 | C Programmed by Madeleine Zirbes 18 | C September 15,1980 19 | C 20 | C YEAR - INPUT 21 | INTEGER YEAR 22 | IF (.NOT.(MOD(YEAR, 400) .EQ. 0)) GOTO 6100 23 | LPYR = (1) 24 | RETURN 25 | 6100 CONTINUE 26 | IF (.NOT.(MOD(YEAR, 4) .NE. 0)) GOTO 6120 27 | LPYR = (0) 28 | RETURN 29 | 6120 CONTINUE 30 | IF (.NOT.(MOD(YEAR, 100) .EQ. 0)) GOTO 6140 31 | LPYR = (0) 32 | RETURN 33 | 6140 CONTINUE 34 | LPYR = (1) 35 | RETURN 36 | END 37 | -------------------------------------------------------------------------------- /src/libutil/makefile: -------------------------------------------------------------------------------- 1 | FFLAGS=$(MYFFLAGS) 2 | # FFLAGS= -fast -O3 3 | #FFLAGS= $(MYFFLAGS) 4 | LIBNAM= $(MINEOSLIB)/libutil.a 5 | # 6 | .f.a: 7 | gfortran $(FFLAGS) -c $< 8 | ar rv $@ $*.o 9 | rm -f $*.o 10 | # 11 | # objects for utility library 12 | # 13 | # 14 | $(LIBNAM): \ 15 | $(LIBNAM)(angles.o) \ 16 | $(LIBNAM)(azimth.o) \ 17 | $(LIBNAM)(cipget.o) \ 18 | $(LIBNAM)(cipnum.o) \ 19 | $(LIBNAM)(cipped.o) \ 20 | $(LIBNAM)(cipscn.o) \ 21 | $(LIBNAM)(cipstr.o) \ 22 | $(LIBNAM)(cipsub.o) \ 23 | $(LIBNAM)(ciptok.o) \ 24 | $(LIBNAM)(ciptyp.o) \ 25 | $(LIBNAM)(daymo.o) \ 26 | $(LIBNAM)(doy.o) \ 27 | $(LIBNAM)(ellip.o) \ 28 | $(LIBNAM)(fcn.o) \ 29 | $(LIBNAM)(gcpath.o) \ 30 | $(LIBNAM)(gcpath_e.o) \ 31 | $(LIBNAM)(get_bath.o) \ 32 | $(LIBNAM)(get_unit.o) \ 33 | $(LIBNAM)(interpol.o) \ 34 | $(LIBNAM)(interple.o) \ 35 | $(LIBNAM)(ival.o) \ 36 | $(LIBNAM)(kblnk.o) \ 37 | $(LIBNAM)(klen.o) \ 38 | $(LIBNAM)(lpyr.o) \ 39 | $(LIBNAM)(llen.o) \ 40 | $(LIBNAM)(kblnk.o) \ 41 | $(LIBNAM)(lnblnk.o) \ 42 | $(LIBNAM)(maxsp.o) \ 43 | $(LIBNAM)(midpnt.o) \ 44 | $(LIBNAM)(midpnt_e.o) \ 45 | $(LIBNAM)(moment_a.o) \ 46 | $(LIBNAM)(moment_rtf.o) \ 47 | $(LIBNAM)(mtimes.o) \ 48 | $(LIBNAM)(mtimes_e.o) \ 49 | $(LIBNAM)(pick_filter.o) \ 50 | $(LIBNAM)(rspln.o) \ 51 | $(LIBNAM)(sadd.o) \ 52 | $(LIBNAM)(sdcoht.o) \ 53 | $(LIBNAM)(sdiff.o) \ 54 | $(LIBNAM)(sec_time.o) \ 55 | $(LIBNAM)(sec_time_inv.o) \ 56 | $(LIBNAM)(dsec_time.o) \ 57 | $(LIBNAM)(dsec_time_inv.o) \ 58 | $(LIBNAM)(sort.o) \ 59 | $(LIBNAM)(splint.o) \ 60 | $(LIBNAM)(spread.o) \ 61 | $(LIBNAM)(swap.o) \ 62 | $(LIBNAM)(ttimes.o) \ 63 | $(LIBNAM)(xyz2geo.o) 64 | ranlib $(LIBNAM) 65 | # 66 | # dependencies 67 | # 68 | $(LIBNAM)(gcpath.o): numerical.h 69 | $(LIBNAM)(gcpath_e.o): numerical.h 70 | $(LIBNAM)(moment_a.o): numerical.h 71 | $(LIBNAM)(moment_rtf.o): numerical.h 72 | $(LIBNAM)(mtimes.o): parameter.f 73 | $(LIBNAM)(mtimes_e.o): parameter.f 74 | $(LIBNAM)(mtimes_e.o): numerical.h 75 | $(LIBNAM)(pick_filter.o): numerical.h 76 | $(LIBNAM)(sec_time.o): numerical.h 77 | $(LIBNAM)(sec_time_inv.o): numerical.h 78 | $(LIBNAM)(spread.o): numerical.h 79 | $(LIBNAM)(ttimes.o): parameter.f 80 | -------------------------------------------------------------------------------- /src/libutil/maxsp.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine maxsp(x,low,high,max,maxloc,min1,minl1,min2,minl2,idum) 5 | c 6 | c maxsp locates the absolute maximum time sample in a time series 7 | c 8 | c for idum = 1, it searches for the max positive amplitude 9 | c for idum = -1, it searchs for the max absolute amplitude 10 | c 11 | integer*4 low, high, maxloc, minl1, minl2, isg, idum 12 | real*4 x(*), amax, min1, min2, max 13 | c 14 | amax = -99999999999.0 15 | c 16 | c seek max positive amplitude 17 | c 18 | if (idum .gt. 0) then 19 | do j = low, high 20 | if (x(j) .gt. amax) then 21 | max = x(j) 22 | maxloc = j 23 | amax = max 24 | end if 25 | end do 26 | else 27 | c 28 | c seek max absolute amplitude 29 | c 30 | do j = low, high 31 | if (abs(x(j)) .gt. amax) then 32 | max = x(j) 33 | maxloc = j 34 | amax = abs(max) 35 | end if 36 | end do 37 | end if 38 | c 39 | if (max .le. 0.) then 40 | isg = -1 41 | else 42 | isg = 1 43 | endif 44 | c 45 | c search forward and back for the associated minimums 46 | c 47 | if (isg .ne. -1) then 48 | do j = maxloc - 1, low, -1 49 | if (x(j-1) .gt. x(j)) then 50 | min1 = x(j) 51 | minl1 = j 52 | go to 15 53 | endif 54 | end do 55 | 15 continue 56 | do j = maxloc + 1, high, 1 57 | if (x(j+1) .gt. x(j)) then 58 | min2 = x(j) 59 | minl2 = j 60 | go to 20 61 | endif 62 | end do 63 | 20 continue 64 | else 65 | do j = maxloc - 1, low, -1 66 | if (x(j-1) .lt. x(j)) then 67 | min1 = x(j) 68 | minl1 = j 69 | go to 25 70 | endif 71 | end do 72 | 25 continue 73 | do j = maxloc + 1, high, 1 74 | if (x(j+1) .lt. x(j)) then 75 | min2 = x(j) 76 | minl2 = j 77 | go to 30 78 | endif 79 | end do 80 | 30 continue 81 | endif 82 | return 83 | end 84 | -------------------------------------------------------------------------------- /src/libutil/midpnt.f: -------------------------------------------------------------------------------- 1 | subroutine midpnt(ealat,ealong,slat,slong,theta,phi) 2 | c 3 | c Subroutine to determine the mid-point between two points on the 4 | c earth's surface. The earth is assumed to be spherical. 5 | c 6 | c inputs 7 | c ealat is earthquake latitude 8 | c ealong is earthquake longitude 9 | c slat is station latitiude 10 | c slong is station longitude 11 | c outputs 12 | c theta is mid-point latitude 13 | c phi is mid-point longitude 14 | c 15 | c all latitudes and longitudes are in degrees 16 | c latitude is positive north, negative south 17 | c longitude is positive east, negative west 18 | c 19 | real n 20 | real l1, l2, l3, mm1, mm2, mm3 21 | c 22 | common/b2/l1,l2,l3,mm1,mm2,mm3,factor 23 | c 24 | external fcn 25 | c 26 | data n/1hn/,s/1hs/,e/1he/,w/1hw/ 27 | pi=3.14159265358 28 | factor=pi/180. 29 | c 30 | c Aa1,aa2,aa3 are cartesian coordinates of projected earthquake sour 31 | c c1,c2,c3 are cartesian coordinates of station 32 | c 33 | eathet=ealat*factor 34 | eaphi=ealong*factor 35 | aa1= cos(eathet)* cos(eaphi) 36 | aa2= cos(eathet)* sin(eaphi) 37 | aa3= sin(eathet) 38 | stheta=slat*factor 39 | sphi=slong*factor 40 | c1= cos(stheta)* cos(sphi) 41 | c2= cos(stheta)* sin(sphi) 42 | c3= sin(stheta) 43 | mm1=aa3*c2-aa2*c3 44 | mm2=aa1*c3-aa3*c1 45 | mm3=aa2*c1-aa1*c2 46 | l1=aa1-c1 47 | l2=aa2-c2 48 | l3=aa3-c3 49 | r1=l3*mm2-l2*mm3 50 | r2=l1*mm3-l3*mm1 51 | c Test to find right phi 52 | z=r2/r1 53 | ph1= atan(z) 54 | phi1=ph1/factor 55 | if(phi1.le.0.) phi2=phi1+180. 56 | if(phi1.gt.0.) phi2=phi1-180. 57 | clat1=fcn(phi1) 58 | clat2=fcn(phi2) 59 | c 60 | c Pick right solution 61 | c 62 | q1=clat1*factor 63 | q2=phi1*factor 64 | q3=clat2*factor 65 | q4=phi2*factor 66 | b11= cos(q1)* cos(q2) 67 | b21= cos(q1)* sin(q2) 68 | b31= sin(q1) 69 | b12= cos(q3)* cos(q4) 70 | b22= cos(q3)* sin(q4) 71 | b32= sin(q3) 72 | dot1=aa1*b11+aa2*b21+aa3*b31 73 | dot2=aa1*b12+aa2*b22+aa3*b32 74 | if(dot1.gt.dot2) phi=phi1 75 | if(dot2.gt.dot1) phi=phi2 76 | if(phi.eq.phi1) theta=clat1 77 | if(phi.eq.phi2) theta=clat2 78 | 1000 continue 79 | return 80 | end 81 | -------------------------------------------------------------------------------- /src/libutil/midpnt_e.f: -------------------------------------------------------------------------------- 1 | subroutine midpnt_e(ealat,ealong,slat,slong,theta,phi) 2 | c 3 | c Subroutine to determine the mid-point between two points on the 4 | c earth's surface. 5 | c 6 | c This version uses geocentric coordinates 7 | c 8 | c inputs 9 | c ealat is earthquake latitude 10 | c ealong is earthquake longitude 11 | c slat is station latitiude 12 | c slong is station longitude 13 | c outputs 14 | c theta is mid-point latitude 15 | c phi is mid-point longitude 16 | c 17 | c all latitudes and longitudes are in degrees 18 | c latitude is positive north, negative south 19 | c longitude is positive east, negative west 20 | c 21 | real*4 n, l1, l2, l3, mm1, mm2, mm3 22 | c 23 | common/b2/l1,l2,l3,mm1,mm2,mm3,factor 24 | c 25 | data n/1hn/,s/1hs/,e/1he/,w/1hw/ 26 | c 27 | include 'numerical.h' 28 | c 29 | factor = drad 30 | e = 1.0/flt 31 | a = (1.0 - e)**2 32 | b = 1.0/a 33 | c 34 | c Aa1,aa2,aa3 are cartesian coordinates of projected earthquake sour 35 | c c1,c2,c3 are cartesian coordinates of station 36 | c 37 | eathet=ealat*factor 38 | ccc 39 | beta = atan( a * tan(eathet)) 40 | eathet = beta 41 | ccc 42 | eaphi=ealong*factor 43 | aa1= cos(eathet)* cos(eaphi) 44 | aa2= cos(eathet)* sin(eaphi) 45 | aa3= sin(eathet) 46 | stheta=slat*factor 47 | ccc 48 | beta = atan( a * tan(stheta)) 49 | stheta = beta 50 | ccc 51 | sphi=slong*factor 52 | c1= cos(stheta)* cos(sphi) 53 | c2= cos(stheta)* sin(sphi) 54 | c3= sin(stheta) 55 | mm1=aa3*c2-aa2*c3 56 | mm2=aa1*c3-aa3*c1 57 | mm3=aa2*c1-aa1*c2 58 | l1=aa1-c1 59 | l2=aa2-c2 60 | l3=aa3-c3 61 | r1=l3*mm2-l2*mm3 62 | r2=l1*mm3-l3*mm1 63 | c Test to find right phi 64 | z=r2/r1 65 | ph1= atan(z) 66 | phi1=ph1/factor 67 | if(phi1.le.0.) phi2=phi1+180. 68 | if(phi1.gt.0.) phi2=phi1-180. 69 | clat1=fcn(phi1) 70 | clat2=fcn(phi2) 71 | ccc 72 | beta = clat1*factor 73 | clat1 = atan(b*tan(beta))/factor 74 | beta = clat2*factor 75 | clat2 = atan(b*tan(beta))/factor 76 | ccc 77 | c 78 | c Pick right solution 79 | c 80 | q1=clat1*factor 81 | q2=phi1*factor 82 | q3=clat2*factor 83 | q4=phi2*factor 84 | b11= cos(q1)* cos(q2) 85 | b21= cos(q1)* sin(q2) 86 | b31= sin(q1) 87 | b12= cos(q3)* cos(q4) 88 | b22= cos(q3)* sin(q4) 89 | b32= sin(q3) 90 | dot1=aa1*b11+aa2*b21+aa3*b31 91 | dot2=aa1*b12+aa2*b22+aa3*b32 92 | if(dot1.gt.dot2) phi=phi1 93 | if(dot2.gt.dot1) phi=phi2 94 | if(phi.eq.phi1) theta=clat1 95 | if(phi.eq.phi2) theta=clat2 96 | 1000 continue 97 | return 98 | end 99 | -------------------------------------------------------------------------------- /src/libutil/moment_a.f: -------------------------------------------------------------------------------- 1 | c 2 | subroutine moment_a(xm,azm,a) 3 | c 4 | c compute "a" functions for adding "fundamental faults" 5 | c ala Jost and Herrmann, SRL, 60, 37-57, 1989 6 | c 7 | real*4 xm(*), a(*), azm, az 8 | real*4 mxx, myy, mzz, mxy, mxz, myz 9 | include 'numerical.h' 10 | c 11 | c convert from spherical coordinate system to Aki and Richards 12 | c 13 | mzz = xm(1) 14 | mxx = xm(2) 15 | myy = xm(3) 16 | mxz = xm(4) 17 | myz = -xm(5) 18 | mxy = -xm(6) 19 | c 20 | az = azm * drad 21 | c1 = cos(az) 22 | c2 = cos(2.*az) 23 | s1 = sin(az) 24 | s2 = sin(2.*az) 25 | c 26 | a(1) = 0.5*(mxx - myy)*c2 + mxy*s2 27 | a(2) = mxz*c1 + myz*s1 28 | a(3) = -0.5*(mxx + myy) 29 | a(4) = 0.5*(mxx - myy)*s2 - mxy*c2 30 | a(5) = mxz*s1 - myz*c1 31 | a(6) = third*(mxx + myy + mzz) 32 | c 33 | return 34 | end 35 | -------------------------------------------------------------------------------- /src/libutil/moment_rtf.f: -------------------------------------------------------------------------------- 1 | c 2 | subroutine moment_rtf(strike,dip,rake,mo,xm) 3 | c 4 | c determine components of moment tensor from strike, dip, and rake 5 | c ala Aki and Richards, p. 117 6 | c 7 | real*4 xm(*), mo 8 | real*4 mxx, myy, mzz, mxy, mxz, myz 9 | include 'numerical.h' 10 | c 11 | st = strike*drad 12 | di = dip*drad 13 | ra = rake*drad 14 | c 15 | sid = sin(di) 16 | si2d = sin(2.*di) 17 | cod = cos(di) 18 | co2d = cos(2.*di) 19 | sir = sin(ra) 20 | cor = cos(ra) 21 | sins = sin(st) 22 | sin2s = sin(2.*st) 23 | coss = cos(st) 24 | cos2s = cos(2.*st) 25 | c 26 | mxx = -mo*(sid*cor*sin2s + si2d*sir*sins*sins) 27 | mxy = mo*(sid*cor*cos2s + 0.5*si2d*sir*sin2s) 28 | mxz = -mo*(cod*cor*coss + co2d*sir*sins) 29 | myy = mo*(sid*cor*sin2s - si2d*sir*coss*coss) 30 | myz = -mo*(cod*cor*sins - co2d*sir*coss) 31 | mzz = mo*si2d*sir 32 | c 33 | c convert to spherical coordinate system 34 | c 35 | c mzz = mrr 36 | c mxx = mtt 37 | c myy = mff 38 | c mxy = -mtf 39 | c mxz = mrt 40 | c myz = -mrf 41 | c 42 | xm(1) = mzz 43 | xm(2) = mxx 44 | xm(3) = myy 45 | xm(4) = mxz 46 | xm(5) = -myz 47 | xm(6) = -mxy 48 | c 49 | return 50 | end 51 | -------------------------------------------------------------------------------- /src/libutil/nblen.f: -------------------------------------------------------------------------------- 1 | integer function nblen (string) 2 | c 3 | c given a character string, nblen returns the length of the string 4 | c to the last non-blank character, presuming the string is left- 5 | c justified, i.e. if string = ' xs j ', nblen = 8. 6 | c 7 | c called non-library routines: none 8 | c language: standard fortran 77 9 | c 10 | integer ls, i 11 | character*(*) string, blank*1, null*1 12 | data blank /' '/ 13 | c 14 | null = char(0) 15 | nblen = 0 16 | ls = len(string) 17 | if (ls .eq. 0) return 18 | do 1 i = ls, 1, -1 19 | if (string(i:i) .ne. blank .and. string(i:i) .ne. null) go to 2 20 | 1 continue 21 | return 22 | 2 nblen = i 23 | return 24 | end 25 | -------------------------------------------------------------------------------- /src/libutil/numerical.h: -------------------------------------------------------------------------------- 1 | c 2 | c include file for useful constants 3 | c 4 | c pi = 3.14159265350 5 | c 6 | pi = 4.*atan(1.0) 7 | tpi = 2.0*pi 8 | pi2 = 0.5*pi 9 | pi4 = 0.25*pi 10 | c 11 | c drad - degrees to radians 12 | c 13 | drad = pi/180. 14 | c 15 | c radd - radians to degrees 16 | c 17 | radd = 180./pi 18 | c 19 | c rmhz - radians/s to mhz 20 | c 21 | rmhz = 1000./tpi 22 | c 23 | c rad - mhz to radians/s 24 | c 25 | rad = 1.0/rmhz 26 | c 27 | c rn - earth radius in meters 28 | c 29 | rn = 6371000.0 30 | c 31 | c rnk - earth radius in km 32 | c 33 | rnk = 6371. 34 | c 35 | c dkm - degrees to km 36 | c 37 | dkm = rnk*drad 38 | c 39 | bigg = 6.6732e-11 40 | rhobar = 5515.0 41 | c 42 | third = 1.0/3.0 43 | tthird = 2.0/3.0 44 | fthird = 4.0/3.0 45 | c 46 | c for Barbara's mode scalings 47 | c 48 | gn = pi*bigg*rhobar*rn 49 | vn2 = gn*rn 50 | vn = sqrt(vn2) 51 | wn = vn/rn 52 | c 53 | c time - for counting seconds 54 | c 55 | spmin = 60. 56 | sphr = 3600. 57 | spday = 86400. 58 | c 59 | c ellipiticy 60 | c 61 | flt = 298.25 62 | c 63 | -------------------------------------------------------------------------------- /src/libutil/parameter.f: -------------------------------------------------------------------------------- 1 | integer*4 npmax,npmax2,npmax4,nsmax,ncmax,nlmax,nphase 2 | integer*4 maxcal,mkine,mrayp 3 | c 4 | c npmax is the standard dimension for arrays -- it is used in 5 | c some programs that DOUBLE the trace (i.e. xcor) so it needs to 6 | c be twice what you need -- kind of a space waste, should be 7 | c changed eventually... 8 | c 9 | parameter (npmax = 400000) 10 | c 11 | c npmax2 is (npmax+2)/2 for the fft 12 | c 13 | parameter (npmax2 = 200001) 14 | c 15 | c what is this used for -- can't find it? 16 | c 17 | parameter (npmax4 = 640004) 18 | parameter (nsmax = 120) 19 | parameter (ncmax = 3) 20 | parameter (nlmax = 100) 21 | parameter (nphase = 100) 22 | parameter (maxcal = 5000) 23 | parameter (mkine = 10) 24 | parameter (mrayp = 100) 25 | -------------------------------------------------------------------------------- /src/libutil/sadd.bug: -------------------------------------------------------------------------------- 1 | subroutine sadd(dateo,rdiff) 2 | c 3 | c subtracts rdiff seconds to dateo 4 | c 5 | integer*4 dateo(6) 6 | real*4 rdiff 7 | c 8 | c print*, dateo, rdiff 9 | c 10 | iyear = dateo(1) 11 | iday = dateo(2) 12 | ihour = dateo(3) 13 | imin = dateo(4) 14 | isec = dateo(5) - int(rdiff) 15 | msec = dateo(6) - (rdiff - int(rdiff))*1000. 16 | c 17 | ly = lpyr(iyear) 18 | if (ly .eq. 0) then 19 | jd = 366 20 | else 21 | jd = 365 22 | endif 23 | c 24 | c print*, iyear, iday, ihour, imin, isec, msec 25 | c 26 | if (abs(msec) .ge. 1000) then 27 | irmsec = msec/1000 28 | msec = msec - irmsec * 1000 29 | isec = isec + irmsec 30 | endif 31 | if (msec .lt. 0) then 32 | isec = isec - 1 33 | msec = 1000 + msec 34 | endif 35 | dateo(6) = msec 36 | c 37 | if (abs(isec) .ge. 60) then 38 | irisec = isec/60 39 | isec = isec - irisec * 60 40 | imin = imin + irisec 41 | endif 42 | if (isec .lt. 0) then 43 | imin = imin - 1 44 | isec = 60 + isec 45 | endif 46 | dateo(5) = isec 47 | c 48 | if (abs(imin) .ge. 60) then 49 | irimin = imin/60 50 | imin = imin - irimin * 60 51 | ihour = ihour + irimin 52 | endif 53 | if (imin .lt. 0) then 54 | ihour = ihour - 1 55 | imin = 60 + imin 56 | endif 57 | dateo(4) = imin 58 | c 59 | if (abs(ihour) .ge. 24) then 60 | irihour = ihour/24 61 | ihour = ihour - irihour * 24 62 | iday = iday + irihour 63 | endif 64 | if (ihour .lt. 0) then 65 | iday = iday - 1 66 | ihour = 24 + ihour 67 | endif 68 | dateo(3) = ihour 69 | c 70 | if (abs(iday) .ge. jd) then 71 | iriday = iday/jd 72 | iday = iday - iriday * jd 73 | iyear = iyear + iriday 74 | endif 75 | if (iday .lt. 0) then 76 | iyear = iyear - 1 77 | iday = jd + iday 78 | endif 79 | dateo(2) = iday 80 | dateo(1) = iyear 81 | c 82 | c print*, dateo 83 | c 84 | return 85 | end 86 | -------------------------------------------------------------------------------- /src/libutil/sadd.f: -------------------------------------------------------------------------------- 1 | subroutine sadd(dateo,rdiff) 2 | c 3 | c subtracts rdiff seconds to dateo 4 | c 5 | integer*4 dateo(6) 6 | real*4 rdiff 7 | c 8 | c print*, dateo, rdiff 9 | c 10 | iyear = dateo(1) 11 | iday = dateo(2) 12 | ihour = dateo(3) 13 | imin = dateo(4) 14 | isec = dateo(5) - int(rdiff) 15 | msec = dateo(6) - (rdiff - int(rdiff))*1000. 16 | c 17 | ly = lpyr(iyear) 18 | if (ly .eq. 0) then 19 | jd = 365 20 | else 21 | jd = 366 22 | endif 23 | c 24 | c print*, iyear, iday, ihour, imin, isec, msec 25 | c 26 | if (abs(msec) .ge. 1000) then 27 | irmsec = msec/1000 28 | msec = msec - irmsec * 1000 29 | isec = isec + irmsec 30 | endif 31 | if (msec .lt. 0) then 32 | isec = isec - 1 33 | msec = 1000 + msec 34 | endif 35 | dateo(6) = msec 36 | c 37 | if (abs(isec) .ge. 60) then 38 | irisec = isec/60 39 | isec = isec - irisec * 60 40 | imin = imin + irisec 41 | endif 42 | if (isec .lt. 0) then 43 | imin = imin - 1 44 | isec = 60 + isec 45 | endif 46 | dateo(5) = isec 47 | c 48 | if (abs(imin) .ge. 60) then 49 | irimin = imin/60 50 | imin = imin - irimin * 60 51 | ihour = ihour + irimin 52 | endif 53 | if (imin .lt. 0) then 54 | ihour = ihour - 1 55 | imin = 60 + imin 56 | endif 57 | dateo(4) = imin 58 | c 59 | if (abs(ihour) .ge. 24) then 60 | irihour = ihour/24 61 | ihour = ihour - irihour * 24 62 | iday = iday + irihour 63 | endif 64 | if (ihour .lt. 0) then 65 | iday = iday - 1 66 | ihour = 24 + ihour 67 | endif 68 | dateo(3) = ihour 69 | c 70 | if (abs(iday) .ge. jd) then 71 | iriday = iday/jd 72 | iday = iday - iriday * jd 73 | iyear = iyear + iriday 74 | endif 75 | if (iday .lt. 0) then 76 | iyear = iyear - 1 77 | iday = jd + iday 78 | endif 79 | dateo(2) = iday 80 | dateo(1) = iyear 81 | c 82 | c print*, dateo 83 | c 84 | return 85 | end 86 | -------------------------------------------------------------------------------- /src/libutil/sdcoht.f: -------------------------------------------------------------------------------- 1 | subroutine sdcoht(time, deltatime) 2 | c version pour deltatime en secondes modified 13/10/89 3 | integer*4 time(6), deltatime, modul(6) 4 | data modul / 0, 365, 24, 2*60, 1000 / 5 | if (deltatime.lt.0.) then 6 | write (*,*) '** subr addcoht neg argument',deltatime,time 7 | stop 8 | endif 9 | if (mod(time(1),4).eq.0) then 10 | modul(2)=366 11 | else 12 | modul(2)=365 13 | endif 14 | time(2)=time(2)-1 15 | j1 = deltatime 16 | do j = 5, 2, -1 17 | j2 = time(j) + j1 18 | time(j) = mod(j2,modul(j)) 19 | if (j2 .eq. time(j)) then 20 | go to 80 21 | else 22 | j1 = j2 / modul(j) 23 | end if 24 | enddo 25 | c supposes less than a year span, to be changed (be carefull for bissextile) 26 | time(1) = time(1) + 1 27 | 80 time(2)=time(2)+1 28 | return 29 | end 30 | -------------------------------------------------------------------------------- /src/libutil/sdiff.f: -------------------------------------------------------------------------------- 1 | double precision function sdiff (dateo,daten) 2 | c 3 | c returns the difference in the input dates 4 | c J. Borsenberger 17/4/89 modified 13/10/89 5 | c 6 | implicit double precision (a-h,o-z) 7 | integer*4 dateo(6),daten(6) 8 | c 9 | jour=daten(2)-dateo(2) 10 | if (daten(1).gt.dateo(1)) then 11 | do iannee=dateo(1),daten(1)-1 12 | if (mod(iannee,4).eq.0 .and. mod(iannee,2000).ne.0) then 13 | jour=jour+366 14 | else 15 | jour=jour+365 16 | endif 17 | enddo 18 | else if (daten(1).lt.dateo(1)) then 19 | do iannee=daten(1),dateo(1)-1 20 | if (mod(iannee,4).eq.0 .and. mod(iannee,2000).ne.0) then 21 | jour=jour-366 22 | else 23 | jour=jour-365 24 | endif 25 | enddo 26 | endif 27 | sdiff= 1.d-3*(daten(6)-dateo(6))+ daten(5)-dateo(5)+ 28 | 1 6.d1*(daten(4)-dateo(4) + 6.d1* (daten(3)-dateo(3)+ 29 | 2 24.d0* jour )) 30 | return 31 | end 32 | -------------------------------------------------------------------------------- /src/libutil/sec_time.bug: -------------------------------------------------------------------------------- 1 | subroutine sec_time(iyr,idoy,ihr,imin,sec,ibyr,tsec) 2 | c 3 | c subroutine to convert time to sec relative to a base year 4 | c 5 | integer*4 iyr, idoy, ihr, imin, ibyr 6 | real*4 sec, tsec 7 | c 8 | include 'numerical.h' 9 | c 10 | c first account for day, hour, minutes, and seconds 11 | c 12 | tsec = float(idoy)*spday + float(ihr)*sphr 13 | . + float(imin)*spmin 14 | . + sec 15 | c 16 | c now calculate the year offset 17 | c 18 | icount = 0 19 | do ii = 1, iyr-ibyr 20 | ierr = lpyr(ibyr + ii - 1) 21 | if (ierr .eq. 1) then 22 | iday = 365 23 | else 24 | iday = 366 25 | end if 26 | icount = icount + iday 27 | end do 28 | tsec = tsec + icount*spday 29 | c 30 | return 31 | end 32 | -------------------------------------------------------------------------------- /src/libutil/sec_time.f: -------------------------------------------------------------------------------- 1 | subroutine sec_time(iyr,idoy,ihr,imin,sec,ibyr,tsec) 2 | c 3 | c subroutine to convert time to sec relative to a base year 4 | c input time in gfs format (yr,day,hr,min,sec) and a reference 5 | c year for t=0 6 | c returns tsec, time in sec 7 | c 8 | c NOTE tsec should be double precision in calling program 9 | c to ensure accuracy. 10 | c 11 | integer*4 iyr, idoy, ihr, imin, ibyr 12 | real*4 sec,tsec 13 | real*8 ttmp 14 | c 15 | include 'numerical.h' 16 | c 17 | c first account for day, hour, minutes, and seconds 18 | c subtract 1 from idoy since idoy starts at 1, not zero 19 | c 20 | ttmp = dble(idoy-1)*spday + dble(ihr)*sphr 21 | . + dble(imin)*spmin 22 | . + sec 23 | c 24 | c now calculate the year offset 25 | c 26 | icount = 0 27 | do ii = 1, iyr-ibyr 28 | ierr = lpyr(ibyr + ii - 1) 29 | if (ierr .eq. 1) then 30 | iday = 366 31 | else 32 | iday = 365 33 | end if 34 | icount = icount + iday 35 | c print*,ibyr + ii - 1,iday,icount 36 | end do 37 | ttmp = ttmp + dble(icount)*spday 38 | tsec = sngl(ttmp) 39 | c 40 | return 41 | end 42 | -------------------------------------------------------------------------------- /src/libutil/sec_time_inv.f: -------------------------------------------------------------------------------- 1 | subroutine sec_time_inv(tsec,ibyr,iyr,idoy,ihr,imin,sec) 2 | c 3 | c subroutine to convert time in sec relative to a base year 4 | c to time in y,d,h,m,s. Inverts the action of sec_tim.f. 5 | c 6 | c input tsec and ibyr (reference year for t=0) 7 | c outut time in yr,d,h,m,s 8 | c 9 | c NOTE use dsec_time and dsec_time_inv for more accuracy 10 | c 11 | c 12 | integer*4 iyr, idoy, ihr, imin, ibyr, lpyr 13 | real*4 sec,tsec 14 | c 15 | include 'numerical.h' 16 | c 17 | c first account for year offset 18 | 19 | ierr = lpyr(ibyr) 20 | if (ierr .eq. 1) then 21 | iday = 366 22 | else 23 | iday = 365 24 | end if 25 | 26 | spyr = real(iday)*spday 27 | c nyr = int(tsec/spyr) 28 | c print*,nyr 29 | 30 | c add 1 to base year, and subtract correct number of seconds, 31 | c for each whole year of offset. Requires checking for leap 32 | c year and calculating spyr with each step. Loop is not 33 | c entered if tsec is less than a year. 34 | 35 | iyr = ibyr 36 | do while (tsec.ge.spyr) 37 | c i = 1,nyr 38 | tsec = tsec - spyr 39 | iyr = iyr + 1 40 | ierr = lpyr(iyr) 41 | if (ierr .eq. 1) then 42 | iday = 366 43 | else 44 | iday = 365 45 | end if 46 | spyr = real(iday)*spday 47 | end do 48 | 49 | c year should now be correct, and tsec is less than 1 year. Note 50 | c that idoy starts at 1 since there is no day 0. 51 | 52 | idoy = 1 + int(tsec/spday) 53 | tsec = tsec - real(idoy-1)*spday 54 | ihr = int(tsec/sphr) 55 | tsec = tsec - real(ihr)*sphr 56 | imin = int(tsec/spmin) 57 | sec = real(tsec) - real(imin)*spmin 58 | 59 | if(idoy.gt.iday .or. ihr.gt.24 .or. imin.gt.60 60 | & .or. sec.gt.60. .or. iday.lt.0 .or. ihr.lt.0 .or. 61 | & imin.lt.0 .or. sec.lt.0.) then 62 | print*,'**********' 63 | print*,'ERROR in sec_time_inv -- failed to reduce' 64 | print*,'**********' 65 | end if 66 | 67 | c 68 | return 69 | end 70 | -------------------------------------------------------------------------------- /src/libutil/sort.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine sort(n, array, nindex) 5 | c 6 | c subroutine to sort array in increasing order 7 | c and store the index of order in nindex 8 | c 9 | c taken from Numerical Recipes, Press et al., p. 233 10 | c 11 | real*4 array(*) 12 | integer*4 nindex(*) 13 | c 14 | c check for a single number 15 | c 16 | if (n .eq. 1) then 17 | nindex(1) = 1 18 | return 19 | endif 20 | c 21 | do j = 1, n 22 | nindex(j) = j 23 | end do 24 | l = (n/2) + 1 25 | ir = n 26 | 10 continue 27 | if (l .gt. 1) then 28 | l = l - 1 29 | ndt = nindex(l) 30 | q = array(ndt) 31 | else 32 | ndt = nindex(ir) 33 | q = array(ndt) 34 | nindex(ir) = nindex(1) 35 | ir = ir - 1 36 | if (ir .eq. 1) then 37 | nindex(1) = ndt 38 | return 39 | endif 40 | endif 41 | i = l 42 | j = l + l 43 | 20 if (j .le. ir) then 44 | if (j .lt. ir) then 45 | if(array(nindex(j)) .lt. array(nindex(j+1))) j = j + 1 46 | endif 47 | if (q .lt. array(nindex(j))) then 48 | nindex(i) = nindex(j) 49 | i = j 50 | j = j + j 51 | else 52 | j = ir + 1 53 | endif 54 | go to 20 55 | endif 56 | nindex(i) = ndt 57 | go to 10 58 | end 59 | -------------------------------------------------------------------------------- /src/libutil/splint.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE SPLINT(X,F,I1,I2,A) 2 | C A IS THE INTEGRAL OF F(X)DX FROM X(I1) TO X(I2) COMPUTED 3 | C BY INTEGRATINT THE CUBIC SPLINE DIRECTLY 4 | DIMENSION F(*),X(*),H(1001),Q(3,1001),WORK(3,1001) 5 | I2M1=I2-1 6 | DO 1 I=1,I2M1 7 | 1 H(I)=X(I+1)-X(I) 8 | T=1./3. 9 | CALL RSPLN(I1,I2,X,F,Q,WORK) 10 | A=0. 11 | DO 2 I=I1,I2M1 12 | B=H(I) 13 | A=A+B*(F(I)+B*(.5*Q(1,I)+B*(T*Q(2,I)+B*.25*Q(3,I)))) 14 | 2 CONTINUE 15 | RETURN 16 | END 17 | -------------------------------------------------------------------------------- /src/libutil/spread.f: -------------------------------------------------------------------------------- 1 | subroutine spread(p,dpdd,rs,rr,s_slow,r_slow,delta,b) 2 | c 3 | c subroutine to calculate geometrical spreading coefficient b 4 | c 5 | c p - ray parameter in s/deg 6 | c dpdd - dp/ddelta in s/rad/rad 7 | c rs - source radius in km 8 | c rr - receiver radius in km 9 | c s_slow - source slowness in s/km (scaled) 10 | c r_slow - receiver slowness in s/km (scaled) 11 | c delta - distance in deg 12 | c b - geometrical spreading coefficient 13 | c 14 | c spreading checked 6/9/92 against figure from Kovach and Anderson 15 | c 1/r**2 scaling is removed for stability! 16 | c 17 | c input assumed from ttimes 18 | c 19 | real*4 p, dpdd, rs, rr, s_slow, r_slow, delta 20 | real*4 s_vel, r_vel 21 | c 22 | include 'numerical.h' 23 | c 24 | c convert ray parameter and its derivative to s 25 | c 26 | pk = p * radd 27 | c 28 | c unscale the slowness and convert to velocity 29 | c 30 | s_vel = (1.0/s_slow)*(rs/rnk) 31 | r_vel = (1.0/r_slow)*(rr/rnk) 32 | c 33 | c 5/29/92 - my thinking on units may be incorrect 34 | c p is in sec/deg but dpdd may be in sec/rad/rad already 35 | c 36 | c dpk = dpdd * radd * radd 37 | c 38 | dpk = dpdd 39 | c 40 | dist = delta * drad 41 | c 42 | c calculate the take off angles 43 | c 44 | xs = asin(pk*s_vel/rs) 45 | xr = asin(pk*r_vel/rr) 46 | c 47 | xa = tan(xs)/(sin(dist)*cos(xr)) 48 | b = sqrt(xa * (s_vel/rs) * (abs(dpk)/(rr**2))) 49 | c 50 | c 1/r**2 scaling removed for stability 51 | c 52 | ccccccc 53 | b = sqrt(xa * (s_vel/rs) * (abs(dpk))) 54 | ccccccc 55 | c 56 | c print*,' geometrical spreading info' 57 | c print*, pk, dpk, xs*radd, xr*radd, delta, s_vel, r_vel 58 | c 59 | return 60 | end 61 | -------------------------------------------------------------------------------- /src/libutil/swap.f: -------------------------------------------------------------------------------- 1 | * FUNCTION TO SWAP BYTES IN 2 BYTE INTEGER 2 | integer*2 function iswap2(int0) 3 | 4 | integer*2 int0,itemp2 5 | character*1 char1(2),ctemp 6 | equivalence (itemp2,char1) 7 | 8 | itemp2=int0 9 | ctemp=char1(1) 10 | char1(1)=char1(2) 11 | char1(2)=ctemp 12 | iswap2=itemp2 13 | 14 | return 15 | end 16 | 17 | * FUNCTION TO SWAP BYTES IN 4 BYTE INTEGER 18 | integer*4 function iswap4(int0) 19 | 20 | integer*4 int0,itemp4 21 | character*1 char1(4),ctemp 22 | equivalence (itemp4,char1) 23 | 24 | itemp4=int0 25 | ctemp=char1(1) 26 | char1(1)=char1(4) 27 | char1(4)=ctemp 28 | ctemp=char1(2) 29 | char1(2)=char1(3) 30 | char1(3)=ctemp 31 | iswap4=itemp4 32 | 33 | return 34 | end 35 | 36 | * FUNCTION TO SWAP BYTES IN 4 BYTE REAL 37 | real*4 function rswap4(real0) 38 | 39 | real*4 real0,temp4 40 | character*1 char1(4),ctemp 41 | equivalence (temp4,char1) 42 | 43 | temp4=real0 44 | ctemp=char1(1) 45 | char1(1)=char1(4) 46 | char1(4)=ctemp 47 | ctemp=char1(2) 48 | char1(2)=char1(3) 49 | char1(3)=ctemp 50 | rswap4=temp4 51 | 52 | return 53 | end 54 | 55 | * FUNCTION TO SWAP BYTES IN 8 BYTE REAL 56 | real*8 function rswap8(real0) 57 | 58 | real*8 real0,temp8 59 | integer*4 iswap4,integ4(2),itemp4 60 | equivalence (temp8,integ4) 61 | 62 | temp8=real0 63 | integ4(1)=iswap4(integ4(1)) 64 | integ4(2)=iswap4(integ4(2)) 65 | itemp4=integ4(1) 66 | integ4(1)=integ4(2) 67 | integ4(2)=itemp4 68 | rswap8=temp8 69 | 70 | return 71 | end 72 | 73 | -------------------------------------------------------------------------------- /src/libutil/ttimes.f: -------------------------------------------------------------------------------- 1 | subroutine ttimes(zs,delta,plist,n,tt,dtdd,dtdh,dddp,phcd) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c zs - source depth (km) 6 | c delta - distance in degrees 7 | c plist - phase request 8 | c 9 | c n - number of phases 10 | c tt - array of travel times 11 | c dtdd - array of d time /d distance values 12 | c dtdh - array of d time /d depth values 13 | c dddp - array of d distane /d ray parameter values 14 | c phcd - array of phase names 15 | c 16 | save 17 | c 18 | include 'parameter.f' 19 | c 20 | logical prnt(3), lprem 21 | character*8 phcd(nphase),phlst(1), plist, plast 22 | character*80 modnam 23 | character*60 seismdir 24 | real*4 tt(nphase),dtdd(nphase),dtdh(nphase),dddp(nphase) 25 | real*4 usrc(2) 26 | c 27 | data plast /' '/ 28 | c 29 | common /t_slow/ usrc 30 | common /t_model/ lprem 31 | c 32 | in = 1 33 | c 34 | call getenv('SEISM',seismdir) 35 | call klen(seismdir,kl) 36 | c 37 | if (lprem) then 38 | modnam = seismdir(1:kl)//'/prem' 39 | else 40 | modnam = seismdir(1:kl)//'/iasp91' 41 | end if 42 | c 43 | do ii = 1, 3 44 | prnt(ii) = .false. 45 | end do 46 | do ii = 1, nphase 47 | tt(ii) = 0.0 48 | dtdd(ii) = 0.0 49 | dtdh(ii) = 0.0 50 | dddp(ii) = 0.0 51 | phcd(ii) = ' ' 52 | end do 53 | usrc(1) = 0.0 54 | usrc(2) = 0.0 55 | phlst(1) = plist 56 | n = 0 57 | nc = 1 58 | c 59 | if (plast .ne. plist) then 60 | close(in) 61 | call tabin(in,modnam) 62 | call brnset(nc,phlst,prnt) 63 | plast = plist 64 | endif 65 | c 66 | call depset(zs,usrc) 67 | c 68 | call trtm(delta,nphase,n,tt,dtdd,dtdh,dddp,phcd) 69 | c 70 | end 71 | -------------------------------------------------------------------------------- /src/libutil/xyz2geo.f: -------------------------------------------------------------------------------- 1 | subroutine xyz2geo(iflag,x,lat,lon,hght) 2 | 3 | * Convert Cartesian to geodetic coordinates assuming a given 4 | * reference ellipsoid (finv,semi) and geocenter offset t(3) 5 | * iflag = 1 xyz to geodetic 6 | * = 2 geodetic to xyz 7 | 8 | * lat and lon in degrees 9 | * hght in meters 10 | 11 | integer*4 i,iflag 12 | real*8 lat,lon,hght,x(3),semi,finv,t(3) 13 | real*8 f,e2,sinlat,coslat,sinlon,coslon,curvn 14 | real*8 sqr,lat0,cutoff 15 | real*8 pi,rad_to_deg 16 | 17 | * Numerical constants 18 | parameter ( pi = 3.1415926535897932D0 ) 19 | parameter ( rad_to_deg = 180.d0 /pi ) 20 | 21 | * GRS80 ellipsoid used by NAD83 and WGS84 22 | data semi,finv,(t(i),i=1,3)/6378137.,298.257222101,0.,0.,0./ 23 | 24 | f= 1.d0/finv 25 | e2= 2.d0*f - f*f 26 | 27 | if( iflag.eq.1) then 28 | * xyz to geodetic: requires iterations on latitude 29 | do i = 1, 3 30 | x(i) = x(i) - t(i) 31 | enddo 32 | 33 | if (x(1)+1.d0.eq.1.d0 .and. x(2)+1.d0.eq.1.d0) then 34 | lon = 0.d0 35 | else 36 | lon= datan2(x(2),x(1)) 37 | endif 38 | 39 | if( lon.lt.0d0 ) lon=lon + 2.d0*pi 40 | 41 | * starting value for latitude iteration 42 | sqr= dsqrt(x(1)**2 + x(2)**2) 43 | lat0= datan2(x(3)/sqr,1.d0-e2) 44 | lat= lat0 45 | 46 | 40 sinlat= dsin(lat) 47 | curvn= semi/(dsqrt(1.d0-e2*sinlat*sinlat)) 48 | lat= datan2((x(3)+e2*curvn*sinlat),sqr) 49 | * iterate to millimeter level 50 | if( dabs(lat-lat0).lt.1.d-10) goto 30 51 | lat0= lat 52 | goto 40 53 | 54 | 30 continue 55 | cutoff= 80.d0/rad_to_deg 56 | if(lat.le.cutoff) then 57 | hght= (sqr/dcos(lat))-curvn 58 | else 59 | hght= z/dsin(lat)-curvn+e2*curvn 60 | endif 61 | lat=lat*rad_to_deg 62 | lon=lon*rad_to_deg 63 | if(lon.gt.180.d0) lon=lon-360.d0 64 | 65 | else 66 | * geodetic to xyz 67 | lat = lat/rad_to_deg 68 | lon = lon/rad_to_deg 69 | sinlat= dsin(lat) 70 | coslat= dcos(lat) 71 | sinlon= dsin(lon) 72 | coslon= dcos(lon) 73 | curvn= semi/(dsqrt(1.d0-e2*sinlat*sinlat)) 74 | 75 | x(1) = (curvn+hght)*coslat*coslon + t(1) 76 | x(2) = (curvn+hght)*coslat*sinlon + t(2) 77 | x(3) = (curvn*(1.d0-e2)+hght)*sinlat + t(3) 78 | 79 | endif 80 | 81 | return 82 | end 83 | 84 | 85 | -------------------------------------------------------------------------------- /src/mineos/MAKE_eig_recover.mk: -------------------------------------------------------------------------------- 1 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 2 | #LFLAGS= $(MYLFLAGS) 3 | LFLAGS= 4 | PROG= eig_recover 5 | SUBS= kblnk.f 6 | OBJS= $(PROG).o $(SUBS:.f=.o) 7 | 8 | 9 | .f.o: 10 | gfortran $(FFLAGS) -c $*.f 11 | 12 | #---------------------------------------------------------------------------------- 13 | 14 | $(PROG): $(OBJS) 15 | gfortran $(FFLAGS) $(LFLAGS) -o $(MINEOSBIN)/$@ $(OBJS) 16 | 17 | # check object files for dependency on .h files 18 | $(OBJS): parameter.h 19 | gfortran $(FFLAGS) -c $*.f 20 | -------------------------------------------------------------------------------- /src/mineos/MAKE_frechet.mk: -------------------------------------------------------------------------------- 1 | #LFLAGS= -L$(MINEOSLIB) 2 | # FFLAGS=-ffixed-line-length-none 3 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 4 | LDLIBS=-lgfortran -lm 5 | 6 | frechetcomp = draw_frechet_gv frechet frechet_gv frechet_cv draw_frechet_gv 7 | 8 | #---------------------------------- 9 | #---------------------------------- 10 | 11 | all: clean $(frechetcomp) 12 | 13 | #---------------------------------- 14 | #---------------------------------- 15 | 16 | 17 | frechet: $(MINEOSBIN)/frechet 18 | 19 | $(MINEOSBIN)/frechet: frechet.o 20 | -rm $(MINEOSBIN)/frechet 21 | gfortran $(FFLAGS) -o $(MINEOSBIN)/frechet frechet.o 22 | 23 | frechet.o: frechet.f 24 | gfortran $(FFLAGS) -c -o frechet.o frechet.f 25 | 26 | #---------------------------------- 27 | 28 | frechet_gv: $(MINEOSBIN)/frechet_gv 29 | 30 | $(MINEOSBIN)/frechet_gv: frechet_gv.o 31 | -rm $(MINEOSBIN)/frechet_gv 32 | gfortran $(FFLAGS) -o $(MINEOSBIN)/frechet_gv frechet_gv.o 33 | 34 | frechet_gv.o: frechet_gv.f 35 | gfortran $(FFLAGS) -c -o frechet_gv.o frechet_gv.f 36 | 37 | #---------------------------------- 38 | 39 | frechet_cv: $(MINEOSBIN)/frechet_cv 40 | 41 | $(MINEOSBIN)/frechet_cv: frechet_cv.o 42 | -rm $(MINEOSBIN)/frechet_cv 43 | gfortran $(FFLAGS) -o $(MINEOSBIN)/frechet_cv frechet_cv.o 44 | 45 | frechet_cv.o: frechet_cv.f 46 | gfortran $(FFLAGS) -c -o frechet_cv.o frechet_cv.f 47 | 48 | #---------------------------------- 49 | 50 | draw_frechet_gv: $(MINEOSBIN)/draw_frechet_gv 51 | 52 | $(MINEOSBIN)/draw_frechet_gv: draw_frechet_gv.o 53 | -rm $(MINEOSBIN)/draw_frechet_gv 54 | gfortran $(FFLAGS) -o $(MINEOSBIN)/draw_frechet_gv draw_frechet_gv.o 55 | 56 | draw_frechet_gv.o: draw_frechet_gv.f 57 | gfortran $(FFLAGS) -c -o draw_frechet_gv.o draw_frechet_gv.f 58 | 59 | #---------------------------------- 60 | clean: 61 | -rm *.o 62 | -------------------------------------------------------------------------------- /src/mineos/MAKE_mineos_nohang.mk: -------------------------------------------------------------------------------- 1 | #FFLAGS= $(MYFFLAGS) 2 | #LFLAGS= $(MYLFLAGS) 3 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 4 | #LFLAGS= -Bstatic 5 | LFLAGS= 6 | # 7 | PROG= mineos_nohang 8 | SUBS= baylis.f bfs.f dermf.f derms.f detqn_nohang.f drspln.f dsplin.f eifout.f entry.f\ 9 | fprop.f fprpmn.f fpsm.f fsbdry.f fsbm.f gauslv.f grav.f intgds.f match.f\ 10 | model.f modout.f ortho.f remedy_nohang.f rkdot.f rotspl_nohang.f rprop.f rps.f sdepth.f\ 11 | sfbdry.f sfbm.f sprop.f sprpmn.f spsm.f startl.f steps.f svd.f tprop.f\ 12 | tps.f trknt.f whead.f wtable.f zknt.f 13 | OBJS= mineos.o $(SUBS:.f=.o) 14 | # FC=gfortran 15 | 16 | .f.o: 17 | gfortran $(FFLAGS) -c $*.f 18 | 19 | #---------------------------------------------------------------------------------- 20 | 21 | $(PROG): $(OBJS) 22 | gfortran $(FFLAGS) $(LFLAGS) -o $(MINEOSBIN)/$@ $(OBJS) 23 | 24 | # check object files for dependency on .h files 25 | $(OBJS): parameter.h 26 | gfortran $(FFLAGS) -c $*.f 27 | 28 | clean: 29 | -rm *.o -------------------------------------------------------------------------------- /src/mineos/MAKE_mineos_q.mk: -------------------------------------------------------------------------------- 1 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 2 | #LFLAGS= $(MYLFLAGS) 3 | LFLAGS= 4 | PROG= mineos_qcorrectphv 5 | SUBS= 6 | OBJS= $(PROG).o $(SUBS:.f=.o) 7 | 8 | 9 | .f.o: 10 | gfortran $(FFLAGS) -c $*.f 11 | 12 | #---------------------------------------------------------------------------------- 13 | 14 | $(PROG): $(OBJS) 15 | gfortran $(FFLAGS) $(LFLAGS) -o $(MINEOSBIN)/$@ $(OBJS) 16 | 17 | # check object files for dependency on .h files 18 | $(OBJS): parameter.h 19 | gfortran $(FFLAGS) -c $*.f 20 | -------------------------------------------------------------------------------- /src/mineos/MAKE_mineos_strip.mk: -------------------------------------------------------------------------------- 1 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 2 | #LFLAGS= $(MYLFLAGS) 3 | LFLAGS= 4 | PROG= mineos_strip 5 | SUBS= 6 | OBJS= $(PROG).o $(SUBS:.f=.o) 7 | 8 | .f.o: 9 | gfortran $(FFLAGS) -c $*.f 10 | 11 | #---------------------------------------------------------------------------------- 12 | 13 | $(PROG): $(OBJS) 14 | gfortran $(FFLAGS) $(LFLAGS) -o $(MINEOSBIN)/$@ $(OBJS) 15 | 16 | # check object files for dependency on .h files 17 | $(OBJS): parameter.h 18 | gfortran $(FFLAGS) -c $*.f 19 | 20 | -------------------------------------------------------------------------------- /src/mineos/MAKE_mineos_table.mk: -------------------------------------------------------------------------------- 1 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 2 | #LFLAGS= $(MYLFLAGS) 3 | LFLAGS= 4 | PROG= mineos_table 5 | SUBS= kblnk.f 6 | OBJS= $(PROG).o $(SUBS:.f=.o) 7 | 8 | .f.o: 9 | gfortran $(FFLAGS) -c $*.f 10 | 11 | #---------------------------------------------------------------------------------- 12 | 13 | $(PROG): $(OBJS) 14 | gfortran $(FFLAGS) $(LFLAGS) -o $(MINEOSBIN)/$@ $(OBJS) 15 | 16 | # check object files for dependency on .h files 17 | $(OBJS): parameter.h 18 | gfortran $(FFLAGS) -c $*.f 19 | -------------------------------------------------------------------------------- /src/mineos/bfs.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE BFS(L,X,EPS,F,FP,FPP) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C BFS CALCULATES UNNORMALIZED SPHERICAL BESSEL FUNCTIONS OF THE FIRST 6 | C KIND( J FUNCTIONS). RECURSION DOWNWARD IN L IS USED. OUTPUT IS THE 7 | C FUNCTION, F, FIRST DERIVATIVE, FP AND SECOND DERIVATIVE, FPP. 8 | c 9 | c calls no other routines 10 | c 11 | IMPLICIT REAL*8(A-H,O-Z) 12 | c 13 | FL=L 14 | EM=14.D0 15 | IF(X.GT.FL) EM=EM+X-FL 16 | M=EM 17 | FL1=FL+1.D0 18 | FL2=FL+FL1+2*M 19 | F=0.D0 20 | F1=EPS 21 | DO 1 I=1,M 22 | F3=F 23 | F=F1 24 | FL2=FL2-2.D0 25 | 1 F1=FL2*F/X-F3 26 | FP=FL*F/X-F3 27 | FPP=-2.D0*FP/X+(FL*FL1/(X*X)-1.D0)*F 28 | c 29 | RETURN 30 | END 31 | -------------------------------------------------------------------------------- /src/mineos/dermf.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE DERMF(IQ,Z,F,FP,IKNT,QFF) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** CALCULATES MINOR VECTOR DERIVATIVE (FP) IN A FLUID *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | include 'parameter.h' 12 | c 13 | REAL*8 LCON,NCON,LSPL,NSPL 14 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 15 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 16 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 17 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 18 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 19 | & ASPL(3,nknot) 20 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 21 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 22 | DIMENSION F(1),FP(1) 23 | c 24 | IF(IKNT.NE.0) GOTO 14 25 | T=Z-R(IQ) 26 | IF(T.NE.0.D0) GOTO 5 27 | RO=RHO(IQ) 28 | FLU=FCON(IQ)*QFF 29 | GR=G(IQ) 30 | GOTO 10 31 | 5 RO=RHO(IQ)+T*(QRO(1,IQ)+T*(QRO(2,IQ)+T*QRO(3,IQ))) 32 | FLU=(FCON(IQ)+T*(FSPL(1,IQ)+T*(FSPL(2,IQ)+T*FSPL(3,IQ))))*QFF 33 | GR=G(IQ)+T*(QG(1,IQ)+T*(QG(2,IQ)+T*QG(3,IQ))) 34 | 10 T21=-4.D0*RO 35 | ZR=1.D0/Z 36 | T12=FL3*ZR*ZR/WSQ 37 | T11=GR*T12-ZR 38 | S11=RO*(GR*GR*T12-WSQ)+T21*GR*ZR 39 | C11=-T12/RO+1.D0/FLU 40 | 14 IF(KG.NE.0) GOTO 15 41 | FP(1)=T11*F(1)+C11*F(2) 42 | FP(2)=(S11-T21*RO)*F(1)-T11*F(2) 43 | RETURN 44 | c 45 | 15 IF(IKNT.NE.0) GOTO 19 46 | T22=-FL*ZR 47 | S22=RO*T12 48 | B11=T11+T22 49 | S12=RO*B11 50 | IF(IBACK.EQ.1) GOTO 20 51 | B33=T11-T22 52 | FP(1)=B11*F(1)+4.D0*F(3)-C11*F(4) 53 | FP(2)=S12*F(1)-T21*F(3)+T12*F(4) 54 | 19 FP(3)=S22*F(1)-(T12+T12)*F(2)+B33*F(3)+C11*F(5) 55 | FP(4)=-S11*F(1)+(T21+T21)*F(2)-B33*F(4)-4.D0*F(5) 56 | FP(5)=-(S12+S12)*F(2)+S11*F(3)-S22*F(4)-B11*F(5) 57 | RETURN 58 | c 59 | 20 FP(1)=T22*F(1)-T21*F(2)-4.D0*F(3) 60 | FP(2)=-T12*F(1)+T11*F(2)-C11*F(4) 61 | FP(3)=-S22*F(1)+S12*F(2)-T22*F(3)+T12*F(4) 62 | FP(4)=S12*F(1)-S11*F(2)+T21*F(3)-T11*F(4) 63 | c 64 | RETURN 65 | END 66 | -------------------------------------------------------------------------------- /src/mineos/drspln.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE DRSPLN(I1,I2,X,Y,Q,F) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C RSPLN COMPUTES CUBIC SPLINE INTERPOLATION COEFFICIENTS 6 | C FOR Y(X) BETWEEN GRID POINTS I1 AND I2 SAVING THEM IN Q. THE 7 | C INTERPOLATION IS CONTINUOUS WITH CONTINUOUS FIRST AND SECOND 8 | C DERIVITIVES. IT AGREES EXACTLY WITH Y AT GRID POINTS AND WITH THE 9 | C THREE POINT FIRST DERIVITIVES AT BOTH END POINTS (I1 AND I2). 10 | C X MUST BE MONOTONIC BUT IF TWO SUCCESSIVE VALUES OF X ARE EQUAL 11 | C A DISCONTINUITY IS ASSUMED AND SEPERATE INTERPOLATION IS DONE ON 12 | C EACH STRICTLY MONOTONIC SEGMENT. THE ARRAYS MUST BE DIMENSIONED AT 13 | C LEAST - X(I2), Y(I2), Q(3,I2), AND F(3,I2). F IS WORKING STORAGE 14 | C FOR RSPLN. 15 | C -RPB 16 | c calls no other routines 17 | c 18 | IMPLICIT REAL*8(A-H,O-Z) 19 | c 20 | SAVE 21 | DIMENSION X(1),Y(1),Q(3,1),F(3,1),YY(3) 22 | EQUIVALENCE (YY(1),Y0) 23 | DATA YY/3*0.D0/ 24 | c 25 | J1=I1+1 26 | Y0=0.D0 27 | C BAIL OUT IF THERE ARE LESS THAN TWO POINTS TOTAL. 28 | IF(I2-I1)13,17,8 29 | 8 A0=X(J1-1) 30 | C SEARCH FOR DISCONTINUITIES. 31 | DO 3 I=J1,I2 32 | B0=A0 33 | A0=X(I) 34 | IF(A0-B0)3,4,3 35 | 3 CONTINUE 36 | 17 J1=J1-1 37 | J2=I2-2 38 | GO TO 5 39 | 4 J1=J1-1 40 | J2=I-3 41 | C SEE IF THERE ARE ENOUGH POINTS TO INTERPOLATE (AT LEAST THREE). 42 | 5 IF(J2+1-J1)9,10,11 43 | C ONLY TWO POINTS. USE LINEAR INTERPOLATION. 44 | 10 J2=J2+2 45 | Y0=(Y(J2)-Y(J1))/(X(J2)-X(J1)) 46 | DO 15 J=1,3 47 | Q(J,J1)=YY(J) 48 | 15 Q(J,J2)=YY(J) 49 | GO TO 12 50 | C MORE THAN TWO POINTS. DO SPLINE INTERPOLATION. 51 | 11 A0=0.D0 52 | H=X(J1+1)-X(J1) 53 | H2=X(J1+2)-X(J1) 54 | Y0=H*H2*(H2-H) 55 | H=H*H 56 | H2=H2*H2 57 | C CALCULATE DERIVITIVE AT NEAR END. 58 | B0=(Y(J1)*(H-H2)+Y(J1+1)*H2-Y(J1+2)*H)/Y0 59 | B1=B0 60 | C EXPLICITLY REDUCE BANDED MATRIX TO AN UPPER BANDED MATRIX. 61 | DO 1 I=J1,J2 62 | H=X(I+1)-X(I) 63 | Y0=Y(I+1)-Y(I) 64 | H2=H*H 65 | HA=H-A0 66 | H2A=H-2.D0*A0 67 | H3A=2.D0*H-3.*A0 68 | H2B=H2*B0 69 | Q(1,I)=H2/HA 70 | Q(2,I)=-HA/(H2A*H2) 71 | Q(3,I)=-H*H2A/H3A 72 | F(1,I)=(Y0-H*B0)/(H*HA) 73 | F(2,I)=(H2B-Y0*(2.D0*H-A0))/(H*H2*H2A) 74 | F(3,I)=-(H2B-3.D0*Y0*HA)/(H*H3A) 75 | A0=Q(3,I) 76 | 1 B0=F(3,I) 77 | C TAKE CARE OF LAST TWO ROWS. 78 | I=J2+1 79 | H=X(I+1)-X(I) 80 | Y0=Y(I+1)-Y(I) 81 | H2=H*H 82 | HA=H-A0 83 | H2A=H*HA 84 | H2B=H2*B0-Y0*(2.D0*H-A0) 85 | Q(1,I)=H2/HA 86 | F(1,I)=(Y0-H*B0)/H2A 87 | HA=X(J2)-X(I+1) 88 | Y0=-H*HA*(HA+H) 89 | HA=HA*HA 90 | C CALCULATE DERIVITIVE AT FAR END. 91 | Y0=(Y(I+1)*(H2-HA)+Y(I)*HA-Y(J2)*H2)/Y0 92 | Q(3,I)=(Y0*H2A+H2B)/(H*H2*(H-2.D0*A0)) 93 | Q(2,I)=F(1,I)-Q(1,I)*Q(3,I) 94 | C SOLVE UPPER BANDED MATRIX BY REVERSE ITERATION. 95 | DO 2 J=J1,J2 96 | K=I-1 97 | Q(1,I)=F(3,K)-Q(3,K)*Q(2,I) 98 | Q(3,K)=F(2,K)-Q(2,K)*Q(1,I) 99 | Q(2,K)=F(1,K)-Q(1,K)*Q(3,K) 100 | 2 I=K 101 | Q(1,I)=B1 102 | C FILL IN THE LAST POINT WITH A LINEAR EXTRAPOLATION. 103 | 9 J2=J2+2 104 | DO 14 J=1,3 105 | 14 Q(J,J2)=YY(J) 106 | C SEE IF THIS DISCONTINUITY IS THE LAST. 107 | 12 IF(J2-I2)6,13,13 108 | C NO. GO BACK FOR MORE. 109 | 6 J1=J2+2 110 | IF(J1-I2)8,8,7 111 | C THERE IS ONLY ONE POINT LEFT AFTER THE LATEST DISCONTINUITY. 112 | 7 DO 16 J=1,3 113 | 16 Q(J,I2)=YY(J) 114 | C FINI. 115 | c 116 | 13 RETURN 117 | END 118 | -------------------------------------------------------------------------------- /src/mineos/dsplin.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE DSPLIN(N,X,Y,Q,F) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c calls no other routines 6 | c 7 | IMPLICIT REAL*8(A-H,O-Z) 8 | c 9 | SAVE 10 | DIMENSION X(1),Y(1),Q(3,1),F(3,1),YY(3) 11 | EQUIVALENCE (YY(1),Y0) 12 | DATA YY/3*0.D0/ 13 | c 14 | A0=0.D0 15 | J2=N-2 16 | H=X(2)-X(1) 17 | H2=X(3)-X(1) 18 | Y0=H*H2*(H2-H) 19 | H=H*H 20 | H2=H2*H2 21 | B0=(Y(1)*(H-H2)+Y(2)*H2-Y(3)*H)/Y0 22 | B1=B0 23 | DO 5 I=1,J2 24 | H=X(I+1)-X(I) 25 | Y0=Y(I+1)-Y(I) 26 | H2=H*H 27 | HA=H-A0 28 | H2A=H-2.D0*A0 29 | H3A=2.D0*H-3.*A0 30 | H2B=H2*B0 31 | Q(1,I)=H2/HA 32 | Q(2,I)=-HA/(H2A*H2) 33 | Q(3,I)=-H*H2A/H3A 34 | F(1,I)=(Y0-H*B0)/(H*HA) 35 | F(2,I)=(H2B-Y0*(2.D0*H-A0))/(H*H2*H2A) 36 | F(3,I)=-(H2B-3.D0*Y0*HA)/(H*H3A) 37 | A0=Q(3,I) 38 | 5 B0=F(3,I) 39 | I=J2+1 40 | H=X(I+1)-X(I) 41 | Y0=Y(I+1)-Y(I) 42 | H2=H*H 43 | HA=H-A0 44 | H2A=H*HA 45 | H2B=H2*B0-Y0*(2.D0*H-A0) 46 | Q(1,I)=H2/HA 47 | F(1,I)=(Y0-H*B0)/H2A 48 | HA=X(J2)-X(I+1) 49 | Y0=-H*HA*(HA+H) 50 | HA=HA*HA 51 | Y0=(Y(I+1)*(H2-HA)+Y(I)*HA-Y(J2)*H2)/Y0 52 | Q(3,I)=(Y0*H2A+H2B)/(H*H2*(H-2.D0*A0)) 53 | Q(2,I)=F(1,I)-Q(1,I)*Q(3,I) 54 | DO 10 J=1,J2 55 | K=I-1 56 | Q(1,I)=F(3,K)-Q(3,K)*Q(2,I) 57 | Q(3,K)=F(2,K)-Q(2,K)*Q(1,I) 58 | Q(2,K)=F(1,K)-Q(1,K)*Q(3,K) 59 | 10 I=K 60 | Q(1,I)=B1 61 | DO 15 J=1,3 62 | 15 Q(J,N)=YY(J) 63 | c 64 | RETURN 65 | END 66 | -------------------------------------------------------------------------------- /src/mineos/eifout.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE EIFOUT(LSMIN) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** MASSAGES SPHEROIDAL MODE EIGENFUNCTIONS BEFORE OUTPUT *** 6 | c 7 | c calls: GAUSLV 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LL,LCON,NCON,LSPL,NSPL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/EIFX/A(14,nknot),INORM(nknot),idum(nknot) 25 | COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N 26 | DIMENSION ZI(4) 27 | DATA ZI/4*0.D0/ 28 | c 29 | I1=MIN0(NIC,MAX0(2,LSMIN)) 30 | I2=NIC 31 | 5 IF(I1.EQ.I2) GOTO 20 32 | DO 10 IQ=I1,I2 33 | FF=FCON(IQ)*(1.D0+XLAM(IQ)*FCT) 34 | LL=LCON(IQ)*(1.D0+QSHEAR(IQ)*FCT) 35 | ZR=1.D0/R(IQ) 36 | SFL3Z=SFL3*ZR 37 | D=1.D0/(CCON(IQ)*(1.D0+XA2(IQ)*FCT)) 38 | V=A(2,IQ) 39 | IF(KG.NE.0) GOTO 15 40 | A(2,IQ)=(ZR-2.D0*FF*D*ZR)*A(1,IQ)+SFL3Z*FF*D*V+D*A(3,IQ) 41 | A(4,IQ)=-SFL3Z*A(1,IQ)+(ZR+ZR)*V+A(4,IQ)/LL 42 | A(5,IQ)=0.D0 43 | A(6,IQ)=0.D0 44 | GOTO 10 45 | 15 A(2,IQ)=(ZR-2.D0*FF*D*ZR)*A(1,IQ)+SFL3Z*FF*D*V+D*A(4,IQ) 46 | A(4,IQ)=-SFL3Z*A(1,IQ)+(ZR+ZR)*V+A(5,IQ)/LL 47 | A(5,IQ)=A(3,IQ) 48 | A(6,IQ)=4.D0*(A(6,IQ)-RHO(IQ)*A(1,IQ))-FL*ZR*A(5,IQ) 49 | 10 A(3,IQ)=V 50 | 20 IF(I2.EQ.NSL) GOTO 25 51 | I1=MIN0(NSL,MAX0(LSMIN,NOCP1)) 52 | I2=NSL 53 | GOTO 5 54 | 25 I1=MIN0(NOC,MAX0(LSMIN,NICP1)) 55 | I2=NOC 56 | 30 IF(I1.EQ.I2) GOTO 50 57 | DO 35 IQ=I1,I2 58 | ZR=1.D0/R(IQ) 59 | SFL3Z=SFL3*ZR 60 | FFI=1.D0/(FLAM(IQ)*(1.D0+XLAM(IQ)*FCT)) 61 | IF(KG.NE.0) GOTO 40 62 | P=A(2,IQ) 63 | A(5,IQ)=0.D0 64 | A(6,IQ)=0.D0 65 | GOTO 45 66 | 40 P=A(3,IQ) 67 | A(5,IQ)=A(2,IQ) 68 | A(6,IQ)=4.D0*(A(4,IQ)-RHO(IQ)*A(1,IQ))-FL*ZR*A(5,IQ) 69 | 45 A(3,IQ)=SFL3Z*(G(IQ)*A(1,IQ)-P/RHO(IQ)+A(5,IQ))/WSQ 70 | A(2,IQ)=SFL3Z*A(3,IQ)-A(1,IQ)*ZR+P*FFI 71 | 35 A(4,IQ)=SFL3Z*(A(1,IQ)+P*(QRO(1,IQ)/(RHO(IQ)**2)+G(IQ)*FFI)/WSQ) 72 | 50 IF(N.EQ.NSL.OR.I2.EQ.N) GOTO 55 73 | I1=NSLP1 74 | I2=N 75 | GOTO 30 76 | 55 IMAX=0 77 | DO 60 IQ=LSMIN,N 78 | 60 IMAX=MAX0(INORM(IQ),IMAX) 79 | DO 65 IQ=LSMIN,N 80 | IEXP=INORM(IQ)-IMAX 81 | AL=0.D0 82 | IF(IEXP.GE.-80) AL=2.D0**IEXP 83 | DO 65 J=1,6 84 | 65 A(J,IQ)=A(J,IQ)*AL 85 | LSM1=MAX0(1,LSMIN-1) 86 | DO 70 I=1,LSM1 87 | DO 70 J=1,6 88 | 70 A(J,I)=0.D0 89 | IF(L.GT.1.OR.LSMIN.GT.2) GOTO 75 90 | A(2,1)=1.5D0*A(1,2)/R(2)-.5D0*A(2,2) 91 | A(4,1)=1.5D0*A(3,2)/R(2)-.5D0*A(4,2) 92 | 75 DO 80 J=1,4 93 | 80 ZI(J)=0.D0 94 | I1=MAX0(LSMIN,2) 95 | DO 85 IQ=I1,N 96 | IP=IQ-1 97 | c 98 | 85 IF(R(IQ).NE.R(IP)) CALL GAUSLV(R(IP),R(IQ),IP,ZI,4) 99 | c 100 | c print*, (zi(i),i=1,4) 101 | CG=ZI(2)/(W*ZI(1)) 102 | WRAY=DSQRT(2.D0*ZI(4)/ZI(1)) 103 | QINV=2.D0*ZI(3)/(WSQ*ZI(1)) 104 | RNORM=1.D0/(W*DSQRT(ZI(1))) 105 | DO 90 IQ=I1,N 106 | ZR=1.D0/R(IQ) 107 | A(1,IQ)=A(1,IQ)*ZR 108 | A(2,IQ)=(A(2,IQ)-A(1,IQ))*ZR 109 | A(3,IQ)=A(3,IQ)*ZR 110 | A(4,IQ)=(A(4,IQ)-A(3,IQ))*ZR 111 | A(5,IQ)=A(5,IQ)*ZR 112 | A(6,IQ)=(A(6,IQ)-A(5,IQ))*ZR 113 | A(1,IQ)=A(1,IQ)*RNORM 114 | A(2,IQ)=A(2,IQ)*RNORM 115 | A(3,IQ)=A(3,IQ)*RNORM 116 | A(4,IQ)=A(4,IQ)*RNORM 117 | A(5,IQ)=A(5,IQ)*RNORM 118 | 90 A(6,IQ)=A(6,IQ)*RNORM 119 | IF(LSMIN.GT.2.OR.L.GT.2) RETURN 120 | c 121 | IF(L.EQ.2) GOTO 95 122 | A(1,1)=A(1,2)-.5D0*A(2,2)*R(2) 123 | A(2,1)=0.D0 124 | A(3,1)=A(3,2)-.5D0*A(4,2)*R(2) 125 | A(4,1)=0.D0 126 | A(6,1)=1.5D0*A(5,2)/R(2)-.5D0*A(6,2) 127 | RETURN 128 | c 129 | 95 A(2,1)=1.5D0*A(1,2)/R(2)-.5D0*A(2,2) 130 | A(4,1)=1.5D0*A(3,2)/R(2)-.5D0*A(4,2) 131 | c 132 | RETURN 133 | END 134 | -------------------------------------------------------------------------------- /src/mineos/eig_recover.f: -------------------------------------------------------------------------------- 1 | program eig_recover 2 | c 3 | c eig_recover allows reading and rewriting of eig files 4 | c for which mineos was aborted. Specify last angular 5 | c order (l) value to recover. 6 | c jbg 9/30/92 7 | c 8 | include 'parameter.h' 9 | c 10 | real*4 wmin, wmax 11 | real*4 radius(nknot) 12 | real*4 dn(nknot), pv(nknot), sv(nknot), ph(nknot), sh(nknot) 13 | real*4 eta(nknot) 14 | real*4 qalpha(nknot), qbeta(nknot) 15 | real*4 abuf(maxbyte+3) 16 | c 17 | real*8 wd,h1d,gvd 18 | c 19 | character*256 fileo 20 | c 21 | common/ablk/nn,ll,wd,h1d,gvd,buf(nknot6) 22 | equivalence(nn,abuf) 23 | c 24 | c get the name of the eigenfunction file 25 | c 26 | print*,' Enter the pathname of the eig file to be fixed.' 27 | read(*,'(a)')fileo 28 | open(unit=2, file=fileo, form = 'unformatted', 29 | & access = 'sequential') 30 | csun , recl = 28000) 31 | call kblnk(fileo,k) 32 | fileo = fileo(1:k)//'_fix' 33 | open(unit=8, file=fileo, form = 'unformatted', 34 | & access = 'sequential') 35 | csun , recl = 28000) 36 | c 37 | c read and rewrite top of header 38 | c 39 | read(2) jcom, wmin, wmax, llmin, llmax, wgrav 40 | read(2) knot,nic,noc,ifanis,tref, 41 | & (radius(i),i=1, knot), (dn(i), i=1,knot), 42 | & (pv(i), i=1,knot),(sv(i), i=1,knot), 43 | & (qalpha(i),i=1,knot),(qbeta(i),i=1,knot), 44 | & (ph(i), i=1,knot),(sh(i), i=1,knot), 45 | & (eta(i), i=1,knot) 46 | c 47 | write(8) jcom, wmin, wmax, llmin, llmax, wgrav 48 | write(8) knot,nic,noc,ifanis,tref, 49 | & (radius(i),i=1, knot), (dn(i), i=1,knot), 50 | & (pv(i), i=1,knot),(sv(i), i=1,knot), 51 | & (qalpha(i),i=1,knot),(qbeta(i),i=1,knot), 52 | & (ph(i), i=1,knot),(sh(i), i=1,knot), 53 | & (eta(i), i=1,knot) 54 | c 55 | if (jcom .eq. 2) then 56 | knot = knot-noc 57 | endif 58 | c 59 | if (jcom .eq. 3) then 60 | nvec=6*knot+8 61 | else 62 | nvec=2*knot+8 63 | endif 64 | c 65 | c get n,l values for first mode to fix 66 | c 67 | print*,'Enter last l value to recover:' 68 | read(*,*) lf 69 | c 70 | c read modes and correct as neccessary 71 | c 72 | 2 read(2,end=999)(abuf(i),i=1,nvec) 73 | if(ll.le.lf) then 74 | write(8)(abuf(i),i=1,nvec) 75 | else 76 | print*,'Halted prior to ',nn,ll 77 | go to 999 78 | end if 79 | go to 2 80 | 999 continue 81 | close(2) 82 | close(8) 83 | stop 84 | end 85 | 86 | -------------------------------------------------------------------------------- /src/mineos/entry.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ENTRY(W,IMAX,KEI) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c calls: DETQN 6 | c 7 | IMPLICIT REAL*8(A-H,O-Z) 8 | c 9 | SAVE 10 | c 11 | include 'parameter.h' 12 | c 13 | COMMON/MTAB/WE(nbranch2),DE(nbranch2),KE(nbranch2) 14 | c 15 | CALL DETQN(W,KEI,DEI,0) 16 | c 17 | INDX=MIN0(MAX0(2*(KEI-KE(1)),1),IMAX) 18 | IF(INDX.EQ.1.AND.WE(1).LT.W) GOTO 10 19 | IF(INDX.EQ.IMAX.AND.WE(IMAX).GT.W) GOTO 10 20 | IF(KEI.NE.KE(INDX)) GOTO 5 21 | IF(WE(INDX).GT.W) GOTO 10 22 | INDX=INDX+1 23 | IF(WE(INDX).LT.W) GOTO 10 24 | c 25 | RETURN 26 | c 27 | 5 WE(INDX)=W 28 | KE(INDX)=KEI 29 | DE(INDX)=DEI 30 | INDX=INDX+1 31 | 10 WE(INDX)=W 32 | KE(INDX)=KEI 33 | DE(INDX)=DEI 34 | c 35 | RETURN 36 | END 37 | -------------------------------------------------------------------------------- /src/mineos/fprpmn.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE FPRPMN(JF,JL,F,H,NVEFM,IEXP) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** PROPAGATE THE MINOR VECTOR IN A FLUID REGION FROM LEVEL JF TO JL *** 6 | c 7 | c calls: BAYLIS, DERMF, RKDOT, ZKNT 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LCON,NCON,LSPL,NSPL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/EIFX/AR(14,nknot),INORM(nknot),idum(nknot) 25 | COMMON/SHANKS/B(46),C(10),DX,STEP(8),STEPF,IN,MAXO 26 | DIMENSION F(1),H(NVEFM,1),S(5),FP(5) 27 | DATA ECONST/1048576.D0/ 28 | DATA S/5*0.D0/,FP/5*0.D0/ 29 | c 30 | IF(NVEFM.EQ.1) GOTO 85 31 | MAXO1=MAXO-1 32 | JUD=1 33 | IF(JL.LT.JF) JUD=-1 34 | Y=R(JF) 35 | I=JF 36 | GO TO 45 37 | 10 X=Y 38 | Y=R(I) 39 | IF(Y.EQ.X) GOTO 45 40 | IQ=MIN0(I,I-JUD) 41 | QFF=1.D0+XLAM(IQ)*FCT 42 | ZS=DMIN1(X,Y) 43 | XI=G(I)/Y 44 | ALFSQ=(WSQ+4.D0*RHO(I)+XI-FL3*XI*XI/WSQ)*RHO(I)/FLAM(I) 45 | Q=(DSQRT(DABS(ALFSQ-FL3/(X*X)))+1.D0/ZS+FLOAT(KG)*SFL3/X)/STEPF 46 | DEL=FLOAT(JUD)*STEP(MAXO)/Q 47 | DXS=0.D0 48 | 15 Y=X+DEL 49 | IF(FLOAT(JUD)*(Y-R(I)).GT.0.D0) Y=R(I) 50 | DX=Y-X 51 | c 52 | IF(DX.NE.DXS) CALL BAYLIS(Q,MAXO1) 53 | c 54 | DXS=DX 55 | DO 30 J=1,NVEFM 56 | 30 S(J)=F(J) 57 | DO 35 NI=1,IN 58 | Z=X+C(NI) 59 | c 60 | CALL DERMF(IQ,Z,F,H(1,NI),0,QFF) 61 | c 62 | 35 CALL RKDOT(F,S,H,NVEFM,NI) 63 | c 64 | IF(KNSW.NE.1) GOTO 40 65 | c 66 | CALL DERMF(IQ,Y,F,FP,1,QFF) 67 | c 68 | CALL ZKNT(S,H,F,FP,X,Y,0) 69 | c 70 | 40 X=Y 71 | IF(Y.NE.R(I)) GO TO 15 72 | 45 SIZE=DABS(F(1)) 73 | DO 50 J=2,NVEFM 74 | 50 SIZE=DMAX1(SIZE,DABS(F(J))) 75 | 55 IF(SIZE.LT.1024.D0) GOTO 65 76 | DO 60 J=1,NVEFM 77 | 60 F(J)=F(J)/ECONST 78 | SIZE=SIZE/ECONST 79 | IEXP=IEXP+20 80 | GOTO 55 81 | 65 IF(IBACK.EQ.0) GOTO 70 82 | INORM(I)=INORM(I)+IEXP 83 | RNE2 =-AR(1,I)*F(4)+AR(4,I)*F(2)+AR(2,I)*F(1) 84 | AR(1,I)=-AR(1,I)*F(3)+AR(2,I)*F(2)-AR(3,I)*F(1) 85 | RNE3 =-AR(2,I)*F(4)+AR(4,I)*F(3)-AR(5,I)*F(1) 86 | AR(4,I)=-AR(3,I)*F(4)-AR(2,I)*F(3)-AR(5,I)*F(2) 87 | AR(2,I)=RNE2 88 | AR(3,I)=RNE3 89 | GOTO 80 90 | 70 INORM(I)=IEXP 91 | DO 75 J=1,NVEFM 92 | 75 AR(J,I)=F(J) 93 | 80 IF(I.EQ.JL) RETURN 94 | 95 | I=I+JUD 96 | GO TO 10 97 | 85 DO 90 I=JL,JF 98 | INORM(I)=INORM(I)+IEXP 99 | 90 CONTINUE 100 | DO 91 J=1,2 101 | DO 91 I=JL,JF 102 | AR(J,I)=AR(J,I)*F(1) 103 | 91 CONTINUE 104 | 105 | RETURN 106 | END 107 | -------------------------------------------------------------------------------- /src/mineos/fpsm.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE FPSM(LS,NVEFM,ASS) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** COMPUTES SPHEROIDAL MODE START SOLUTION IN A FLUID REGION USING POWER 6 | C*** SERIES OR SPH. BESSEL FNS. IF THE ARGUMENT IS TOO LARGE. 7 | c 8 | c calls: BFS 9 | c 10 | IMPLICIT REAL*8(A-H,O-Z) 11 | c 12 | include 'parameter.h' 13 | c 14 | REAL*8 LCON,NCON,LSPL,NSPL 15 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 16 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 17 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 18 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 19 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 20 | & ASPL(3,nknot) 21 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 22 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 23 | DIMENSION ASS(1) 24 | c 25 | X=R(LS) 26 | FLA=FLAM(LS)*(1.D0+XLAM(LS)*FCT) 27 | VPSQ=FLA/RHO(LS) 28 | ZETA=4.D0*RHO(LS) 29 | XI=G(LS)/X 30 | QSQ=(WSQ+FLOAT(KG)*ZETA+XI-FL3*XI*XI/WSQ)/VPSQ 31 | XSQ=X*X 32 | ZSQ=QSQ*XSQ 33 | IF(ZSQ/(4.D0*FL+6.D0).GT.0.1D0) GO TO 10 34 | F=1.D0 35 | DT=1.D0 36 | U=0.D0 37 | S2=0.D0 38 | C=0.D0 39 | D1=FL+FL3*XI/WSQ 40 | IF(KG.EQ.0) U=-D1/QSQ 41 | D3=FL2-D1 42 | 5 C=C+2.D0 43 | C2=1.D0/(C*(FL2+C)) 44 | D1=D1+2.D0 45 | S=DT*XSQ*C2 46 | U=U+D1*S 47 | S2=S2+S 48 | IF(DABS(DT/F).LT.EPS) GOTO 6 49 | DT=-DT*ZSQ*C2 50 | F=F+DT 51 | GOTO 5 52 | 6 P=ZETA*S2-VPSQ 53 | S=ZETA*S2*D3-VPSQ*FL2 54 | GOTO 15 55 | 10 Z=DSQRT(ZSQ) 56 | c 57 | CALL BFS(L,Z,EPS,F,FP,FPP) 58 | c 59 | P=-F*VPSQ 60 | S=FL2*P 61 | U=(F*FL-Z*FP)/QSQ 62 | IF(KG.EQ.0) U=-(FL3*XI*F/WSQ+Z*FP)/QSQ 63 | 15 IF(KG.EQ.0) GOTO 20 64 | C1=FL*G(LS)-WSQ*X 65 | C2=FL2*C1*0.25D0/X-RHO(LS)*FL 66 | ASS(1)=X*FL*P-C1*U 67 | ASS(2)=-X*FL*F*FLA 68 | ASS(3)=FL*S*0.25D0-U*C2 69 | ASS(4)=X*F*FLA*C1 70 | ASS(5)=-X*F*FLA*C2 71 | GOTO 25 72 | 20 ASS(1)=U 73 | ASS(2)=X*F*FLA 74 | 25 SUM=ASS(1)*ASS(1) 75 | DO 30 I=2,NVEFM 76 | 30 SUM=SUM+ASS(I)*ASS(I) 77 | SUM=1.D0/DSQRT(SUM) 78 | IF(ASS(NVEFM).LT.0.D0) SUM=-SUM 79 | DO 35 I=1,NVEFM 80 | 35 ASS(I)=ASS(I)*SUM 81 | c 82 | RETURN 83 | END 84 | -------------------------------------------------------------------------------- /src/mineos/fsbdry.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE FSBDRY(AF,AS,KG) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C FSBDRY CREATES SOLID FUNDAMENTAL MATRIX AS FROM FLUID FUNDAMENTAL MATRIX 6 | C AF.IT IS PRESUMED THAT FSBDRY IS USED TO CROSS A F/S BOUNDARY. 7 | c 8 | c calls no other routines 9 | c 10 | IMPLICIT REAL*8(A-H,O-Z) 11 | c 12 | DIMENSION AF(4,1),AS(6,1) 13 | c 14 | DO 10 I=1,3 15 | DO 10 J=1,6 16 | 10 AS(J,I)=0.D0 17 | IF(KG.NE.0) GOTO 20 18 | AS(1,1)=AF(1,1) 19 | AS(3,1)=AF(2,1) 20 | AS(2,2)=1.D0 21 | RETURN 22 | c 23 | 20 DO 25 K=1,2 24 | AS(1,K)=AF(1,K) 25 | AS(3,K)=AF(2,K) 26 | AS(4,K)=AF(3,K) 27 | 25 AS(6,K)=AF(4,K) 28 | AS(2,3)=1.D0 29 | c 30 | RETURN 31 | END 32 | -------------------------------------------------------------------------------- /src/mineos/fsbm.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE FSBM(ASS,KG,IBACK) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** CONVERT MINOR VECTOR AT A FLUID/SOLID BOUNDARY *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | DIMENSION ASS(14),AS(14) 12 | c 13 | DO 10 J=1,14 14 | AS(J)=ASS(J) 15 | 10 ASS(J)=0.D0 16 | IF(IBACK.EQ.1) GOTO 30 17 | IF(KG.NE.0) GOTO 20 18 | ASS(1)=AS(1) 19 | ASS(4)=-AS(2) 20 | RETURN 21 | c 22 | 20 ASS(6)=AS(1) 23 | ASS(14)=AS(2) 24 | ASS(1)=AS(3) 25 | ASS(9)=AS(4) 26 | ASS(4)=-AS(5) 27 | RETURN 28 | c 29 | 30 IF(KG.NE.0) GOTO 40 30 | ASS(1)=-AS(1) 31 | RETURN 32 | c 33 | 40 ASS(1)=-AS(1) 34 | ASS(3)=-AS(2) 35 | ASS(5)=-AS(3) 36 | ASS(12)=AS(4) 37 | c 38 | RETURN 39 | END 40 | -------------------------------------------------------------------------------- /src/mineos/gauslv.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE GAUSLV(R1,R2,IQ,FINT,NINT) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** FIFTH ORDER GAUSS-LEGENDRE INTEGRATION *** 6 | c 7 | c calls: INTGDS 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | DIMENSION FINT(1),VALS(4),VALS1(4),SUM(4),W(2),X(2) 13 | DATA W,X/.478628670499366D0,.236926885056189D0, 14 | + .538469310105683D0,.906179845938664D0/ 15 | DATA VALS/4*0.D0/,VALS1/4*0.D0/,SUM/4*0.D0/ 16 | c 17 | Y1=.5D0*(R2+R1) 18 | Y2=.5D0*(R2-R1) 19 | c 20 | CALL INTGDS(Y1,IQ,VALS) 21 | c 22 | DO 5 J=1,NINT 23 | 5 SUM(J)=.568888888888889D0*VALS(J) 24 | DO 10 I=1,2 25 | T1=X(I)*Y2 26 | c 27 | CALL INTGDS(Y1+T1,IQ,VALS) 28 | CALL INTGDS(Y1-T1,IQ,VALS1) 29 | c 30 | DO 10 J=1,NINT 31 | 10 SUM(J)=SUM(J)+W(I)*(VALS(J)+VALS1(J)) 32 | DO 15 J=1,NINT 33 | 15 FINT(J)=FINT(J)+Y2*SUM(J) 34 | c 35 | RETURN 36 | END 37 | -------------------------------------------------------------------------------- /src/mineos/grav.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE GRAV(G,RHO,QRO,R,N) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** GIVEN RHO AND SPLINE COEFFS,COMPUTES GRAVITY *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | DIMENSION G(1),RHO(1),QRO(3,1),R(1) 12 | c 13 | G(1)=0.D0 14 | DO 10 I=2,N 15 | IM1=I-1 16 | DEL=R(I)-R(IM1) 17 | RN2=R(IM1)*R(IM1) 18 | TRN=2.D0*R(IM1) 19 | C1=RHO(IM1)*RN2 20 | C2=(QRO(1,IM1)*RN2+TRN*RHO(IM1))*0.5D0 21 | C3=(QRO(2,IM1)*RN2+TRN*QRO(1,IM1)+RHO(IM1))/3.D0 22 | C4=(QRO(3,IM1)*RN2+TRN*QRO(2,IM1)+QRO(1,IM1))*.25D0 23 | C5=(TRN*QRO(3,IM1)+QRO(2,IM1))*0.2D0 24 | 10 G(I)=(G(IM1)*RN2+4.D0*DEL*(C1+DEL*(C2+DEL*(C3+DEL*(C4+DEL* 25 | + (C5+DEL*QRO(3,IM1)/6.D0))))))/(R(I)*R(I)) 26 | c 27 | RETURN 28 | END 29 | -------------------------------------------------------------------------------- /src/mineos/intgds.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE INTGDS(RR,IQ,VALS) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** INTERPOLATES INTEGRANDS FOR NORMALISATION,CG,Q ETC..FOR USE WITH GAUSLV. 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LCON,NCON,LSPL,NSPL,NN,LL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/EIFX/AR(14,nknot),adum(nknot) 25 | DIMENSION Q(3),QP(3),VALS(1) 26 | DATA D1,D2,D3,D4,D5,D6,D7/.111111111111111D0, 27 | + 0.066666666666667D0,0.666666666666667D0,1.333333333333333D0, 28 | + 2.666666666666667D0,3.333333333333333D0,5.333333333333333D0/ 29 | DATA Q/3*0.D0/,QP/3*0.D0/ 30 | c 31 | T=RR-R(IQ) 32 | HN=1.D0/(R(IQ+1)-R(IQ)) 33 | HSQ=HN*HN 34 | QFF=1.D0+XLAM(IQ)*FCT 35 | QLL=1.D0+QSHEAR(IQ)*FCT 36 | IQ1=IQ+1 37 | IFUN=3 38 | IF(JCOM.NE.3) IFUN=1 39 | DO 10 I=1,IFUN 40 | I2=2*I 41 | I1=I2-1 42 | A=((AR(I2,IQ)+AR(I2,IQ1))+2.D0*HN*(AR(I1,IQ)-AR(I1,IQ1)))*HSQ 43 | B=-(2.D0*AR(I2,IQ)+AR(I2,IQ1))*HN-3.D0*(AR(I1,IQ)-AR(I1,IQ1))*HSQ 44 | Q(I)=(AR(I1,IQ)+T*(AR(I2,IQ)+T*(B+T*A)))/RR 45 | 10 QP(I)=AR(I2,IQ)+T*(2.D0*B+T*3.D0*A) 46 | RRO=(RHO(IQ)+T*(QRO(1,IQ)+T*(QRO(2,IQ)+T*QRO(3,IQ))))*RR 47 | GR=G(IQ)+T*(QG(1,IQ)+T*(QG(2,IQ)+T*QG(3,IQ))) 48 | FF=(FCON(IQ)+T*(FSPL(1,IQ)+T*(FSPL(2,IQ)+T*FSPL(3,IQ))))*QFF 49 | LL=(LCON(IQ)+T*(LSPL(1,IQ)+T*(LSPL(2,IQ)+T*LSPL(3,IQ))))*QLL 50 | IF(IFANIS.NE.0) GOTO 15 51 | NN=LL 52 | CC=FF+LL+LL 53 | AA=CC 54 | GOTO 20 55 | 15 QAA=1.D0+XA2(IQ)*FCT 56 | NN=(NCON(IQ)+T*(NSPL(1,IQ)+T*(NSPL(2,IQ)+T*NSPL(3,IQ))))*QLL 57 | CC=(CCON(IQ)+T*(CSPL(1,IQ)+T*(CSPL(2,IQ)+T*CSPL(3,IQ))))*QAA 58 | AA=(ACON(IQ)+T*(ASPL(1,IQ)+T*(ASPL(2,IQ)+T*ASPL(3,IQ))))*QAA 59 | 20 QRKA=D1*(4.D0*(AA+FF-NN)+CC) 60 | 1 *(QKAPPA(IQ)+T*HN*(QKAPPA(IQ1)-QKAPPA(IQ))) 61 | QRMU=D2*(AA+CC-2.D0*FF+5.D0*NN+6.D0*LL) 62 | 1 *(QSHEAR(IQ)+T*HN*(QSHEAR(IQ1)-QSHEAR(IQ))) 63 | IF(JCOM.NE.3) GOTO 25 64 | Q1SQ=Q(1)*Q(1) 65 | Q2SQ=Q(2)*Q(2) 66 | VALS(1)=RR*RRO*(Q1SQ+Q2SQ) 67 | FAC=(FL+.5D0)/SFL3 68 | VALS(2)=(SFL3*(LL*Q1SQ+AA*Q2SQ)+Q(2)*((RRO*GR+2.D0*(NN-AA-LL)+FF) 69 | + *Q(1)+RRO*Q(3)-FF*QP(1))+LL*QP(2)*Q(1))*FAC 70 | + +.25D0*Q(3)*(QP(3)+FL*Q(3)) 71 | T2=QRKA+D7*QRMU 72 | T3=QRKA+D4*QRMU 73 | T4=QRKA+D6*QRMU 74 | T5=QRKA-D5*QRMU 75 | T6=QRKA-D3*QRMU 76 | VALS(3)=.5D0*((FL3*QRMU+T2)*Q1SQ+(2.D0*QRMU+FL3*T3)*Q2SQ) 77 | 1 -Q(1)*SFL3*T4*Q(2)+Q(1)*(T5*QP(1)+SFL3*QRMU*QP(2))+Q(2)*(-2.D0* 78 | 2 QRMU*QP(2)-SFL3*T6*QP(1))+.5D0*(T3*QP(1)*QP(1)+QRMU*QP(2)*QP(2)) 79 | VALS(4)=.5D0*((FL3*LL+4.D0*(RRO*(RRO-GR)+AA-NN-FF)+CC)*Q1SQ+ 80 | +(4.D0*LL-NN-NN+FL3*AA)*Q2SQ +FL*FL*.25D0*Q(3)*Q(3)+CC*QP(1)*QP(1)+ 81 | +LL*QP(2)*QP(2)+.25D0*QP(3)*QP(3))+Q(3)*(RRO*SFL3*Q(2)+FL*.25D0*QP 82 | +(3))+Q(1)*(SFL3*(RRO*GR+2.D0*(NN-AA-LL)+FF)*Q(2)+RRO*(QP(3)-Q(3))+ 83 | +(FF+FF-CC)*QP(1)+SFL3*LL*QP(2))-Q(2)*(SFL3*FF*QP(1)+(LL+LL)*QP(2)) 84 | RETURN 85 | c 86 | 25 Q(1)=Q(1)*RR 87 | VALS(1)=RR*RRO*Q(1)*Q(1) 88 | IF(JCOM.EQ.1) GOTO 30 89 | VALS(2)=NN*Q(1)*Q(1) 90 | T1=(RR*QP(1)-Q(1))**2 91 | T2=(FL3-2.D0)*Q(1)*Q(1) 92 | VALS(3)=(T1+T2)*QRMU 93 | VALS(4)=T1*LL+T2*NN 94 | RETURN 95 | c 96 | 30 T1=(RR*QP(1)+2.D0*Q(1))**2 97 | T2=D4*(RR*QP(1)-Q(1))**2 98 | VALS(2)=T1*QRKA+T2*QRMU 99 | VALS(3)=RR*QP(1)*(CC*RR*QP(1)+4.D0*FF*Q(1))+4.D0*Q(1)*Q(1) 100 | + *(AA-NN-RRO*GR) 101 | c 102 | RETURN 103 | END 104 | -------------------------------------------------------------------------------- /src/mineos/kblnk.f: -------------------------------------------------------------------------------- 1 | subroutine kblnk(string,k) 2 | c 3 | c returns the number of non-blank characters in string 4 | c 5 | character*(*) string 6 | character*1 blank 7 | data blank/' '/ 8 | k=0 9 | do 1 i=1,80 10 | if(string(i:i).eq.blank) go to 2 11 | k=i 12 | 1 continue 13 | 2 return 14 | end 15 | 16 | -------------------------------------------------------------------------------- /src/mineos/match.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE MATCH(N,J,KG,AF,AFR) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c calls no other routines 6 | c 7 | IMPLICIT REAL*8(A-H,O-Z) 8 | c 9 | include 'parameter.h' 10 | c 11 | COMMON/EIFX/AR(14,nknot),INORM(nknot),idum2(nknot) 12 | COMMON/AREM/A(6,3,nknot) 13 | DIMENSION AF(4,1),AFR(1) 14 | c 15 | PRINT 999,'match 0',AF(1,1),AF(2,1),AFR(1),AFR(2) 16 | 17 | K=J+2 18 | IF(KG.EQ.1) GO TO 20 19 | C=(AF(1,1)*AFR(1)+AF(2,1)*AFR(2))/(AF(1,1)**2+AF(2,1)**2) 20 | AF1=AF(1,1)*C 21 | AF2=AF(2,1)*C 22 | PRINT 999,'match 1',AF1,AF2,AFR(1),AFR(2) 23 | IDIFF=INORM(J)-INORM(J+1) 24 | INORM(J+1)=INORM(J) 25 | 999 FORMAT(a8,4G20.10) 26 | DO 10 I=K,N 27 | INORM(I)=INORM(I)+IDIFF 28 | 10 CONTINUE 29 | DO 11 J=1,4 30 | DO 11 I=K,N 31 | AR(J,I)=C*A(J,1,I) 32 | 11 CONTINUE 33 | RETURN 34 | c 35 | 20 A2=(AF(3,1)*AFR(1)-AF(1,1)*AFR(3))/(AF(1,2)*AF(3,1)-AF(1,1) 36 | + *AF(3,2)) 37 | A1=(AF(3,2)*AFR(1)-AF(1,2)*AFR(3))/(AF(1,1)*AF(3,2)-AF(3,1) 38 | + *AF(1,2)) 39 | AF1=A1*AF(1,1)+A2*AF(1,2) 40 | AF2=A1*AF(2,1)+A2*AF(2,2) 41 | AF3=A1*AF(3,1)+A2*AF(3,2) 42 | AF4=A1*AF(4,1)+A2*AF(4,2) 43 | PRINT 999,'match 2',AF1,AF2,AF3,AF4 44 | PRINT 999,'match 3',(AFR(I),I=1,4) 45 | IDIFF=INORM(J)-INORM(J+1) 46 | INORM(J+1)=INORM(J) 47 | DO 25 I=K,N 48 | INORM(I)=INORM(I)+IDIFF 49 | DO 25 J=1,6 50 | 25 AR(J,I)=A1*A(J,1,I)+A2*A(J,2,I) 51 | c 52 | RETURN 53 | END 54 | -------------------------------------------------------------------------------- /src/mineos/modout.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE MODOUT(WCOM,QMOD,GCOM,IOEIG) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c writes output eigenfrequencies, eigenfunctions to mode file 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*4 ABUF,BUF 16 | c ,WW,QQ,GC 17 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 18 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 19 | COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N 20 | COMMON/EIFX/A(14,nknot),DUM(nknot) 21 | COMMON/BUFCOM/NN,LL,WW,QQ,GC,BUF(nknot6) 22 | DIMENSION ABUF(maxbyte+3) 23 | EQUIVALENCE (NN,ABUF) 24 | DATA A/nknot14*0.D0/,DUM/nknot*0.D0/,BUF/nknot6*0.D0/ 25 | c 26 | NN=NORD 27 | LL=L 28 | WW=WCOM 29 | QQ=QMOD 30 | GC=GCOM 31 | if(JCOM.ne.2)goto 5 32 | nocor=N-NOC 33 | do 20, i=1,nocor 34 | buf(i)=A(1,NOC+i) 35 | j=i+nocor 36 | buf(j)=A(2,NOC+i) 37 | 20 continue 38 | nvec=2*nocor+8 39 | goto 15 40 | 5 NVEC=2*N+8 41 | IF (JCOM .EQ. 3) NVEC=6*N+8 42 | DO 10 I=1,N 43 | BUF(I)=A(1,I) 44 | J=I+N 45 | BUF(J)=A(2,I) 46 | IF(JCOM.NE.3) GOTO 10 47 | J=J+N 48 | BUF(J)=A(3,I) 49 | J=J+N 50 | BUF(J)=A(4,I) 51 | J=J+N 52 | BUF(J)=A(5,I) 53 | J=J+N 54 | BUF(J)=A(6,I) 55 | 10 CONTINUE 56 | 15 write(ioeig) (abuf(i),i=1,nvec) 57 | c 58 | RETURN 59 | END 60 | -------------------------------------------------------------------------------- /src/mineos/ortho.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ORTHO(LI,LC,B,KG) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C FINDS THE ORTHOGONAL MATRIX V SUCH THAT THE COLUMNS OF B*V ARE ORTHOGONAL 6 | C THE ARRAY A IS REPLACED BY A*V FOR LEVELS LI - LC. ARRAY B IS REPLACED 7 | C BY B*V AND IS THEN READY FO ENTRY TO SPROP AT LEVEL LC.THIS IS INTENDED 8 | C TO DIMINISH THE ONSET OF DEGENERACY CAUSED BY RAPID EXPONENTIAL GROWTH 9 | C IN THE MANTLE FOR MODES WITH DEEPLY TURNING S AND SHALLOWLY TURNING P. 10 | c 11 | c calls: SVD 12 | c 13 | IMPLICIT REAL*8(A-H,O-Z) 14 | c 15 | SAVE 16 | c 17 | include 'parameter.h' 18 | c 19 | COMMON/AREM/A(6,3,nknot) 20 | DIMENSION B(6,1),AS(6,3) 21 | DATA AS/18*0.D0/ 22 | c 23 | I1=MIN0(LC,LI) 24 | I2=MAX0(LC,LI) 25 | NC=KG+2 26 | NR=2*NC 27 | c 28 | CALL SVD(B,NR,NC) 29 | c 30 | DO 25 I=I1,I2 31 | DO 20 J=1,NC 32 | DO 20 K=1,NR 33 | AS(K,J)=0.D0 34 | DO 20 L=1,NC 35 | 20 AS(K,J)=AS(K,J)+A(K,L,I)*B(L,J) 36 | DO 25 J=1,NC 37 | DO 25 K=1,NR 38 | 25 A(K,J,I)=AS(K,J) 39 | DO 35 J=1,NC 40 | DO 35 K=1,NR 41 | 35 B(K,J)=A(K,J,LC) 42 | c 43 | RETURN 44 | END 45 | -------------------------------------------------------------------------------- /src/mineos/parameter.h: -------------------------------------------------------------------------------- 1 | integer*4 nknot_t,nknot_s,nknot,nknot3,nknot4,nknot5,nknot6 2 | integer*4 nknot10,nknot14,maxbyte3,maxbyte4,maxbyte5,maxbyte 3 | integer*4 maxmodes,maxmodes1,maxl,maxll,maxtime,maxcomp,maxstat 4 | integer*4 maxn,maxold,maxold2,maxold3,nbranch,nprop,maxdisc,maxdh 5 | integer*4 mbuf,mfrechet,lhdr 6 | real*4 rfrctn 7 | c 8 | c more realistic estimates of the number of knots 9 | c need more t knots for iasp91 model (5 km mantle) 10 | c 11 | parameter (nknot_t = 600) 12 | parameter (nknot_s = 800) 13 | c 14 | c knot definitions for all raw mineos programs 15 | c 16 | parameter (nknot = 1000) 17 | parameter (nknot3 = 3*nknot) 18 | parameter (nknot4 = 4*nknot) 19 | parameter (nknot5 = 5*nknot) 20 | parameter (nknot6 = 6*nknot) 21 | parameter (nknot9 = 9*nknot) 22 | parameter (nknot10 = 10*nknot) 23 | parameter (nknot14 = 14*nknot) 24 | parameter (nknot18 = 18*nknot) 25 | parameter (maxbyte3 = nknot3+5) 26 | parameter (maxbyte4 = nknot4+5) 27 | parameter (maxbyte5 = nknot5+5) 28 | parameter (maxbyte = nknot6+5) 29 | c 30 | c other parameters for mineos programs & idagrn 31 | c 32 | c parameter (nbranch = 280) 33 | parameter (nbranch = 4000) 34 | parameter (nbranch2 = 2*nbranch) 35 | parameter (maxn = 4000) 36 | parameter (maxl = 50000) 37 | parameter (maxll = 50000) 38 | parameter (maxold = maxn*maxl) 39 | parameter (maxmodes = 400000) 40 | parameter (maxmodes1 = 400001) 41 | c 42 | c parameters for idagrn 43 | c 44 | parameter (maxtime = 7210) 45 | parameter (maxstat = 100) 46 | parameter (maxcomp = 6) 47 | c 48 | c parameter for plot_wk 49 | c 50 | parameter (nprop = 29) 51 | c 52 | c parameters of mineos_frechet_new 53 | c 54 | parameter (maxdisc = 30) 55 | parameter (maxdh = 50000) 56 | parameter (rfrctn = 10.) 57 | c 58 | c 6 + 1000*3 + 20 59 | c yielding a desire to make the arrays smaller: 60 | c 6 + 800*3 + 20 61 | c but need to consider anisotropy 62 | c 6 + 800*6 + 20 63 | c 64 | parameter (mbuf = 6+6*nknot_s) 65 | parameter (mfrechet = mbuf + maxdisc) 66 | c 67 | c mineos_partial 68 | c 69 | parameter (lhdr = 100) 70 | c 71 | c nfreq = 2*number of modes - maximum 72 | c nknot = number of knots in model 73 | c nknot3 = 3*number of knots 74 | c nknot6 = 6*number of knots 75 | c and so forth 76 | c 77 | c maxbyte = 6*knot + 5 78 | c 79 | c if you change nknot, be sure to change the other parameters as well 80 | c 81 | -------------------------------------------------------------------------------- /src/mineos/parameter_frechet.h: -------------------------------------------------------------------------------- 1 | integer*4 nknot_t,nknot_s,nknot,nknot3,nknot4,nknot5,nknot6 2 | integer*4 nknot10,nknot14,maxbyte3,maxbyte4,maxbyte5,maxbyte 3 | integer*4 maxmodes,maxmodes1,maxl,maxll,maxtime,maxcomp,maxstat 4 | integer*4 maxn,maxold,maxold2,maxold3,nbranch,nprop,maxdisc,maxdh 5 | integer*4 mbuf,mfrechet,lhdr 6 | real*4 rfrctn 7 | c 8 | c more realistic estimates of the number of knots 9 | c need more t knots for iasp91 model (5 km mantle) 10 | c 11 | parameter (nknot_t = 600) 12 | parameter (nknot_s = 800) 13 | c 14 | c knot definitions for all raw mineos programs 15 | c 16 | parameter (nknot = 1000) 17 | parameter (nknot3 = 3*nknot) 18 | parameter (nknot4 = 4*nknot) 19 | parameter (nknot5 = 5*nknot) 20 | parameter (nknot6 = 6*nknot) 21 | parameter (nknot9 = 9*nknot) 22 | parameter (nknot10 = 10*nknot) 23 | parameter (nknot14 = 14*nknot) 24 | parameter (nknot18 = 18*nknot) 25 | parameter (maxbyte3 = nknot3+5) 26 | parameter (maxbyte4 = nknot4+5) 27 | parameter (maxbyte5 = nknot5+5) 28 | parameter (maxbyte = nknot6+5) 29 | c 30 | c other parameters for mineos programs & idagrn 31 | c 32 | parameter (nbranch = 350) 33 | parameter (nbranch2 = 2*nbranch) 34 | parameter (maxn = 350) 35 | parameter (maxl = 3500) 36 | parameter (maxll = 7000) 37 | parameter (maxold = maxn*maxl) 38 | parameter (maxmodes = 150000) 39 | parameter (maxmodes1 = 150001) 40 | c 41 | c parameters for idagrn 42 | c 43 | parameter (maxtime = 7210) 44 | parameter (maxstat = 100) 45 | parameter (maxcomp = 6) 46 | c 47 | c parameter for plot_wk 48 | c 49 | parameter (nprop = 29) 50 | c 51 | c parameters of mineos_frechet_new 52 | c 53 | parameter (maxdisc = 30) 54 | parameter (maxdh = 50000) 55 | parameter (rfrctn = 10.) 56 | c 57 | c 6 + 1000*3 + 20 58 | c yielding a desire to make the arrays smaller: 59 | c 6 + 800*3 + 20 60 | c but need to consider anisotropy 61 | c 6 + 800*6 + 20 62 | c 63 | parameter (mbuf = 6+6*nknot_s) 64 | parameter (mfrechet = mbuf + maxdisc) 65 | c 66 | c mineos_partial 67 | c 68 | parameter (lhdr = 100) 69 | c 70 | c nfreq = 2*number of modes - maximum 71 | c nknot = number of knots in model 72 | c nknot3 = 3*number of knots 73 | c nknot6 = 6*number of knots 74 | c and so forth 75 | c 76 | c maxbyte = 6*knot + 5 77 | c 78 | c if you change nknot, be sure to change the other parameters as well 79 | c 80 | 81 | -------------------------------------------------------------------------------- /src/mineos/remedy_nohang.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE REMEDY(LS) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C OBTAINS THE EIGENFUNCTION OF AN AWKWARD SPHEROIDAL MODE BY 6 | C INTEGRATING TO THE ICB OR THE MCB. 7 | c 8 | c version to avoid hangups on tough modes -- see bottom of 9 | c routine -- jbg 1/00 10 | c 11 | c calls: FPROP, FSBDRY, MATCH, ORTHO, SFBDRY, SPROP 12 | c 13 | IMPLICIT REAL*8(A-H,O-Z) 14 | c 15 | SAVE 16 | c 17 | include 'parameter.h' 18 | c 19 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 20 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 21 | COMMON/EIFX/AR(14,nknot),INORM(nknot),idum2(nknot) 22 | COMMON/AREM/A(6,3,nknot) 23 | COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N 24 | DIMENSION AF(4,2),AS(6,3),AFR(4) 25 | DATA AF/8*0.D0/,AS/18*0.D0/,AFR/4*0.D0/,A/nknot18*0.D0/ 26 | c 27 | IEXP=0 28 | DO 10 K=1,2 29 | DO 10 J=1,4 30 | 10 AF(J,K)=0.D0 31 | AF(1,1)=1.D0 32 | IF(KG.EQ.1) AF(2,2)=1.D0 33 | IF(NSL.EQ.N) GOTO 5 34 | DO 6 I=NSLP1,N 35 | DO 6 K=1,3 36 | DO 6 J=1,6 37 | 6 A(J,K,I)=0.D0 38 | c 39 | CALL FPROP(N,NSLP1,AF,IEXP) 40 | c 41 | 5 CALL FSBDRY(AF,AS,KG) 42 | c 43 | DO 7 K=1,3 44 | DO 7 J=1,6 45 | 7 A(J,K,NSL)=AS(J,K) 46 | c 47 | IF(N.NE.NSL) CALL ORTHO(N,NSL,AS,KG) 48 | c 49 | CALL SPROP(N,NSL,NOCP1,AS,IEXP) 50 | c 51 | CALL SFBDRY(N,NOCP1,AS,AF,KG) 52 | c 53 | IMTCH=NOC 54 | DO 11 I=1,4 55 | 11 AFR(I)=AR(I,NOC) 56 | IF(LS.GT.NIC) GOTO 15 57 | c 58 | CALL FPROP(NOC,NICP1,AF,IEXP) 59 | c 60 | IMTCH=NIC 61 | DO 12 I=1,4 62 | 12 AFR(I)=AR(I,NICP1) 63 | c 64 | c 65 | c check to make sure first two elements of afr are 66 | c not zero -- if they are, then match hangs. Changes 67 | c LS to an error flag that is used back in detqn -- jbg 1/00 68 | 69 | 15 if(DABS(AFR(1)).lt.1.D-8 .and. DABS(AFR(2)).lt.1.D-8) then 70 | LS = -999 71 | else 72 | CALL MATCH(N,IMTCH,KG,AF,AFR) 73 | endif 74 | c 75 | RETURN 76 | END 77 | -------------------------------------------------------------------------------- /src/mineos/rkdot.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE RKDOT(F,S,H,NVEC,NI) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** PERFORMS DOT PRODUCT WITH RKS COEFFICIENTS *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | COMMON/SHANKS/B(46),C(10),DX,STEP(8),STEPF,IN,MAXO 12 | DIMENSION S(1),F(1),H(NVEC,1) 13 | c 14 | GOTO (1,2,3,4,5,6,7,8,9,10),NI 15 | 1 DO 21 J=1,NVEC 16 | 21 F(J)=S(J)+B(1)*H(J,1) 17 | RETURN 18 | c 19 | 2 DO 22 J=1,NVEC 20 | 22 F(J)=S(J)+B(2)*(H(J,1)+B(3)*H(J,2)) 21 | RETURN 22 | c 23 | 3 DO 23 J=1,NVEC 24 | 23 F(J)=S(J)+B(4)*(H(J,1)+B(5)*H(J,2)+B(6)*H(J,3)) 25 | RETURN 26 | c 27 | 4 DO 24 J=1,NVEC 28 | 24 F(J)=S(J)+B(7)*(H(J,1)+B(8)*H(J,2)+B(9)*H(J,3)+B(10)*H(J,4)) 29 | RETURN 30 | c 31 | 5 DO 25 J=1,NVEC 32 | 25 F(J)=S(J)+B(11)*(H(J,1)+B(12)*H(J,2)+B(13)*H(J,3)+B(14)*H(J,4)+ 33 | +B(15)*H(J,5)) 34 | RETURN 35 | c 36 | 6 DO 26 J=1,NVEC 37 | 26 F(J)=S(J)+B(16)*(H(J,1)+B(17)*H(J,2)+B(18)*H(J,3)+B(19)*H(J,4)+ 38 | +B(20)*H(J,5)+B(21)*H(J,6)) 39 | RETURN 40 | c 41 | 7 DO 27 J=1,NVEC 42 | 27 F(J)=S(J)+B(22)*(H(J,1)+B(23)*H(J,3)+B(24)*H(J,4)+B(25)*H(J,5)+ 43 | +B(26)*H(J,6)+B(27)*H(J,7)) 44 | RETURN 45 | c 46 | 8 DO 28 J=1,NVEC 47 | 28 F(J)=S(J)+B(28)*(H(J,1)+B(29)*H(J,3)+B(30)*H(J,4)+B(31)*H(J,5)+ 48 | +B(32)*H(J,6)+B(33)*H(J,7)+B(34)*H(J,8)) 49 | RETURN 50 | c 51 | 9 DO 29 J=1,NVEC 52 | 29 F(J)=S(J)+B(35)*(H(J,1)+B(36)*H(J,3)+B(37)*H(J,4)+B(38)*H(J,5)+ 53 | +B(39)*H(J,6)+B(40)*H(J,7)+B(41)*H(J,8)+B(42)*H(J,9)) 54 | RETURN 55 | c 56 | 10 DO 30 J=1,NVEC 57 | 30 F(J)=S(J)+B(43)*(H(J,1)+H(J,10)+B(44)*(H(J,4)+H(J,6))+ 58 | +B(45)*H(J,5)+B(46)*(H(J,7)+H(J,9))) 59 | c 60 | RETURN 61 | END 62 | -------------------------------------------------------------------------------- /src/mineos/rprop.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE RPROP(JF,JL,F) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** PROPAGATES SOLN ,F, FOR RADIAL MODES FROM JF TO JL *** 6 | c 7 | c calls: BAYLIS, RKDOT, TRKNT 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LCON,NCON,LSPL,NSPL,NN,LL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/EIFX/A(14,nknot),adum(nknot) 25 | COMMON/SHANKS/B(46),C(10),DX,STEP(8),STEPF,IN,MAXO 26 | DIMENSION H(2,10),S(2),F(2) 27 | DATA H/20*0.D0/,S/2*0.D0/ 28 | c 29 | MAXO1=MAXO-1 30 | Y=R(JF) 31 | VY=DSQRT((FLAM(JF)+2.D0*FMU(JF))/RHO(JF)) 32 | I=JF 33 | GO TO 50 34 | 10 IQ=I 35 | I=I+1 36 | X=Y 37 | Y=R(I) 38 | IF(Y.EQ.X) GOTO 50 39 | QFF=1.D0+XLAM(IQ)*FCT 40 | QLL=1.D0+QSHEAR(IQ)*FCT 41 | QAA=1.D0+XA2(IQ)*FCT 42 | VX=VY 43 | VY=DSQRT((FLAM(I)+2.D0*FMU(I))/RHO(I)) 44 | Q=DMAX1(W/VX+1.D0/X,W/VY+1.D0/Y) 45 | DEL=STEP(MAXO)/Q 46 | DXS=0.D0 47 | 15 Y=X+DEL 48 | IF(Y.GT.R(I)) Y=R(I) 49 | DX=Y-X 50 | c 51 | IF(DX.NE.DXS) CALL BAYLIS(Q,MAXO1) 52 | c 53 | DXS=DX 54 | S(1)=F(1) 55 | S(2)=F(2) 56 | DO 40 NI=1,IN 57 | Z=X+C(NI) 58 | T=Z-R(IQ) 59 | RO=RHO(IQ)+T*(QRO(1,IQ)+T*(QRO(2,IQ)+T*QRO(3,IQ))) 60 | GR=G(IQ)+T*(QG(1,IQ)+T*(QG(2,IQ)+T*QG(3,IQ))) 61 | FF=(FCON(IQ)+T*(FSPL(1,IQ)+T*(FSPL(2,IQ)+T*FSPL(3,IQ))))*QFF 62 | IF(IFANIS.NE.0) GOTO 30 63 | NN=(LCON(IQ)+T*(LSPL(1,IQ)+T*(LSPL(2,IQ)+T*LSPL(3,IQ))))*QLL 64 | CC=FF+NN+NN 65 | AA=CC 66 | GOTO 35 67 | 30 NN=(NCON(IQ)+T*(NSPL(1,IQ)+T*(NSPL(2,IQ)+T*NSPL(3,IQ))))*QLL 68 | CC=(CCON(IQ)+T*(CSPL(1,IQ)+T*(CSPL(2,IQ)+T*CSPL(3,IQ))))*QAA 69 | AA=(ACON(IQ)+T*(ASPL(1,IQ)+T*(ASPL(2,IQ)+T*ASPL(3,IQ))))*QAA 70 | 35 Z=1.D0/Z 71 | A21=-RO*WSQ+4.D0*Z*(Z*(AA-NN-FF*FF/CC)-RO*GR) 72 | H(1,NI)=(F(2)-2.D0*FF*Z*F(1))/CC 73 | H(2,NI)=A21*F(1)+2.D0*Z*F(2)*(FF/CC-1.D0) 74 | c 75 | 40 CALL RKDOT(F,S,H,2,NI) 76 | c 77 | IF(KNSW.NE.1) GOTO 45 78 | FP=A21*F(1)+2.D0*Z*F(2)*(FF/CC-1.D0) 79 | c 80 | CALL TRKNT(S(2),H(2,1),F(2),FP,X,Y) 81 | c 82 | 45 X=Y 83 | IF(Y.NE.R(I)) GO TO 15 84 | 50 A(1,I)=F(1) 85 | A(2,I)=F(2) 86 | IF(I.NE.JL) GO TO 10 87 | c 88 | RETURN 89 | END 90 | -------------------------------------------------------------------------------- /src/mineos/rps.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE RPS(I,AA) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** COMPUTES RADIAL MODE START SOLN USING POWER SERIES OR SPH BESSEL 6 | C*** FNS IF ARGUMENT IS TOO LARGE. 7 | c 8 | c calls: BFS 9 | c 10 | IMPLICIT REAL*8(A-H,O-Z) 11 | c 12 | include 'parameter.h' 13 | c 14 | REAL*8 LCON,NCON,LSPL,NSPL 15 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 16 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 17 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 18 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 19 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 20 | & ASPL(3,nknot) 21 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 22 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 23 | DIMENSION AA(2) 24 | c 25 | X=R(I) 26 | FLA=FLAM(I)*(1.D0+XLAM(I)*FCT) 27 | FU=FMU(I)*(1.D0+QSHEAR(I)*FCT) 28 | AA(1)=X 29 | Z=RHO(I)*X*X*(WSQ+4.D0*RHO(I)+G(I)/X)/(FLA+2.D0*FU) 30 | IF(Z.GT.0.1D0) GO TO 2 31 | D=1.D0 32 | U=0.D0 33 | UP=0.D0 34 | DC=1.D0 35 | A=0.D0 36 | B=1.D0 37 | 1 C=B 38 | A=A+2.D0 39 | B=B+2.D0 40 | UT=DC/B 41 | U=U+UT 42 | UP=UP+C*UT 43 | C=1.D0/(A*B) 44 | DC=-DC*C*Z 45 | D=D+DC 46 | IF(DABS(DC/D).GE.EPS) GO TO 1 47 | AA(2)=(FLA*D+2.D0*FU*UP)/U 48 | RETURN 49 | c 50 | 2 C=DSQRT(Z) 51 | c 52 | CALL BFS(L,C,EPS,D,A,B) 53 | c 54 | U=-A/C 55 | AA(2)=(FLA*D-2.D0*FU*B)/U 56 | c 57 | RETURN 58 | END 59 | -------------------------------------------------------------------------------- /src/mineos/sdepth.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE SDEPTH(WDIM,LS) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** FINDS STARTING LEVEL,LS, FOR A GIVEN L AND W *** 6 | c 7 | c calls: STARTL 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LCON,NCON,LSPL,NSPL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N 25 | DATA AW,BW,DW/-2.D-3,2.25D-3,1.28D-3/ 26 | c 27 | Q=0.D0 28 | W=WDIM/WN 29 | WSOC=AW+DW*FL 30 | IF(WDIM.GT.WSOC) GOTO 10 31 | c 32 | CALL STARTL(NOCP1,NSL,FMU,LS,Q) 33 | c 34 | IF(LS.EQ.NSL) LS=LS-1 35 | IF(LS.GT.NOCP1) RETURN 36 | c 37 | 10 WSIC=AW+BW*FL 38 | IF(WDIM.GT.WSIC) GOTO 20 39 | c 40 | CALL STARTL(NICP1,NOC,FLAM,LS,Q) 41 | c 42 | IF(LS.EQ.NOC) LS=LS-1 43 | IF(LS.GT.NICP1) RETURN 44 | c 45 | 20 CALL STARTL(2,NIC,FMU,LS,Q) 46 | c 47 | IF(LS.EQ.NIC) LS=LS-1 48 | c 49 | RETURN 50 | END 51 | -------------------------------------------------------------------------------- /src/mineos/sfbdry.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE SFBDRY(JF,JL,AS,AF,KG) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** THE TANGENTIAL TRACTION SCALAR IS FORCED TO VANISH AT THE SOLID 6 | C*** SIDE OF A S/F BOUNDARY(LEVEL JL).A(J,3,I) IS ELLIMINATED FOR 7 | C*** I=JF...JL AND AF IS LOADED FROM A AT LEVEL JL. 8 | c 9 | c calls no other routines 10 | c 11 | IMPLICIT REAL*8(A-H,O-Z) 12 | c 13 | include 'parameter.h' 14 | c 15 | COMMON/AREM/A(6,3,nknot) 16 | DIMENSION AS(6,1),AF(4,1) 17 | c 18 | N1=MIN0(JF,JL) 19 | N2=MAX0(JF,JL) 20 | IF(KG.NE.0) GOTO 25 21 | I1=1 22 | I2=2 23 | IF(DABS(AS(4,2)).GT.DABS(AS(4,1))) GOTO 10 24 | I1=2 25 | I2=1 26 | 10 RAT=-AS(4,I1)/AS(4,I2) 27 | DO 15 J=1,4 28 | DO 15 I=N1,N2 29 | 15 A(J,1,I)=A(J,I1,I)+RAT*A(J,I2,I) 30 | AF(1,1)=A(1,1,JL) 31 | AF(2,1)=A(3,1,JL) 32 | RETURN 33 | c 34 | 25 AB53=DABS(AS(5,3)) 35 | DO 30 K=1,2 36 | I1=K 37 | I2=3 38 | IF(AB53.GT.DABS(AS(5,K))) GOTO 35 39 | I1=3 40 | I2=K 41 | 35 RAT=-AS(5,I1)/AS(5,I2) 42 | DO 40 I=N1,N2 43 | DO 40 J=1,6 44 | 40 A(J,K,I)=A(J,I1,I)+RAT*A(J,I2,I) 45 | AF(1,K)=A(1,K,JL) 46 | AF(2,K)=A(3,K,JL) 47 | AF(3,K)=A(4,K,JL) 48 | 30 AF(4,K)=A(6,K,JL) 49 | c 50 | RETURN 51 | END 52 | -------------------------------------------------------------------------------- /src/mineos/sfbm.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE SFBM(ASS,KG,IBACK) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** CONVERT MINOR VECTOR AT A SOLID/FLUID BOUNDARY *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | DIMENSION ASS(14),AS(14) 12 | c 13 | DO 10 J=1,14 14 | AS(J)=ASS(J) 15 | 10 ASS(J)=0.D0 16 | IF(IBACK.EQ.1) GOTO 30 17 | IF(KG.NE.0) GOTO 20 18 | ASS(1)=AS(3) 19 | ASS(2)=AS(5) 20 | RETURN 21 | c 22 | 20 ASS(1)=AS(8) 23 | ASS(2)=-AS(12) 24 | ASS(3)=AS(3) 25 | ASS(4)=-AS(10) 26 | ASS(5)=AS(5) 27 | RETURN 28 | c 29 | 30 IF(KG.NE.0) GOTO 40 30 | ASS(1)=-AS(3) 31 | RETURN 32 | c 33 | 40 ASS(1)=AS(7) 34 | ASS(2)=-AS(9) 35 | ASS(3)=-AS(10) 36 | ASS(4)=-AS(14) 37 | c 38 | RETURN 39 | END 40 | -------------------------------------------------------------------------------- /src/mineos/startl.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE STARTL(JF,JL,V,LS,Q) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** FINDS START LEVEL BETWEEN JF AND JL USING VELOCITYV AND ANG. ORD. L. 6 | C*** UPON ENTRY Q IS THE VALUE OF THE EXPONENT AT R(JF) OR AT THE TURNING 7 | C*** POINT(Q=0) DEPENDING ON PREVIOUS CALLS TO STARTL. UPON EXIT Q IS THE 8 | C*** VALUE OF THE EXPONENT AT THE STARTING LEVEL LS. 9 | c 10 | c calls no other routines 11 | c 12 | IMPLICIT REAL*8(A-H,O-Z) 13 | c 14 | SAVE 15 | c 16 | include 'parameter.h' 17 | c 18 | REAL*8 LCON,NCON,LSPL,NSPL 19 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 20 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 21 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 22 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 23 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 24 | & ASPL(3,nknot) 25 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 26 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 27 | COMMON/RINDX/NIC,NOC,NSL,NICP1,NOCP1,NSLP1,N 28 | DIMENSION RRLOG(nknot),P(nknot),V(1) 29 | DATA IFIRST/1/ 30 | DATA RRLOG/nknot*0.D0/,P/nknot*0.D0/ 31 | c 32 | IF(IFIRST.NE.1) GOTO 5 33 | IFIRST=0 34 | VERTNO=-DLOG(EPS) 35 | DO 1 I=3,N 36 | 1 RRLOG(I)=.5D0*DLOG(R(I)/R(I-1)) 37 | 5 DO 10 J=JF,JL 38 | PP=FL3-WSQ*R(J)*R(J)*RHO(J)/V(J) 39 | IF(PP.LE.0.D0) GOTO 15 40 | 10 P(J)=DSQRT(PP) 41 | 15 P(J)=0.D0 42 | 20 K=J 43 | J=J-1 44 | IF(J.LE.JF) GO TO 25 45 | Q=Q+RRLOG(K)*(P(J)+P(K)) 46 | IF(Q.LT.VERTNO) GO TO 20 47 | LS=J 48 | RETURN 49 | c 50 | 25 LS=JF 51 | c 52 | RETURN 53 | END 54 | -------------------------------------------------------------------------------- /src/mineos/steps.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE STEPS(EPS) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** COMPUTES 8 DIMENSIONLESS STEP SIZES FOR RKS INTEGRATION 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | COMMON/SHANKS/B(46),C(10),DX,STEP(8),STEPF,IN,MAXO 11 | c 12 | PS=DLOG(EPS) 13 | FAC=1.D0 14 | DO 2 N=1,8 15 | FN=N+1 16 | FAC=FAC*FN 17 | X=(DLOG(FAC)+PS)/FN 18 | X=DEXP(X) 19 | S=X 20 | DO 1 I=1,N 21 | 1 S=X*DEXP(-S/FN) 22 | 2 STEP(N)=S 23 | c 24 | RETURN 25 | END 26 | -------------------------------------------------------------------------------- /src/mineos/svd.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE SVD(A,MROW,NCOL) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C SECTION I CHAPTER 10 WILKENSON AND REINSCH (1971 ,SPRINGER). 6 | C THE MATRIX A IS OVERWRITTEN WITH V(NCOL,NCOL), THE RIGHT SIDE ORTHOGONAL 7 | C MATRIX IN THE SVD DECOMPOSITION. FOR USE ONLY IN EOS SUBS AS ,TO REDUCE 8 | C BRANCHING POINTS, I HAVE USED THE FACT THAT NCOL IS LT MROW. 9 | c 10 | c calls no other routines 11 | c 12 | IMPLICIT REAL*8(A-H,O-Z) 13 | c 14 | SAVE 15 | DIMENSION A(6,1),E(3),Q(3) 16 | DATA E/3*0.D0/,Q/3*0.D0/ 17 | c 18 | EPS=1.5D-14 19 | TOL=1.D-293 20 | G=0.D0 21 | X=0.D0 22 | DO 60 I=1,NCOL 23 | L=I+1 24 | E(I)=G 25 | S=0.D0 26 | DO 10 J=I,MROW 27 | 10 S=S+A(J,I)*A(J,I) 28 | IF(S.GT.TOL) GO TO 15 29 | Q(I)=0.D0 30 | IF(L.GT.NCOL) GOTO 60 31 | GO TO 30 32 | 15 Q(I)=DSIGN(DSQRT(S),-A(I,I)) 33 | H=A(I,I)*Q(I)-S 34 | A(I,I)=A(I,I)-Q(I) 35 | IF(L.GT.NCOL) GO TO 60 36 | DO 25 J=L,NCOL 37 | S=0.D0 38 | DO 20 K=I,MROW 39 | 20 S=S+A(K,I)*A(K,J) 40 | F=S/H 41 | DO 25 K=I,MROW 42 | 25 A(K,J)=A(K,J)+F*A(K,I) 43 | 30 S=0.D0 44 | DO 35 J=L,NCOL 45 | 35 S=S+A(I,J)*A(I,J) 46 | IF(S.GE.TOL)GO TO 40 47 | G=0.D0 48 | GO TO 60 49 | 40 G=DSIGN(DSQRT(S),-A(I,L)) 50 | H=A(I,L)*G-S 51 | A(I,L)=A(I,L)-G 52 | DO 45 J=L,NCOL 53 | 45 E(J)=A(I,J)/H 54 | DO 55 J=L,MROW 55 | S=0.D0 56 | DO 50 K=L,NCOL 57 | 50 S=S+A(J,K)*A(I,K) 58 | DO 55 K=L,NCOL 59 | 55 A(J,K)=A(J,K)+S*E(K) 60 | 60 X=DMAX1(DABS(Q(I))+DABS(E(I)),X) 61 | GOTO 100 62 | 75 IF(G.EQ.0.D0)GO TO 91 63 | H=A(I,L)*G 64 | DO 80 J=L,NCOL 65 | 80 A(J,I)=A(I,J)/H 66 | DO 90 J=L,NCOL 67 | S=0.D0 68 | DO 85 K=L,NCOL 69 | 85 S=S+A(I,K)*A(K,J) 70 | DO 90 K=L,NCOL 71 | 90 A(K,J)=A(K,J)+S*A(K,I) 72 | 91 DO 95 J=L,NCOL 73 | A(I,J)=0.D0 74 | 95 CONTINUE 75 | DO 96 J=L,NCOL 76 | A(J,I)=0.D0 77 | 96 CONTINUE 78 | c 79 | c correction to prevent accessing arrays out of bounds 80 | c 81 | 100 if (i .eq. (ncol+1)) then 82 | i = ncol 83 | endif 84 | c 85 | A(I,I)=1.D0 86 | G=E(I) 87 | L=I 88 | I=I-1 89 | IF(I.GE.1)GO TO 75 90 | EP=EPS*X 91 | K=NCOL 92 | 105 L=K 93 | 110 IF(DABS(E(L)).LE.EP)GO TO 125 94 | IF(DABS(Q(L-1)).LE.EP) GO TO 115 95 | L=L-1 96 | IF(L.GE.1)GO TO 110 97 | 115 C=0.D0 98 | S=1.D0 99 | DO 120 I=L,K 100 | F=S*E(I) 101 | E(I)=C*E(I) 102 | IF(DABS(F).LE.EP)GO TO 125 103 | G=Q(I) 104 | H=DSQRT(F*F+G*G) 105 | C=G/H 106 | S=-F/H 107 | 120 Q(I)=H 108 | 125 Z=Q(K) 109 | IF(L.EQ.K)GO TO 145 110 | X=Q(L) 111 | Y=Q(K-1) 112 | G=E(K-1) 113 | H=E(K) 114 | F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.D0*H*Y) 115 | G=DSQRT(F*F+1.D0) 116 | F=((X-Z)*(X+Z)+H*(Y/(F+DSIGN(G,F))-H))/X 117 | C=1.D0 118 | S=1.D0 119 | LP1=L+1 120 | DO 140 I=LP1,K 121 | G=E(I) 122 | Y=Q(I) 123 | H=S*G 124 | G=C*G 125 | Z=DSQRT(F*F+H*H) 126 | IM1=I-1 127 | E(IM1)=Z 128 | C=F/Z 129 | S=H/Z 130 | F=S*G+C*X 131 | G=C*G-S*X 132 | H=S*Y 133 | Y=C*Y 134 | DO 130 J=1,NCOL 135 | X=A(J,IM1) 136 | Z=A(J,I) 137 | A(J,IM1)=C*X+S*Z 138 | 130 A(J,I)=C*Z-S*X 139 | Z=DSQRT(F*F+H*H) 140 | Q(IM1)=Z 141 | C=F/Z 142 | S=H/Z 143 | F=S*Y+C*G 144 | 140 X=C*Y-S*G 145 | E(L)=0.D0 146 | E(K)=F 147 | Q(K)=X 148 | GO TO 105 149 | 145 IF(Z.GE.0.D0)GO TO 155 150 | Q(K)=-Z 151 | DO 150 J=1,NCOL 152 | 150 A(J,K)=-A(J,K) 153 | 155 K=K-1 154 | IF(K.GE.1)GO TO 105 155 | c 156 | RETURN 157 | END 158 | -------------------------------------------------------------------------------- /src/mineos/tprop.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE TPROP(JF,JL,F) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** PROPAGATES F FROM JF TO JL - TOROIDAL MODES *** 6 | c 7 | c calls: BAYLIS, RKDOT, TRKNT 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | c 13 | include 'parameter.h' 14 | c 15 | REAL*8 LCON,NCON,LSPL,NSPL,NN,LL 16 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 17 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 18 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 19 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 20 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 21 | & ASPL(3,nknot) 22 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 23 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 24 | COMMON/EIFX/A(14,nknot),adum(nknot) 25 | COMMON/SHANKS/B(46),C(10),DX,STEP(8),STEPF,IN,MAXO 26 | DIMENSION H(2,10),S(2),F(2) 27 | DATA H/20*0.D0/,S/2*0.D0/ 28 | c 29 | FL3M2=FL3-2.D0 30 | MAXO1=MAXO-1 31 | Y=R(JF) 32 | VY=FMU(JF)/RHO(JF) 33 | I=JF 34 | GO TO 50 35 | 10 IQ=I 36 | I=I+1 37 | X=Y 38 | Y=R(I) 39 | IF(Y.EQ.X) GOTO 50 40 | QLL=1.D0+QSHEAR(IQ)*FCT 41 | VX=VY 42 | VY=FMU(I)/RHO(I) 43 | QX=1.D0/X+DSQRT(DABS(WSQ/(VX)-FL3/(X*X))) 44 | QY=1.D0/Y+DSQRT(DABS(WSQ/(VY)-FL3/(Y*Y))) 45 | Q=DMAX1(QX,QY) 46 | DEL=STEP(MAXO)/Q 47 | DXS=0.D0 48 | 15 Y=X+DEL 49 | IF(Y.GT.R(I)) Y=R(I) 50 | DX=Y-X 51 | c 52 | IF(DX.NE.DXS) CALL BAYLIS(Q,MAXO1) 53 | c 54 | DXS=DX 55 | S(1)=F(1) 56 | S(2)=F(2) 57 | DO 40 NI=1,IN 58 | Z=X+C(NI) 59 | T=Z-R(IQ) 60 | RO=RHO(IQ)+T*(QRO(1,IQ)+T*(QRO(2,IQ)+T*QRO(3,IQ))) 61 | LL=(LCON(IQ)+T*(LSPL(1,IQ)+T*(LSPL(2,IQ)+T*LSPL(3,IQ))))*QLL 62 | NN=LL 63 | IF(IFANIS.NE.0) NN=(NCON(IQ)+ 64 | + T*(NSPL(1,IQ)+T*(NSPL(2,IQ)+T*NSPL(3,IQ))))*QLL 65 | Z=1.D0/Z 66 | H(1,NI)=Z*F(1)+F(2)/LL 67 | H(2,NI)=(NN*FL3M2*Z*Z-RO*WSQ)*F(1)-3.D0*Z*F(2) 68 | c 69 | 40 CALL RKDOT(F,S,H,2,NI) 70 | c 71 | IF(KNSW.NE.1) GOTO 45 72 | FP=(NN*FL3M2*Z*Z-RO*WSQ)*F(1)-3.D0*Z*F(2) 73 | c 74 | CALL TRKNT(S(2),H(2,1),F(2),FP,X,Y) 75 | c 76 | 45 X=Y 77 | IF(Y.NE.R(I)) GOTO 15 78 | 50 A(1,I)=F(1) 79 | A(2,I)=F(2) 80 | IF(I.NE.JL) GO TO 10 81 | c 82 | RETURN 83 | END 84 | -------------------------------------------------------------------------------- /src/mineos/tps.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE TPS(I,A) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** COMPUTES TOROIDAL MODE START SOLN USING POWER SERIES OR SPH BESSEL 6 | C*** FNS IF ARGUMENT IS TOO LARGE. 7 | c 8 | c calls: BFS 9 | c 10 | IMPLICIT REAL*8(A-H,O-Z) 11 | c 12 | include 'parameter.h' 13 | c 14 | REAL*8 LCON,NCON,LSPL,NSPL 15 | COMMON R(nknot),FMU(nknot),FLAM(nknot),QSHEAR(nknot), 16 | & QKAPPA(nknot),XA2(nknot),XLAM(nknot),RHO(nknot), 17 | & QRO(3,nknot),G(nknot),QG(3,nknot),FCON(nknot), 18 | & FSPL(3,nknot),LCON(nknot),LSPL(3,nknot),NCON(nknot), 19 | & NSPL(3,nknot),CCON(nknot),CSPL(3,nknot),ACON(nknot), 20 | & ASPL(3,nknot) 21 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 22 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 23 | DIMENSION A(2) 24 | c 25 | A(1)=R(I) 26 | FU=FMU(I)*(1.D0+QSHEAR(I)*FCT) 27 | X2=WSQ*R(I)*R(I)*RHO(I)/FU 28 | TE=X2/(4.D0*FL+6.D0) 29 | IF(TE.GT.0.1D0) GO TO 10 30 | C=0.D0 31 | D=1.D0 32 | E=FL-1.D0 33 | F=D 34 | H=E 35 | 5 C=C+2.D0 36 | D=-D*X2/(C*(FL2+C)) 37 | E=E+2.D0 38 | F=F+D 39 | H=H+D*E 40 | IF(DABS(D/F).GT.EPS) GO TO 5 41 | A(2)=FU*H/F 42 | RETURN 43 | c 44 | 10 X=DSQRT(X2) 45 | c 46 | CALL BFS(L,X,EPS,F,H,D) 47 | c 48 | A(2)=FU*(X*H-F)/F 49 | c 50 | RETURN 51 | END 52 | -------------------------------------------------------------------------------- /src/mineos/trknt.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE TRKNT(Y1,Y1P,Y2,Y2P,X,Y) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** TOROIDAL AND RADIAL MODE COUNTER *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 13 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 14 | DIMENSION XS(2),VAL(4) 15 | DATA XS/2*0.D0/,VAL/4*0.D0/ 16 | c 17 | NS=0 18 | IF(KOUNT.EQ.0) GOTO 60 19 | H=Y-X 20 | A1=H*Y1P 21 | A2=-H*(2.D0*Y1P+Y2P)+3.D0*(Y2-Y1) 22 | A3=H*(Y1P+Y2P)-2.D0*(Y2-Y1) 23 | A33=3.D0*A3 24 | A22=2.D0*A2 25 | IF(A3.NE.0.D0) GOTO 20 26 | IF(A2.EQ.0.D0) GOTO 50 27 | XS(1)=-A1/A22 28 | IF(XS(1).GE.0.D0.AND.XS(1).LE.1.D0) NS=1 29 | GOTO 50 30 | 20 DISC=A2*A2-A1*A33 31 | IF(DISC) 50,25,30 32 | 25 XS(1)=-A2/A33 33 | IF(XS(1).GE.0.D0.AND.XS(1).LE.1.D0) NS=1 34 | GOTO 50 35 | 30 DISC=DSQRT(DISC) 36 | TR1=(-A2+DISC)/A33 37 | TR2=(-A2-DISC)/A33 38 | IF(DABS(A33).GT.DABS(A1)) GOTO 35 39 | FAC=A1/A33 40 | TR1=FAC/TR1 41 | TR2=FAC/TR2 42 | 35 IF(TR1.LT.0.D0.OR.TR1.GT.1.D0) GOTO 40 43 | XS(1)=TR1 44 | NS=1 45 | 40 IF(TR2.LT.0.D0.OR.TR2.GT.1.D0) GOTO 50 46 | NS=NS+1 47 | XS(NS)=TR2 48 | IF(NS.LT.2) GOTO 50 49 | IF(TR2.GE.TR1) GOTO 50 50 | XS(1)=TR2 51 | XS(2)=TR1 52 | 50 IF(NS.EQ.0) GOTO 60 53 | NS1=NS+1 54 | DO 55 J=2,NS1 55 | T=XS(J-1) 56 | 55 VAL(J)=Y1+T*(A1+T*(A2+T*A3)) 57 | 60 VAL(1)=Y1 58 | NS2=NS+2 59 | VAL(NS2)=Y2 60 | DO 100 J=2,NS2 61 | 100 IF(VAL(J-1)*VAL(J).LE.0.D0) KOUNT=KOUNT+1 62 | IF(VAL(1).EQ.0.D0) KOUNT=KOUNT-1 63 | c 64 | RETURN 65 | END 66 | -------------------------------------------------------------------------------- /src/mineos/whead.f: -------------------------------------------------------------------------------- 1 | subroutine whead(ioeig, jcoma, wmina, wmaxa, lmin, lmax, wgrava) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | c writes two records of header to the formatted output file 6 | c on the first entry 7 | c 8 | c calls no other routines 9 | c 10 | implicit real*8 (a-h,o-z) 11 | c 12 | include 'parameter.h' 13 | c 14 | real*4 wminl, wmaxl, wgravl, trefl, tdum(nknot,9) 15 | common/bits/pi,rn,vn,wn,w,wsq,wray,qinv,cg,wgrav,tref,fct,eps,fl, 16 | + fl1,fl2,fl3,sfl3,jcom,nord,l,kg,kount,knsw,ifanis,iback 17 | common/rindx/nic,noc,nsl,nicp1,nocp1,nslp1,n 18 | common/head/ tdum 19 | c 20 | data ifirst /0/ 21 | c 22 | save ifirst 23 | c 24 | c convert double precision to single precision 25 | c 26 | wminl = wmina 27 | wmaxl = wmaxa 28 | wgravl = wgrava 29 | trefl = tref 30 | c 31 | if (ifirst .eq. 0) then 32 | write(ioeig) jcom, wminl, wmaxl, lmin, lmax, wgravl 33 | write(ioeig) n, nic, noc, ifanis, trefl, (tdum(i,1),i=1,n), 34 | & (tdum(i,2),i=1,n), (tdum(i,3),i=1,n), (tdum(i,4),i=1,n), 35 | & (tdum(i,5),i=1,n), (tdum(i,6),i=1,n), (tdum(i,7),i=1,n), 36 | & (tdum(i,8),i=1,n), (tdum(i,9),i=1,n) 37 | endif 38 | ifirst = 1 39 | c 40 | return 41 | end 42 | -------------------------------------------------------------------------------- /src/mineos/zknt.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZKNT(S,SP,F,FP,X,Y,IFSOL) 2 | c 3 | c23456789012345678901234567890123456789012345678901234567890123456789012 4 | c 5 | C*** GIVEN MINOR VECTOR AND DERIVS,CONSTRUCTS MODE COUNT *** 6 | c 7 | c calls no other routines 8 | c 9 | IMPLICIT REAL*8(A-H,O-Z) 10 | c 11 | SAVE 12 | COMMON/BITS/PI,RN,VN,WN,W,WSQ,WRAY,QINV,CG,WGRAV,TREF,FCT,EPS,FL, 13 | + FL1,FL2,FL3,SFL3,JCOM,NORD,L,KG,KOUNT,KNSW,IFANIS,IBACK 14 | DIMENSION S(1),SP(1),F(1),FP(1),XS(4),VAL(4) 15 | DATA XS/4*0.D0/,VAL/4*0.D0/ 16 | c 17 | IF(IFSOL.EQ.0.AND.KG.EQ.0) GOTO 5 18 | Y1=S(5) 19 | Y2=F(5) 20 | Y1P=SP(5) 21 | Y2P=FP(5) 22 | T1=S(3)-S(4) 23 | T2=F(3)-F(4) 24 | T1P=SP(3)-SP(4) 25 | T2P=FP(3)-FP(4) 26 | GOTO 10 27 | 5 Y1=S(2) 28 | Y2=F(2) 29 | Y1P=SP(2) 30 | Y2P=FP(2) 31 | T1=S(1) 32 | T2=F(1) 33 | T1P=SP(1) 34 | T2P=FP(1) 35 | 10 H=Y-X 36 | NS=0 37 | IF(KOUNT.NE.0) GOTO 15 38 | A1=Y2-Y1 39 | A2=0.D0 40 | A3=0.D0 41 | A22=0.D0 42 | A33=0.D0 43 | GOTO 50 44 | 15 A1=H*Y1P 45 | A2=-H*(2.D0*Y1P+Y2P)+3.D0*(Y2-Y1) 46 | A3=H*(Y1P+Y2P)-2.D0*(Y2-Y1) 47 | A33=3.D0*A3 48 | A22=2.D0*A2 49 | IF(A3.NE.0.D0) GOTO 20 50 | IF(A2.EQ.0.D0) GOTO 50 51 | XS(2)=-A1/A22 52 | IF(XS(2).GE.0.D0.AND.XS(2).LE.1.D0) NS=1 53 | GOTO 50 54 | 20 DISC=A2*A2-A1*A33 55 | IF(DISC) 50,25,30 56 | 25 XS(2)=-A2/A33 57 | IF(XS(2).GE.0.D0.AND.XS(2).LE.1.D0) NS=1 58 | GOTO 50 59 | 30 DISC=DSQRT(DISC) 60 | TR1=(-A2+DISC)/A33 61 | TR2=(-A2-DISC)/A33 62 | IF(DABS(A33).GT.DABS(A1)) GOTO 35 63 | FAC=A1/A33 64 | TR1=FAC/TR1 65 | TR2=FAC/TR2 66 | 35 IF(TR1.LT.0.D0.OR.TR1.GT.1.D0) GOTO 40 67 | XS(2)=TR1 68 | NS=1 69 | 40 IF(TR2.LT.0.D0.OR.TR2.GT.1.D0) GOTO 50 70 | NS=NS+1 71 | XS(NS+1)=TR2 72 | IF(NS.LT.2) GOTO 50 73 | IF(TR2.GE.TR1) GOTO 50 74 | XS(2)=TR2 75 | XS(3)=TR1 76 | 50 VAL(1)=Y1 77 | XS(1)=0.D0 78 | NS2=NS+2 79 | VAL(NS2)=Y2 80 | XS(NS2)=1.D0 81 | IF(NS.EQ.0) GOTO 60 82 | NS1=NS+1 83 | DO 55 J=2,NS1 84 | T=XS(J) 85 | 55 VAL(J)=Y1+T*(A1+T*(A2+T*A3)) 86 | 60 IFT=0 87 | DO 100 J=2,NS2 88 | IF(VAL(J-1)*VAL(J).GT.0.D0) GOTO 100 89 | IF(VAL(J-1).NE.0.D0) GOTO 65 90 | TES=T1*A1 91 | GOTO 90 92 | 65 RT1=0.5D0*(XS(J-1)+XS(J)) 93 | RT=RT1 94 | DO 70 I=1,5 95 | V=Y1+RT*(A1+RT*(A2+RT*A3)) 96 | VP=A1+RT*(A22+RT*A33) 97 | ADD=-V/VP 98 | RT=RT+ADD 99 | IF(DABS(ADD).LT.1.D-5) GOTO 75 100 | IF(DABS(RT-RT1).LE..5D0) GOTO 70 101 | RT=RT1 102 | GOTO 75 103 | 70 CONTINUE 104 | 75 IF(IFT.NE.0) GOTO 85 105 | IF(KOUNT.NE.0) GOTO 80 106 | B1=T2-T1 107 | B2=0.D0 108 | B3=0.D0 109 | GOTO 85 110 | 80 B1=H*T1P 111 | B2=-H*(2.D0*T1P+T2P)+3.D0*(T2-T1) 112 | B3=H*(T1P+T2P)-2.D0*(T2-T1) 113 | IFT=1 114 | 85 TES=T1+RT*(B1+RT*(B2+RT*B3)) 115 | VP=A1+RT*(A22+RT*A33) 116 | TES=TES*VP 117 | 90 IF(TES.LT.0.D0) KOUNT=1+KOUNT 118 | IF(TES.GT.0.D0) KOUNT=KOUNT-1 119 | 100 CONTINUE 120 | c 121 | RETURN 122 | END 123 | -------------------------------------------------------------------------------- /src/plot_wk/MAKE_plot_wk.mk: -------------------------------------------------------------------------------- 1 | FFLAGS=-w -O1 -ffixed-line-length-none -fno-range-check 2 | #LFLAGS= $(MYLFLAGS) 3 | # FFLAGS=-ffixed-line-length-none 4 | PROG= plot_wk 5 | SUBS= amp.f branch_sort.f class.f color.f cvtaper.f excite.f fix_class_c.f \ 6 | fix_class_k.f fix_class_p.f fix_class_r.f fix_class_v.f interple.f \ 7 | interpol.f response.f search.o seek.f summary.f table.f wind.f 8 | OBJS= $(PROG).o $(SUBS:.f=.o) 9 | 10 | .f.o: 11 | gfortran $(FFLAGS) -c $*.f 12 | 13 | #---------------------------------------------------------------------------------- 14 | 15 | $(PROG): $(OBJS) 16 | gfortran $(FFLAGS) -o $(MINEOSBIN)/plot_wk $(OBJS) \ 17 | $(MINEOSLIB)/libcip.a \ 18 | $(MINEOSLIB)/libutil.a \ 19 | $(MINEOSLIB)/libtau.a 20 | 21 | # clean up huge .o files 22 | # rm plot_wk.o branch_sort.o 23 | 24 | # check object files for dependency on .h files 25 | $(OBJS): parameter.h 26 | gfortran $(FFLAGS) -c $*.f 27 | -------------------------------------------------------------------------------- /src/plot_wk/amp.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine amp(ida,lselect,title) 5 | c 6 | c subroutine to search over mode table 7 | c 8 | include 'parameter.h' 9 | c 10 | real*4 modes(0:maxmodes,nprop) 11 | real*4 value(nprop,2) 12 | real*4 fill(0:maxmodes) 13 | integer*4 inx(0:maxl,0:maxn),ifill(0:maxmodes),cfill(0:maxmodes) 14 | integer*4 inx2(0:maxmodes,2) 15 | integer*4 index(nprop), ida 16 | character*80 cval(nprop) 17 | character*256 title 18 | logical lsummary, lselect 19 | c 20 | common /mode/ inx, modes, inx2 21 | common /fill/ lsummary, fill, ifill, cfill 22 | common /nparam/ nparam, nextra 23 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 24 | common /value/ cval 25 | c 26 | c print out parameter 27 | c 28 | if ((ida .le. 0) .or. (ida .gt. 29)) then 29 | print*,' error selecting parameter' 30 | print*, ida 31 | ida = 0 32 | return 33 | else 34 | c print*, cval(ida) 35 | endif 36 | if (lselect) then 37 | do in = 1, nmodes 38 | if (ifill(in) .ne. 0) then 39 | fill(in) = modes(in,ida) 40 | endif 41 | end do 42 | else 43 | do in = 1, nmodes 44 | fill(in) = modes(in,ida) 45 | ifill(in) = 1 46 | end do 47 | endif 48 | title = cval(ida)(5:80) 49 | call color(nmodes) 50 | return 51 | end 52 | -------------------------------------------------------------------------------- /src/plot_wk/branch_sort.f: -------------------------------------------------------------------------------- 1 | subroutine branch_sort(b_file) 2 | c 3 | c subroutine to sort branches by nn 4 | c 5 | include 'parameter.h' 6 | c 7 | real*4 modes(0:maxmodes,nprop), wmin, wmax 8 | real*4 fill(0:maxmodes), temp(4) 9 | integer*4 jcom, nmodes 10 | integer*4 ifill(0:maxmodes),cfill(0:maxmodes) 11 | integer*4 inx(0:maxl,0:maxn),inx2(0:maxmodes,2) 12 | integer*4 nnb(0:maxl,nbranch), llb(0:maxl,nbranch), numb(nbranch) 13 | character*256 b_file 14 | logical lsummary, lbranch 15 | c 16 | common /mode/ inx, modes, inx2 17 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 18 | common /limits2/ wmin, wmax, pmin, pmax, gmin, gmax 19 | common /fill/ lsummary, fill, ifill, cfill 20 | common /branch/ lbranch, ib, numb, nnb, llb 21 | c 22 | data lbranch /.false./ 23 | c 24 | c first, zero any previous branch info 25 | c 26 | do ii = 1, nbranch 27 | do jj = 0, maxl 28 | nnb(jj,ii) = 0 29 | llb(jj,ii) = 0 30 | end do 31 | end do 32 | ib = 0 33 | c 34 | lbranch = .true. 35 | c 36 | c sort these branches by n 37 | c 38 | ib = 0 39 | do ii = nlow, nup 40 | ib = ib + 1 41 | im = 0 42 | do jj = llow, lup 43 | ic1 = inx(jj,ii) 44 | if ((modes(ic1,1) .ne. 0.) .and. (cfill(ic1) .gt. 3)) then 45 | ifill(ic1) = 1 46 | cfill(ic1) = 3 + (ib - (ib/3)*3) 47 | im = im + 1 48 | nnb(im,ib) = ii 49 | llb(im,ib) = jj 50 | endif 51 | end do 52 | numb(ib) = im 53 | end do 54 | c 55 | c now write output file containing branch information 56 | c two header records, followed by one record for each branch 57 | c each branch record contains a 6-tuple of info about each mode - nn, ll, w, q, cv, gv 58 | c 59 | open(unit=4,file=b_file,form='unformatted',access='sequential') 60 | write(4) jcom, nmodes, nlow, nup, llow, lup 61 | write(4) ib, (numb(ii), ii = 1, ib) 62 | do ii = 1, ib 63 | write(4) (nnb(jj,ii), llb(jj,ii), 64 | & (modes(inx(llb(jj,ii),nnb(jj,ii)),kk),kk=1,4),jj=1,numb(ii)) 65 | end do 66 | close(4) 67 | return 68 | end 69 | -------------------------------------------------------------------------------- /src/plot_wk/color.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine color(nmodes) 5 | c 6 | c subroutine to scale color 7 | c 8 | include 'parameter.h' 9 | c 10 | real*4 fill(0:maxmodes) 11 | real*4 fmax, fmid, fmin, ftotal, fint 12 | integer*4 ifill(0:maxmodes) 13 | integer*4 cfill(0:maxmodes) 14 | logical lsummary, lcolor 15 | c 16 | common /color2/ fmin, fmid, fmax 17 | common /color3/ lcolor, clmin, clmax 18 | common /fill/ lsummary, fill, ifill, cfill 19 | c 20 | c use hardwired limits or loop over modes and determine limits of 'fill' 21 | c 22 | if (lcolor) then 23 | fmin = clmin 24 | fmax = clmax 25 | else 26 | fmax = -999999999999999999. 27 | fmin = 999999999999999999. 28 | do ii = 1, nmodes 29 | if (ifill(ii) .ne. 0) then 30 | fmax = amax1(fmax,fill(ii)) 31 | fmin = amin1(fmin,fill(ii)) 32 | endif 33 | end do 34 | endif 35 | c print*,' color limits: ', fmin, fmax 36 | ftotal = fmax - fmin 37 | fmid = (fmax + fmin)/2. 38 | fint = abs(ftotal)/4. 39 | f1 = fmin + fint 40 | f2 = f1 + fint 41 | f3 = f2 + fint 42 | do ii = 1, nmodes 43 | if (ifill(ii) .ne. 0) then 44 | amp = fill(ii) 45 | if ((amp .ge. fmin) .and. (amp .lt. f1)) then 46 | cfill(ii) = 4 47 | elseif ((amp .ge. f1) .and. (amp .lt. f2)) then 48 | cfill(ii) = 5 49 | elseif ((amp .ge. f2) .and. (amp .lt. f3)) then 50 | cfill(ii) = 7 51 | elseif ((amp .ge. f3) .and. (amp .le. fmax)) then 52 | cfill(ii) = 8 53 | else 54 | cfill(ii) = 2 55 | endif 56 | else 57 | cfill(ii) = 2 58 | endif 59 | end do 60 | return 61 | end 62 | -------------------------------------------------------------------------------- /src/plot_wk/cvtaper.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | cSSS Steven S. Shapiro 5 | cSSS 4 January 1991 6 | cSSS Subroutine "cvtaper" performs a taper in phase velocity space. 7 | cSSS Function: 8 | cSSS Tapers phase velocity from cv0 to cv1 using Hanning window 9 | cSSS Sets phase velocities between cv1 and cv2 inclusive = 1 10 | cSSS Tapers phase velocity from cv2 to cv3 using Hanning window 11 | cSSS 12 | subroutine cvtaper (cv0, cv1, cv2, cv3) 13 | c 14 | include 'parameter.h' 15 | c 16 | real*4 modes(0:maxmodes,nprop) 17 | real*4 fill(0:maxmodes) 18 | real*4 19 | & tcv, 20 | c the phase velocity 21 | & cv0, 22 | & cv1, 23 | & cv2, 24 | & cv3, 25 | & pi 26 | integer*4 ifill(0:maxmodes) 27 | integer*4 cfill(0:maxmodes) 28 | integer*4 inx(0:maxl,0:maxn) 29 | integer*4 inx2(0:maxmodes,2) 30 | logical lsummary 31 | c 32 | common /mode/ inx, modes, inx2 33 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 34 | common /fill/ lsummary, fill, ifill, cfill 35 | c 36 | data pi / 3.141592654/ 37 | if ((cv0 .gt. cv1) .or. (cv1 .gt. cv2) .or. (cv2 .gt. cv3)) then 38 | print*, 'Error in "cvtaper": values are not in ascending order. 39 | &.' 40 | print*, 'Redo command.' 41 | return 42 | else 43 | end if 44 | do ii = 1, nmodes 45 | if (ifill(ii) .ne. 0) then 46 | c Mode has been selected 47 | tcv = modes(ii,3) 48 | if ((tcv .ge. cv1) .and. (tcv .le. cv2)) then 49 | fill(ii) = 1.0 50 | else if ((tcv .lt. cv1) .and. (tcv .ge. cv0)) then 51 | fill(ii) = 0.5 * (1 - cos (pi * (tcv - cv0) 52 | & / (cv1 - cv0))) 53 | else if ((tcv .gt. cv2) .and. (tcv .le. cv3)) then 54 | fill(ii) = 0.5 * (1 - cos (pi * (tcv - cv3) 55 | & / (cv2 - cv3))) 56 | else 57 | fill(ii) = 0.0 58 | end if 59 | else 60 | endif 61 | end do 62 | call color(nmodes) 63 | return 64 | end 65 | -------------------------------------------------------------------------------- /src/plot_wk/interple.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | real function interple(n1, n2, x, dx, xlast, y, m, b) 5 | c 6 | c given the coefficients for linear interpolation 7 | c this routine calculates y for an input x 8 | c 9 | c inputs: 10 | c n1: lower bound 11 | c n2: upper bound 12 | c x(n): array of x-values 13 | c dx: point a which the function is to be evaluated 14 | c y(n): function to be interpolated 15 | c m(n-1): slopes 16 | c b(n-1): intercepts 17 | c returned 18 | c y: interpolated value 19 | c 20 | parameter (n=5000) 21 | real x(n), dx, y(n) 22 | real b(n), m(n), xlast 23 | c 24 | if ((n2-n1) .gt. n) then 25 | print*,' array limits exceeded in interpl' 26 | stop 27 | endif 28 | c 29 | do i = n1, n2 30 | if (dx .eq. x(i)) then 31 | if (dx .eq. x(i+1)) then 32 | if (xlast .eq. 0.) then 33 | interple = y(i+1) 34 | return 35 | elseif (xlast .lt. x(i)) then 36 | interple = y(i) 37 | return 38 | else 39 | interple = y(i+1) 40 | return 41 | endif 42 | else 43 | interple = y(i) 44 | return 45 | endif 46 | elseif ((dx .gt. x(i)) .and. (dx .lt. x(i+1))) then 47 | if (m(i) .ge. 999.0) then 48 | if (xlast .lt. dx) then 49 | interple = y(i) 50 | else 51 | interple = y(i+1) 52 | endif 53 | else 54 | interple = m(i)*dx + b(i) 55 | endif 56 | return 57 | endif 58 | end do 59 | 20 continue 60 | c 61 | c outside array bounds - extrapolate 62 | c 63 | if (dx .lt. x(n1)) then 64 | interple = m(n1)*dx + b(n1) 65 | elseif (dx .gt. x(n2)) then 66 | interple = m(n2)*dx + b(n2) 67 | else 68 | print*,' error in interpolation' 69 | endif 70 | return 71 | end 72 | -------------------------------------------------------------------------------- /src/plot_wk/interpol.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine interpol(n1, n2, x, y, m, b) 5 | c 6 | c computes the coefficients for linear interpolation 7 | c y = mx + b 8 | c 9 | c inputs: 10 | c n1: lower bound for interpolation 11 | c n2: upper bound for interpolation 12 | c x(n): points at which the function is evaluated 13 | c y(n): function to be interpolated 14 | c outputs: 15 | c m(n): slopes of lines 16 | c b(n): intercepts 17 | c 18 | save 19 | parameter (n=5000) 20 | real x(n), y(n) 21 | real b(n), m(n) 22 | c 23 | if ((n2-n1) .gt. n) then 24 | print*,'array limits exceeded in interpol',n2-n1,n 25 | stop 26 | endif 27 | do i = n1, n2-1 28 | dx = x(i+1) - x(i) 29 | dy = y(i+1) - y(i) 30 | if (dx .eq. 0.) then 31 | m(i) = 999.0 32 | else 33 | m(i) = dy/dx 34 | endif 35 | b(i) = y(i) - m(i)*x(i) 36 | end do 37 | return 38 | end 39 | -------------------------------------------------------------------------------- /src/plot_wk/mask_phase.mk: -------------------------------------------------------------------------------- 1 | FFLAGS= $(MYFFLAGS) 2 | LFLAGS= $(MYLFLAGS) 3 | # 4 | SUBS= amp.o branch_sort.o class.o color.o cvtaper.o excite_phase.o fix_class_c.o \ 5 | fix_class_k.o fix_class_p.o fix_class_r.o fix_class_v.o interple.o \ 6 | interpol.o response.o search.o seek.o summary.o table.o wind_phase.o 7 | OBJS= mask_phase.o $(SUBS) 8 | 9 | 10 | mask_phase: $(OBJS) 11 | f77 $(FFLAGS) $(LFLAGS) -o $(MYBIN)/mask_phase $(OBJS) \ 12 | $(USRLIB)/libcip.a \ 13 | $(USRLIB)/libutil.a 14 | # clean up huge .o files 15 | rm plot_wk.o branch_sort.o 16 | 17 | -------------------------------------------------------------------------------- /src/plot_wk/numerical.h: -------------------------------------------------------------------------------- 1 | c 2 | c include file for useful constants 3 | c 4 | c pi = 3.14159265350 5 | c 6 | pi = 4.*atan(1.0) 7 | tpi = 2.0*pi 8 | pi2 = 0.5*pi 9 | pi4 = 0.25*pi 10 | c 11 | c drad - degrees to radians 12 | c 13 | drad = pi/180. 14 | c 15 | c radd - radians to degrees 16 | c 17 | radd = 180./pi 18 | c 19 | c rmhz - radians/s to mhz 20 | c 21 | rmhz = 1000./tpi 22 | c 23 | c rad - mhz to radians/s 24 | c 25 | rad = 1.0/rmhz 26 | c 27 | c rn - earth radius in meters 28 | c 29 | rn = 6371000.0 30 | c 31 | c rnk - earth radius in km 32 | c 33 | rnk = 6371. 34 | c 35 | c dkm - degrees to km 36 | c 37 | dkm = rnk*drad 38 | c 39 | bigg = 6.6732e-11 40 | rhobar = 5515.0 41 | c 42 | third = 1.0/3.0 43 | tthird = 2.0/3.0 44 | fthird = 4.0/3.0 45 | c 46 | c for Barbara's mode scalings 47 | c 48 | gn = pi*bigg*rhobar*rn 49 | vn2 = gn*rn 50 | vn = sqrt(vn2) 51 | wn = vn/rn 52 | c 53 | c time - for counting seconds 54 | c 55 | spmin = 60. 56 | sphr = 3600. 57 | spday = 86400. 58 | c 59 | c ellipiticy 60 | c 61 | flt = 298.25 62 | c 63 | -------------------------------------------------------------------------------- /src/plot_wk/parameter.f: -------------------------------------------------------------------------------- 1 | integer*4 npmax,npmax2,npmax4,nsmax,ncmax,nlmax,nphase 2 | integer*4 maxcal,mkine,mrayp 3 | c 4 | c npmax is the standard dimension for arrays -- it is used in 5 | c some programs that DOUBLE the trace (i.e. xcor) so it needs to 6 | c be twice what you need -- kind of a space waste, should be 7 | c changed eventually... 8 | c 9 | parameter (npmax = 400000) 10 | c 11 | c npmax2 is (npmax+2)/2 for the fft 12 | c 13 | parameter (npmax2 = 200001) 14 | c 15 | c what is this used for -- can't find it? 16 | c 17 | parameter (npmax4 = 640004) 18 | parameter (nsmax = 120) 19 | parameter (ncmax = 3) 20 | parameter (nlmax = 100) 21 | parameter (nphase = 100) 22 | parameter (maxcal = 5000) 23 | parameter (mkine = 10) 24 | parameter (mrayp = 100) 25 | -------------------------------------------------------------------------------- /src/plot_wk/parameter.h: -------------------------------------------------------------------------------- 1 | integer*4 nknot_t,nknot_s,nknot,nknot3,nknot4,nknot5,nknot6 2 | integer*4 nknot10,nknot14,maxbyte3,maxbyte4,maxbyte5,maxbyte 3 | integer*4 maxmodes,maxmodes1,maxl,maxll,maxtime,maxcomp,maxstat 4 | integer*4 maxn,maxold,maxold2,maxold3,nbranch,nprop,maxdisc,maxdh 5 | integer*4 mbuf,mfrechet,lhdr 6 | real*4 rfrctn 7 | c 8 | c more realistic estimates of the number of knots 9 | c need more t knots for iasp91 model (5 km mantle) 10 | c 11 | parameter (nknot_t = 600) 12 | parameter (nknot_s = 800) 13 | c 14 | c knot definitions for all raw mineos programs 15 | c 16 | parameter (nknot = 1000) 17 | parameter (nknot3 = 3*nknot) 18 | parameter (nknot4 = 4*nknot) 19 | parameter (nknot5 = 5*nknot) 20 | parameter (nknot6 = 6*nknot) 21 | parameter (nknot9 = 9*nknot) 22 | parameter (nknot10 = 10*nknot) 23 | parameter (nknot14 = 14*nknot) 24 | parameter (nknot18 = 18*nknot) 25 | parameter (maxbyte3 = nknot3+5) 26 | parameter (maxbyte4 = nknot4+5) 27 | parameter (maxbyte5 = nknot5+5) 28 | parameter (maxbyte = nknot6+5) 29 | c 30 | c other parameters for mineos programs & idagrn 31 | c 32 | parameter (nbranch = 350) 33 | parameter (nbranch2 = 2*nbranch) 34 | parameter (maxn = 350) 35 | parameter (maxl = 3500) 36 | parameter (maxll = 7000) 37 | parameter (maxold = maxn*maxl) 38 | parameter (maxmodes = 150000) 39 | parameter (maxmodes1 = 150001) 40 | c 41 | c parameters for idagrn 42 | c 43 | parameter (maxtime = 7210) 44 | parameter (maxstat = 100) 45 | parameter (maxcomp = 6) 46 | c 47 | c parameter for plot_wk 48 | c 49 | parameter (nprop = 29) 50 | c 51 | c parameters of mineos_frechet_new 52 | c 53 | parameter (maxdisc = 30) 54 | parameter (maxdh = 50000) 55 | parameter (rfrctn = 10.) 56 | c 57 | c 6 + 1000*3 + 20 58 | c yielding a desire to make the arrays smaller: 59 | c 6 + 800*3 + 20 60 | c but need to consider anisotropy 61 | c 6 + 800*6 + 20 62 | c 63 | parameter (mbuf = 6+6*nknot_s) 64 | parameter (mfrechet = mbuf + maxdisc) 65 | c 66 | c mineos_partial 67 | c 68 | parameter (lhdr = 100) 69 | c 70 | c nfreq = 2*number of modes - maximum 71 | c nknot = number of knots in model 72 | c nknot3 = 3*number of knots 73 | c nknot6 = 6*number of knots 74 | c and so forth 75 | c 76 | c maxbyte = 6*knot + 5 77 | c 78 | c if you change nknot, be sure to change the other parameters as well 79 | c 80 | 81 | -------------------------------------------------------------------------------- /src/plot_wk/response.f: -------------------------------------------------------------------------------- 1 | subroutine response(r_file) 2 | c 3 | c subroutine to add instrument group delay 4 | c 5 | include 'parameter.h' 6 | c 7 | real*4 modes(0:maxmodes,nprop) 8 | real*4 mhz, rad, pi, tpi, dist 9 | real*4 omega(5000), gi(5000), mgi(5000), bgi(5000) 10 | real*4 interple 11 | c 12 | integer*4 inx(0:maxl,0:maxn),inx2(0:maxmodes,2) 13 | c 14 | character*256 r_file 15 | c 16 | common /mode/ inx, modes, inx2 17 | common /nparam/ nparam, nextra 18 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 19 | common /limits2/ wmin, wmax, pmin, pmax, gmin, gmax 20 | c 21 | data tpi /6.2831853071796/ 22 | c 23 | mhz = 1000./tpi 24 | rad = 1.0/mhz 25 | pi = tpi/2. 26 | c 27 | c open and read file 28 | c 29 | open(unit=3,file=r_file,form='unformatted',access='sequential') 30 | c & status='readonly') 31 | read(3) ic 32 | do ii = 1, ic 33 | read(3) w, t1, t2, t3, dg 34 | omega(ii) = w*mhz 35 | gi(ii) = dg 36 | end do 37 | close(3) 38 | c 39 | c check to find the index which is greater than the maximum frequency 40 | c 41 | w = 0.0 42 | if = 0 43 | do while (w .lt. wmax) 44 | if = if + 1 45 | w = omega(if) 46 | end do 47 | c 48 | c interpolate these values 49 | c 50 | call interpol(1,if,omega,gi,mgi,bgi) 51 | c 52 | c now loop over the modes and add the instrument group delay to the total group delay 53 | c 54 | wl = 0. 55 | do ii = 1, nmodes 56 | w = modes(ii,1) 57 | wf = 0.0 58 | lf = 0 59 | do while (wf .lt. w) 60 | lf = lf + 1 61 | wf = omega(lf) 62 | end do 63 | lf = lf - 1 64 | if (lf .le. 0) then 65 | lf = 1 66 | endif 67 | dg = interple(lf,if,omega,w,wl,gi,mgi,bgi) 68 | modes(ii,29) = dg 69 | end do 70 | nextra = nextra + 1 71 | c 72 | c all done 73 | c 74 | return 75 | end 76 | -------------------------------------------------------------------------------- /src/plot_wk/seek.f: -------------------------------------------------------------------------------- 1 | subroutine seek(a,i1,i2,value,index) 2 | c 3 | include 'parameter.h' 4 | c 5 | real*4 a(nknot) 6 | c 7 | dv = 999999999 8 | c 9 | do ii = i1, i2 10 | if (dv .gt. abs(a(ii) - value)) then 11 | dv = abs(a(ii) - value) 12 | index = ii 13 | endif 14 | end do 15 | return 16 | end 17 | -------------------------------------------------------------------------------- /src/plot_wk/table.f: -------------------------------------------------------------------------------- 1 | subroutine table(m_file) 2 | c 3 | c subroutine to open mode table file 4 | c 5 | include 'parameter.h' 6 | c 7 | real*4 modes(0:maxmodes,nprop) 8 | real*4 wmin, wmax, pmin, pmax, gmin, gmax 9 | integer*4 inx(0:maxl,0:maxn), inx2(0:maxmodes,2) 10 | integer*4 jcom, nmodes, nlow, nup, llow, lup 11 | character*256 m_file 12 | c 13 | common /mode/ inx, modes, inx2 14 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 15 | common /limits2/ wmin, wmax, pmin, pmax, gmin, gmax 16 | common /nparam/ nparam, nextra 17 | c 18 | data tpi / 6.2831853071796/ 19 | c 20 | c open and read header records 21 | c 22 | open(unit=3,file=m_file,form='unformatted',access='sequential') 23 | read(3) jcom, nmodes, wmin, wmax, llmin, llmax 24 | read(3) dum 25 | read(3) idum 26 | read(3) idum 27 | read(3) idum 28 | c 29 | c intialize limits 30 | c 31 | wmin = 999999. 32 | wmax = 0. 33 | pmin = 999999. 34 | pmax = 0. 35 | gmin = 999999. 36 | gmax = 0. 37 | nlow = 999999 38 | nup = 0 39 | llow = 999999 40 | lup = 0 41 | c 42 | c now read mode table 43 | c 44 | do ii = 1, nmodes 45 | read(3,end = 25) nn, ll, w, qq, alpha, phi, cv, gv 46 | inx(ll,nn) = ii 47 | inx2(ii,1) = ll 48 | inx2(ii,2) = nn 49 | modes(ii,1) = w*1000./tpi 50 | modes(ii,2) = qq 51 | modes(ii,3) = cv 52 | modes(ii,4) = gv 53 | do kk = 5, nparam 54 | modes(ii,kk) = 0.0 55 | end do 56 | wmin = amin1(wmin,modes(ii,1)) 57 | wmax = amax1(wmax,modes(ii,1)) 58 | pmin = amin1(pmin,modes(ii,3)) 59 | pmax = amax1(pmax,modes(ii,3)) 60 | gmin = amin1(gmin,modes(ii,4)) 61 | gmax = amax1(gmax,modes(ii,4)) 62 | nlow = min0(nlow,nn) 63 | nup = max0(nup,nn) 64 | llow = min0(llow,ll) 65 | lup = max0(lup,ll) 66 | end do 67 | 25 continue 68 | close(3) 69 | print*, ' jcom = ', jcom,' # modes = ',nmodes 70 | print*, ' wmin = ', wmin,' wmax = ', wmax 71 | print*, ' nmin = ', nlow,' nmax = ', nup 72 | print*, ' lmin = ', llow,' lmax = ', lup 73 | c 74 | c check over table for lost modes 75 | c 76 | print*, ' ' 77 | do ii = nlow, nup 78 | do jj = llow, lup 79 | if (inx(jj,ii) .eq. 0) then 80 | do kk = jj, lup 81 | if (inx(kk,ii) .ne. 0) then 82 | go to 30 83 | end if 84 | end do 85 | go to 35 86 | 30 continue 87 | print*,' mode not found: ', ii, jj 88 | end if 89 | end do 90 | 35 continue 91 | end do 92 | c 93 | call color(nmodes) 94 | c 95 | return 96 | end 97 | -------------------------------------------------------------------------------- /src/plot_wk/wind.f: -------------------------------------------------------------------------------- 1 | c 2 | c 3 | c 4 | subroutine wind(gv0,s0,np) 5 | c 6 | c subroutine to window about group velocity 7 | c 8 | include 'parameter.h' 9 | c 10 | character*1 wtype 11 | real*4 modes(0:maxmodes,nprop) 12 | real*4 fill(0:maxmodes), dist, dep 13 | real*4 gv0, s0, t0, tgv, arg, amp 14 | integer*4 ifill(0:maxmodes) 15 | integer*4 cfill(0:maxmodes) 16 | integer*4 inx(0:maxl,0:maxn) 17 | integer*4 inx2(0:maxmodes,2) 18 | logical lsummary 19 | c 20 | common /mode/ inx, modes, inx2 21 | common /limits/ jcom, nmodes, nlow, nup, llow, lup 22 | common /fill/ lsummary, fill, ifill, cfill 23 | common /c_excite/ dist, dep 24 | c 25 | c sign convention here is that source (modes(ii,28)) and instrument delay (modes(ii,29)) 26 | c have minus signs 27 | c 28 | t0 = dist/gv0 29 | do ii = 1, nmodes 30 | if (ifill(ii) .ne. 0) then 31 | if (np .eq. 0) then 32 | tgv = modes(ii,27) 33 | elseif (np .eq. 1) then 34 | tgv = modes(ii,27) - modes(ii,28) 35 | elseif (np .eq. 2) then 36 | tgv = modes(ii,27) - modes(ii,28) - modes(ii,29) 37 | endif 38 | arg = s0*(tgv - t0) 39 | amp = exp(-0.5*arg**2) 40 | fill(ii) = amp*fill(ii) 41 | endif 42 | end do 43 | call color(nmodes) 44 | return 45 | end 46 | --------------------------------------------------------------------------------