SPEED
Functions/Subroutines
CHECK_SISM.f90 File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine check_sism (cs_nnz, cs, nm, tm, sd, nl_sism, num_ns, max_num_ns, sour_ns, dist_sour_ns, pos_sour_nx, pos_sour_ny, pos_sour_nz, check_ns, check_dist_ns, length_cns, check_pos_ns, fun_sism, nf, tag_func, val_sism, nn_loc, local_n_num, srcmodflag, szsism)
 Fills array check_ns for seismic force.
 

Function/Subroutine Documentation

◆ check_sism()

subroutine check_sism ( integer*4  cs_nnz,
integer*4, dimension(0:cs_nnz)  cs,
integer*4  nm,
integer*4, dimension(nm)  tm,
integer*4, dimension(nm)  sd,
integer*4  nl_sism,
integer*4, dimension(nl_sism)  num_ns,
integer*4  max_num_ns,
integer*4, dimension(max_num_ns,nl_sism)  sour_ns,
real*8, dimension(max_num_ns,nl_sism)  dist_sour_ns,
real*8, dimension(max_num_ns,nl_sism)  pos_sour_nx,
real*8, dimension(max_num_ns,nl_sism)  pos_sour_ny,
  pos_sour_nz,
integer*4, dimension(length_cns,4)  check_ns,
real*8, dimension(length_cns,1)  check_dist_ns,
integer*4  length_cns,
real*8, dimension(length_cns,3)  check_pos_ns,
integer*4, dimension(nl_sism)  fun_sism,
integer*4  nf,
integer*4, dimension(nf)  tag_func,
real*8, dimension(nl_sism,szsism)  val_sism,
integer*4  nn_loc,
integer*4, dimension(nn_loc)  local_n_num,
integer*4  srcmodflag,
integer*4  szsism 
)

Fills array check_ns for seismic force.

Author
Ilario Mazzieri
Date
September, 2013
Version
1.0
Parameters
[in]cs_nnzlength of cs
[in]csspectral connectivity vector
[in]nmnumber of materials
[in]tmlabel for materias
[in]sdpolynomial degree vector
[in]nl_sismnumber of seismic loads
[in]num_nsnumber of seismic nodes
[in]max_num_nsmax number of seismic nodes
[in]sour_nsseismic source
[in]dist_sour_nsdistance of the node from the seismic source
[in]length_cnslength check seismic nodes (useless)
[in]fun_sismfunction associeted with the seismic load
[in]nfnumber of functions
[in]tag_functag for seismic functions
[in]val_sismvalues for the seismic loads
[in]nn_locnumber of local nodes
[in]local_n_numlocal numeration vector
[out]check_nscheck_ns(i,1) seismic source node, check_ns(i,2) seismic function for the node i, check_ns(i,3) i for seismic load, check_ns(i,4) number of the element
[out]check_dist_nscheck_dist_ns(i,1) dist_sour_ns / val_sism

Definition at line 46 of file CHECK_SISM.f90.

