SPEED
MAKE_MECH_PROP_CASE_012.f90
Go to the documentation of this file.
1! Copyright (C) 2012 The SPEED FOUNDATION
2! Author: Ilario Mazzieri
3!
4! This file is part of SPEED.
5!
6! SPEED is free software; you can redistribute it and/or modify it
7! under the terms of the GNU Affero General Public License as
8! published by the Free Software Foundation, either version 3 of the
9! License, or (at your option) any later version.
10!
11! SPEED is distributed in the hope that it will be useful, but
12! WITHOUT ANY WARRANTY; without even the implied warranty of
13! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14! Affero General Public License for more details.
15!
16! You should have received a copy of the GNU Affero General Public License
17! along with SPEED. If not, see <http://www.gnu.org/licenses/>.
18
19
21
22
23 subroutine make_mech_prop_case_012(rho, lambda, mu, gamma, qs, qp, & !outputs
24 xs, ys, zs, Depth, zs_all,&
25 vs30, thickness, sub_tag_all, f_distance)
26
27 real*8, intent(out) :: rho, lambda, mu, gamma, qs, qp
28 real*8, intent(in) :: xs, ys, zs, depth, zs_all,&
29 vs30, thickness, f_distance
30 integer*4 :: sub_tag_all
31 real*8 :: ni, vs, vp, depth_real
32
33 rho = 0.d0;
34 lambda = 0.d0;
35 mu = 0.d0;
36 gamma = 0.d0;
37 qs = 0.d0;
38 qp = 0.d0
39
40
41
42
43 if ((depth.ge.0.0d0).and.(zs_all.ge.0.0d0)) then
44 ! + MATERIAL INSIDE THE BASIN
45 if (depth .le. 150.0d0) then
46 vs = 300.d0
47 vp = 1500.d0
48 rho = 1800.d0
49 lambda = rho * (vp**2 - 2*vs**2)
50 mu = rho * vs**2
51 qs = 0.1*vs;
52 gamma = (3.1415*(2.d0/3.d0))/qs !hy: fpeak = 2/3 Hz
53
54 elseif(depth .gt. 150.d0 .and. depth .le. f_distance) then
55 vs = 300.d0 + 10.d0*(depth-150.d0)**0.5
56 vp = 1500.d0 + 10.d0*(depth-150.d0)**0.5
57 rho = 1800.d0 + 6.d0*(depth-150.d0)**0.5
58 lambda = rho * (vp**2 - 2*vs**2)
59 mu = rho * vs**2
60 qs = 0.1*vs;
61 gamma = (3.1415*(2.d0/3.d0))/qs
62
63 else
64 vs = 800.d0 + 15.d0*(depth-f_distance)**0.5
65 vp = 2000.d0 + 15.d0*(depth-f_distance)**0.5
66 rho = 2100.d0 + 4.d0*(depth-f_distance)**0.5
67 lambda = rho * (vp**2 - 2*vs**2)
68 mu = rho * vs**2
69 qs = 0.1*vs
70 gamma = (3.1415*(2/3))/qs
71
72 endif
73
74 else
75 ! + MATERIAL INSIDE THE BEDROCK
76 depth_real = abs(zs)
77 if (depth_real .le. 1000.0d0) then
78 vs = 1200.d0
79 vp = 2300.d0
80 rho = 2100.d0
81 lambda = rho * (vp**2 - 2*vs**2)
82 mu = rho * vs**2
83 gamma = (3.1415*(2/3))/(150.d0)
84 !if(damping_type .eq. 2) then
85 ! qs=120.d0; qp=230.d0;
86 !endif
87 elseif (depth_real.le.3000.0d0) then
88 vs = 2100.d0
89 vp = 3500.d0
90 rho = 2200.d0
91 lambda = rho * (vp**2 - 2*vs**2)
92 mu = rho * vs**2
93 gamma = (3.1415*(2/3))/(200.d0)
94 !if(damping_type .eq. 2) then
95 ! qs=200.d0; qp=400.d0;
96 !endif
97
98 elseif (depth_real.le.6000.0d0) then
99 vs = 2750.d0
100 vp = 4750.d0
101 rho = 2400.d0
102 lambda = rho * (vp**2 - 2*vs**2)
103 mu = rho * vs**2
104 gamma = (3.1415*(2/3))/(250.d0)
105 !if(damping_type .eq. 2) then
106 ! qs=250.d0; qp=500.d0;
107 !endif
108 else
109 vs = 3670.d0
110 vp = 6340.d0
111 rho = 2800.d0
112 lambda = rho * (vp**2 - 2*vs**2)
113 mu = rho * vs**2
114 gamma = (3.1415*(2/3))/(350.d0)
115 !if(damping_type .eq. 2) then
116 ! qs=350.d0; qp=700.d0;
117 !endif
118
119 endif
120 endif
121
122
123
124
125 end subroutine make_mech_prop_case_012
make_mech_prop_case_012
subroutine make_mech_prop_case_012(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all, f_distance)
Makes not-honoring technique.
Definition MAKE_MECH_PROP_CASE_012.f90:26