Assignes material properties node by node.
53 cs_nnz_loc, cs_loc, ielem, &
54 sub_tag_all, zs, mpi_id, local_n_num, &
55 damping_type, qs, qp, &
56 xs, ys, check_case, label_case)
57
58
59 implicit none
60
61 integer*4 :: tcase, check_case, label_case
62 integer*4 :: vcase, mpi_id
63 integer*4 :: nn
64 integer*4 :: p, q, r, ic
65 integer*4 :: nn_loc
66 integer*4 :: cs_nnz_loc
67 integer*4 :: is,in,ielem , damping_type
68
69 integer*4, dimension(nn_loc) :: local_n_num
70 integer*4, dimension(nn_loc) :: sub_tag_all
71 integer*4, dimension(0:cs_nnz_loc) :: cs_loc
72
73 real*8 :: depth, depth_real, qs_all, qp_all, thickness, vs30, pig
74 real*8 :: vs,vp, rho,lambda,mu,gamma,ni, qs,qp
75 real*8 :: x1,y1,x2,y2,coef_a, coef_b, coef_c, numer, den, distance, f_distance
76
77 real*8, dimension(nn_loc) :: zs_elev
78 real*8, dimension(nn_loc) :: zs_all
79 real*8, dimension(nn_loc) :: vs_nodes, thick_nodes
80
81 real*8, dimension(nn_loc) :: zs, xs, ys
82
83 real*8, dimension(nn,nn,nn) :: rho_el,lambda_el,mu_el,gamma_el, qs_h, qp_h
84
85 real*8 :: stat_id1_x, stat_id1_y, stat_id2_x, stat_id2_y
86
87 character*70 :: filename
88 character*5 :: filesuffix
89
90
91 pig = 4.d0*datan(1.d0);
92
93
94
95 if (check_case .eq. 1) then
96
97 filesuffix = '.dat'
98 write(filename, '(A,I5.5,A5)') 'NHCheck', mpi_id, filesuffix
99
100
101 open(1000 + mpi_id,file=filename,position='APPEND')
102 endif
103
104 do r = 1,nn
105 do q = 1,nn
106 do p = 1,nn
107 is = nn*nn*(r -1) +nn*(q -1) +p
108 in = cs_loc(cs_loc(ielem -1) +is)
109 ic = in
110
111 if (ic .eq. 0 ) write(*,*) 'Error in MAKE_ELTENSOR_FOR_CASES '
112
113 if (tcase.eq.1) then
114
116 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
117 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
118
119 elseif (tcase.eq.2) then
120
122 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
123 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
124
125 elseif (tcase.eq.3) then
126
128 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
129 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
130
131 elseif (tcase.eq.4) then
132
134 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
135 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
136
137 elseif (tcase.eq.5) then
138
140 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
141 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
142
143
144 elseif (tcase.eq.6) then
145
147 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
148 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
149
150 elseif (tcase.eq.7) then
151
153 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
154 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
155
156 elseif (tcase.eq.8) then
157
159 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
160 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
161
162 elseif (tcase.eq.10) then
163
165 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
166 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
167
168 elseif (tcase.eq.11) then
169
171 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
172 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
173
174 elseif (tcase.eq.12) then
175
176
177
178 x1 = 654957.002352; y1 = 4974060.299450;
179 x2 = 688420.525202; y2 = 4957613.600935;
180
181 coef_a = 1.d0/(x2-x1);
182 coef_b = 1.d0/(y1-y2);
183 coef_c = - y1/(y1-y2) + x1/(x1-x2);
184
185 numer = coef_a*xs(ic) + coef_b*ys(ic) + coef_c
186 den = dsqrt(coef_a**2 + coef_b**2)
187 distance = dabs(numer/den)
188 f_distance = 150.d0 + 1850.d0/(1.d0 + dexp(-0.0012*(distance-5000.d0)));
189
191 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
192 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic), f_distance)
193
194
195 elseif (tcase.eq.13) then
196
198 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
199 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
200
201 elseif (tcase.eq.14) then
202
204 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
205 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
206
207 elseif (tcase.eq.15) then
208
210 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
211 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
212
213 elseif (tcase.eq.16) then
214
216 xs(ic), ys(ic), zs(ic),&
217 zs_elev(ic), zs_all(ic), &
218 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
219
220 elseif (tcase.eq.18) then
221
223 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
224 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
225
226 elseif (tcase.eq.19) then
227
229 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
230 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
231
232 elseif (tcase.eq.20) then
233
235 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
236 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
237
238 elseif (tcase.eq.21) then
239
241 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
242 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
243
244 elseif (tcase.eq.22) then
245
246
248 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
249 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
250
251 elseif (tcase.eq.27) then
252
253
255 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
256 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
257
258 elseif (tcase.eq.28) then
259
260
262 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
263 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
264
265 elseif (tcase.eq.29) then
266
268 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
269 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
270
271 elseif (tcase.eq.30) then
272
273
275 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
276 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
277
278 elseif (tcase.eq.31) then
279
280
282 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
283 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
284
285 elseif (tcase.eq.32) then
286
287
289 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
290 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
291
292 elseif (tcase.eq.33) then
293
294
296 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
297 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
298
299 elseif (tcase.eq.35) then
300
302 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
303 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
304
305 elseif (tcase.eq.38) then
306
308 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
309 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
310
311 elseif (tcase.eq.40) then
312
313
315 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
316 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
317
318 elseif (tcase.eq.45) then
319
320
322 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
323 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
324
325
326 elseif (tcase.eq.46) then
327
328
330 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic))
331
332 elseif (tcase.eq.50) then
333
334
336 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
337 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
338
339 elseif (tcase.eq.60) then
340
341
343 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
344 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
345
346 elseif (tcase.eq.70) then
347
348
350 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
351 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
352
353 elseif (tcase .eq. 91) then
354
355
357 xs(ic),ys(ic),zs(ic),zs_elev(ic),zs_all(ic), &
358 vs_nodes(ic), thick_nodes(ic), sub_tag_all(ic))
359
360
361 elseif (tcase.eq.98) then
362
363
364 vs = 100
365 vp = 200
366 rho = 2000
367 lambda = rho * (vp**2 - 2*vs**2)
368 mu = rho * vs**2
369 gamma = 0.0d0
370
371 elseif (tcase.eq.99) then
372
373
374 depth = zs_elev(ic)
375 if ((depth .ge. 0.0d0) .and. (zs_all(ic) .ge. 0.0d0)) then
376 vs = 1000.d0
377 vp = 2081.9942d0
378 rho = 2000.d0
379 lambda = rho * (vp**2 - 2*vs**2)
380 mu = rho * vs**2
381 qp = 200;
382 qs = 100;
383 gamma = 4.d0*datan(1.d0)/qs;
384 else
385 vs = 2000.d0
386 vp = 3463.9976
387 rho = 2500.d0
388 lambda = rho * (vp**2 - 2*vs**2)
389 mu = rho * vs**2
390 qp = 200;
391 qs = 100;
392 gamma = 4.d0*datan(1.d0)/qs;
393 endif
394
395 elseif (tcase.eq.100) then
396
397
398 depth = zs_elev(ic)
399 if ((depth .ge. 0.0d0) .and. (zs_all(ic) .ge. 0.0d0)) then
400 vs = 300.d0
401 vp = 600.d0
402 rho = 1800.d0
403 lambda = rho * (vp**2 - 2*vs**2)
404 mu = rho * vs**2
405 qp = 60;
406 qs = 30;
407 gamma = 4.d0*datan(1.d0)/qs;
408 else
409 vs = 2000.d0
410 vp = 4000.d0
411 rho = 2200.d0
412 lambda = rho * (vp**2 - 2*vs**2)
413 mu = rho * vs**2
414 qp = 400;
415 qs = 200;
416 gamma = 4.d0*datan(1.d0)/qs;
417 endif
418 endif
419
420 if (check_case .eq. 1) &
421 write(1000+mpi_id,*) xs(ic),ys(ic),zs(ic), &
422 dsqrt(mu/rho), &
423 dsqrt((lambda + 2.d0*mu)/rho), &
424 rho, lambda, mu, &
425 qp, qs, gamma, zs_elev(ic), zs_all(ic)
426
427
428 rho_el(p,q,r) = rho
429 lambda_el(p,q,r) = lambda
430 mu_el(p,q,r) = mu
431 gamma_el(p,q,r) = gamma
432 qp_h(p,q,r) = qp
433 qs_h(p,q,r) = qs
434
435 enddo
436 enddo
437 enddo
438
439 if (check_case .eq. 1) close (1000+mpi_id)
440
441 if (damping_type .eq. 2) then
442 qs = 0; qp = 0;
443 qs_all = 0.d0; qp_all=0.d0;
444 do r = 1,nn
445 do q = 1,nn
446 do p = 1,nn
447
448
449 qs_all = qs_all + qs_h(p,q,r)
450 qp_all = qp_all + qp_h(p,q,r)
451 enddo
452 enddo
453 enddo
454
455
456
457 qs = qs_all/nn**3;
458 qp = qp_all/nn**3;
459
460 endif
461
462
463 return
464
subroutine make_mech_prop_case_001(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_002(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_003(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_004(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_005(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_006(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_007(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_008(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_010(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_011(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
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.
subroutine make_mech_prop_case_013(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_014(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_015(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_016(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_018(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_019(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_020(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_021(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_022(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_027(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_028(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_029(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_030(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_031(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_032(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_033(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_035(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_038(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_040(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_045(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_046(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_050(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_060(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_070(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.
subroutine make_mech_prop_case_091(rho, lambda, mu, gamma, qs, qp, xs, ys, zs, depth, zs_all, vs30, thickness, sub_tag_all)
Makes not-honoring technique.