57
58
59
60! use speed_par, only: slip_type
61
62 implicit none
63
64 integer*4 :: cs_nnz,nm,ne,nl_sism,nf, nn_loc
65 integer*4 :: max_num_ns
66 integer*4 :: im,ie,isism,nn
67 integer*4 :: is,in,ip
68 integer*4 :: i,j,k,h
69 integer*4 :: fn
70 integer*4 :: length_cns,srcmodflag,szsism,val_st
71
72 integer*4, dimension(0:cs_nnz) :: cs
73 integer*4, dimension(nm) :: tm,sd
74 integer*4, dimension(nl_sism) :: num_ns
75 integer*4, dimension(nl_sism) :: fun_sism
76 integer*4, dimension(nn_loc) :: local_n_num
77 integer*4, dimension(nf) :: tag_func
78
79 integer*4, dimension(max_num_ns,nl_sism) :: sour_ns
80 integer*4, dimension(length_cns,4) :: check_ns
81
82 real*8 :: vel_prop, dist_b, xb, yb, zb, trup_b, dist_p, trup_p
83 real*8 :: dumvr, delay_tr
84
85 real*8, dimension(:), allocatable :: ct,ww
86
87 real*8, dimension(:,:), allocatable :: dd
88 real*8, dimension(max_num_ns,nl_sism) :: dist_sour_ns
89 real*8, dimension(max_num_ns,nl_sism) :: pos_sour_nx, pos_sour_ny, pos_sour_nz
90 real*8, dimension(length_cns,1) :: check_dist_ns
91 real*8, dimension(length_cns,3) :: check_pos_ns
92 real*8, dimension(nl_sism,szsism) :: val_sism
93
94
95
96
97 h = 0
98 nn = 2
99 ne = cs(0) -1
100
101 if (srcmodflag.eq.0) then
102 val_st = 12
103 elseif (srcmodflag.eq.1) then
104 val_st = 6
105 endif
106
107 allocate(ct(nn),ww(nn),dd(nn,nn))
108 call make_lgl_nw(nn,ct,ww,dd)
109
110 do im = 1,nm
111 if ((sd(im) +1).ne.nn) then
112 deallocate(ct,ww,dd)
113 nn = sd(im) +1
114 allocate(ct(nn),ww(nn),dd(nn,nn))
115 call make_lgl_nw(nn,ct,ww,dd)
116 endif
117
118 do ie = 1,ne
119 if (cs(cs(ie -1) +0).eq.tm(im)) then
120 do k = 1,nn
121 do j = 1,nn
122 do i = 1,nn
123 is = nn*nn*(k -1) +nn*(j -1) +i
124 in = cs(cs(ie -1) +is)
125
126 do isism = 1,nl_sism
127 do ip = 1,num_ns(isism)
128
129 if (local_n_num(in) .eq. sour_ns(ip,isism)) then
130 h = h + 1
131 check_ns(h,1) = sour_ns(ip,isism) !source node
132 check_ns(h,2) = fun_sism(isism) !fun type
133 check_ns(h,3) = isism !fault number
134 check_ns(h,4) = ie !local element
135 ! new --- added position of nodes
136 check_pos_ns(h,1) = pos_sour_nx(ip, isism)
137 check_pos_ns(h,2) = pos_sour_ny(ip, isism)
138 check_pos_ns(h,3) = pos_sour_nz(ip, isism)
139
140 !!distance from hypo / rupture velocity = rupture time --> std
141 !!rupture time ---> Archuleta (line 120 ~ rupt. velocity)
142 !!write(*,*) slip_type
143 !!read(*,*)
144 !!if (slip_type .eq. 'STD') then
145 ! !check_dist_ns(h,1) = dist_sour_ns(ip,isism) / val_sism(isism,19)
146 ! !old version val_sism(isism,19) = vrup
147 ! !new_version val_sism(isism,19) = trup
148 check_dist_ns(h,1) = val_sism(isism,val_st+7) ! Trupt for the baricenter of the triangle
149 !!elseif (slip_type .eq. 'ARC') then
150 !! check_dist_ns(h,1) = val_sism(isism,19)
151 !!elseif (slip_type .eq. 'GAL') then
152 !! check_dist_ns(h,1) = val_sism(isism,19)
153 !!endif
154 !! New implementation for trup (node by node)
155 !trup_b : dist_b = trup_p : dist_p --> trup_p = (trup_b * dist_p)/dist_b
156 if (srcmodflag.eq.0) then
157 xb = (val_sism(isism,4) + val_sism(isism,7) + val_sism(isism,10))/3.d0;
158 yb = (val_sism(isism,5) + val_sism(isism,8) + val_sism(isism,11))/3.d0;
159 zb = (val_sism(isism,6) + val_sism(isism,9) + val_sism(isism,12))/3.d0;
160
161 trup_b = val_sism(isism,19)
162 dist_b = dsqrt((val_sism(isism,1)-xb)**2.d0+(val_sism(isism,2)-yb)**2.d0+(val_sism(isism,3)-zb)**2.d0);
163 dist_p = dsqrt((val_sism(isism,1)-check_pos_ns(h,1))**2.d0 &
164 +(val_sism(isism,2)-check_pos_ns(h,2))**2.d0 &
165 +(val_sism(isism,3)-check_pos_ns(h,3))**2.d0);
166
167 trup_p = trup_b*dist_p/dist_b;
168
169 !write(*,*) h, dist_b, trup_b, dist_p, trup_p
170
171 if (dabs(dist_b) .le. 100) then
172 check_dist_ns(h,1) = val_sism(isism,19)
173 else
174 check_dist_ns(h,1) = (val_sism(isism,19) * dist_sour_ns(ip,isism)) / dist_b;
175 endif
176
177 elseif (srcmodflag.eq.1) then
178 xb = val_sism(isism,4)
179 yb = val_sism(isism,5)
180 zb = val_sism(isism,6)
181 dist_b = dsqrt((val_sism(isism,1)-xb)**2.d0+(val_sism(isism,2)-yb)**2.d0+(val_sism(isism,3)-zb)**2.d0)
182 dist_p = dsqrt((val_sism(isism,1)-check_pos_ns(h,1))**2.d0 &
183 +(val_sism(isism,2)-check_pos_ns(h,2))**2.d0 &
184 +(val_sism(isism,3)-check_pos_ns(h,3))**2.d0);
185
186 if (dabs(dist_b) .le. 100) then
187 check_dist_ns(h,1) = val_sism(isism,val_st+7);
188 else
189 ! delay_tr = Rupture time delay for respective segment + time window delay
190 !dumvr = 2500;
191 !delay_tr = val_sism(isism,val_st+7) - (dist_b/dumvr);
192 !check_dist_ns(h,1) = delay_tr + (dist_p/dumvr);
193 check_dist_ns(h,1) = val_sism(isism,val_st+7)*dist_p/dist_b;
194 endif
195 endif
196
197
198
199
200 endif
201
202 enddo !ip
203 enddo !isism
204
205 enddo !i
206 enddo !j
207 enddo !k
208
209
210 endif !if (cs....)
211
212 enddo !ie = 1,ne
213
214 enddo !im = 1,nm
215
216 return
217
make_lgl_nw
subroutine make_lgl_nw(nb_pnt, xq, wq, dd)
Makes Gauss-Legendre-Lobatto nodes, weigths and spectral derivatives.
Definition MAKE_LGL_NW.f90:29

References make_lgl_nw().

Here is the call graph for this function: