Line data Source code
1 : module fvm_consistent_se_cslam
2 : use shr_kind_mod, only: r8=>shr_kind_r8
3 : use dimensions_mod, only: nc, nhe, nlev, ntrac, np, nhr, nhc, ngpc, ns, nht
4 : use dimensions_mod, only: irecons_tracer
5 : use dimensions_mod, only: kmin_jet,kmax_jet
6 : use cam_abortutils, only: endrun
7 : use cam_logfile, only: iulog
8 :
9 : use se_dyn_time_mod, only: timelevel_t
10 : use element_mod, only: element_t
11 : use fvm_control_volume_mod, only: fvm_struct
12 : use hybrid_mod, only: hybrid_t, config_thread_region, get_loop_ranges, threadOwnsVertLevel
13 : use perf_mod, only: t_startf, t_stopf
14 : implicit none
15 : private
16 : save
17 :
18 : real (kind=r8),parameter , private :: eps=1.0e-14_r8
19 : public :: run_consistent_se_cslam
20 : contains
21 : !
22 : !**************************************************************************************
23 : !
24 : ! Consistent CSLAM-SE algorithm documented in
25 : !
26 : ! Lauritzen et al. (2017): CAM-SE-CSLAM: Consistent finite-volume transport with
27 : ! spectral-element dynamics. Mon. Wea. Rev.
28 : !
29 : !
30 : !**************************************************************************************
31 : !
32 44544 : subroutine run_consistent_se_cslam(elem,fvm,hybrid,dt_fvm,tl,nets,nete,hvcoord,&
33 : ghostbufQnhc,ghostBufQ1, ghostBufFlux,kminp,kmaxp)
34 : ! ---------------------------------------------------------------------------------
35 : use fvm_mod , only: fill_halo_fvm
36 : use fvm_reconstruction_mod, only: reconstruction
37 : use fvm_analytic_mod , only: gauss_points
38 : use edge_mod , only: ghostpack, ghostunpack
39 : use edgetype_mod , only: edgebuffer_t
40 : use bndry_mod , only: ghost_exchange
41 : use hybvcoord_mod , only: hvcoord_t
42 : use constituents , only: qmin
43 : use dimensions_mod , only: large_Courant_incr,irecons_tracer_lev
44 : use thread_mod , only: vert_num_threads, omp_set_nested
45 : implicit none
46 : type (element_t) , intent(inout) :: elem(:)
47 : type (fvm_struct), target , intent(inout) :: fvm(:)
48 : type (hybrid_t) , intent(in) :: hybrid ! distributed parallel structure (shared)
49 : type (TimeLevel_t) , intent(in) :: tl ! time level struct
50 : type (hvcoord_t) , intent(in) :: hvcoord
51 : integer , intent(in) :: nets ! starting thread element number (private)
52 : integer , intent(in) :: nete ! ending thread element number (private)
53 : real (kind=r8) , intent(in) :: dt_fvm
54 : type (EdgeBuffer_t) , intent(inout) :: ghostbufQnhc,ghostBufQ1, ghostBufFlux
55 : integer , intent(in) :: kminp,kmaxp
56 :
57 : !high-order air density reconstruction
58 89088 : real (kind=r8) :: ctracer(irecons_tracer,1-nhe:nc+nhe,1-nhe:nc+nhe,ntrac)
59 : real (kind=r8) :: inv_dp_area(nc,nc)
60 : type (hybrid_t) :: hybridnew
61 :
62 : real (kind=r8), dimension(ngpc) :: gsweights, gspts
63 :
64 89088 : logical :: llimiter(ntrac)
65 : integer :: i,j,k,ie,itr,kptr,q
66 : integer :: kmin_jet_local,kmax_jet_local
67 : integer :: kmin,kmax
68 : integer :: ir
69 : integer :: kblk ! total number of vertical levels per thread
70 : integer :: klev ! total number of vertical levels in the JET region
71 : integer :: region_num_threads
72 : logical :: inJetCall
73 : logical :: ActiveJetThread
74 :
75 44544 : real(r8), pointer :: fcube(:,:,:,:)
76 44544 : real(r8), pointer :: spherecentroid(:,:,:)
77 :
78 1870848 : llimiter = .true.
79 :
80 44544 : inJetCall = .false.
81 44544 : if(((kminp .ne. 1) .or. (kmaxp .ne. nlev)) .and. vert_num_threads>1) then
82 0 : write(iulog,*)'WARNING: deactivating vertical threading for JET region call'
83 0 : inJetCall = .true.
84 0 : region_num_threads = 1
85 : else
86 44544 : region_num_threads = vert_num_threads
87 : endif
88 :
89 44544 : call omp_set_nested(.true.)
90 : !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), &
91 : !$OMP PRIVATE(hybridnew,kblk,ie,k,kmin,gspts,inv_dp_area,itr), &
92 : !$OMP PRIVATE(kmin_jet_local,kmax,kmax_jet_local,kptr,q,ctracer,ActiveJetThread)
93 44544 : call gauss_points(ngpc,gsweights,gspts) !set gauss points/weights
94 178176 : gspts = 0.5_r8*(gspts+1.0_r8) !shift location so in [0:1] instead of [-1:1]
95 :
96 44544 : if(inJetCall) then
97 : ! ===============================================================================
98 : ! if this is the reduced Jet region call then do not thread over the vertical....
99 : ! Just use the number of vertical levels that were passed into subroutine
100 : ! ===============================================================================
101 0 : hybridnew = config_thread_region(hybrid,'serial')
102 0 : kmin = kminp
103 0 : kmax = kmaxp
104 : else
105 44544 : hybridnew = config_thread_region(hybrid,'vertical')
106 44544 : call get_loop_ranges(hybridnew,kbeg=kmin,kend=kmax)
107 : endif
108 :
109 44544 : kblk = kmax-kmin+1
110 : !call t_startf('fvm:before_Qnhc')
111 357744 : do ie=nets,nete
112 29440800 : do k=kmin,kmax
113 1543762800 : elem(ie)%sub_elem_mass_flux(:,:,:,k) = dt_fvm*elem(ie)%sub_elem_mass_flux(:,:,:,k)*fvm(ie)%dp_ref_inverse(k)
114 378972000 : fvm(ie)%dp_fvm(1:nc,1:nc,k) = fvm(ie)%dp_fvm (1:nc,1:nc,k)*fvm(ie)%dp_ref_inverse(k)
115 : end do
116 313200 : kptr = kmin-1
117 313200 : call ghostpack(ghostbufQnhc,fvm(ie)%dp_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,kmin:kmax) ,kblk, kptr,ie)
118 13198944 : do q=1,ntrac
119 12841200 : kptr = kptr + nlev
120 13154400 : call ghostpack(ghostbufQnhc,fvm(ie)%c(1-nhc:nc+nhc,1-nhc:nc+nhc,kmin:kmax,q),kblk,kptr,ie)
121 : enddo
122 : end do
123 : !call t_stopf('fvm:before_Qnhc')
124 : !call t_startf('fvm:ghost_exchange:Qnhc')
125 44544 : call ghost_exchange(hybridnew,ghostbufQnhc,location='ghostbufQnhc')
126 : !call t_stopf('fvm:ghost_exchange:Qnhc')
127 : !call t_startf('fvm:orthogonal_swept_areas')
128 357744 : do ie=nets,nete
129 29440800 : do k=kmin,kmax
130 1544076000 : fvm(ie)%se_flux (1:nc,1:nc,:,k) = elem(ie)%sub_elem_mass_flux(:,:,:,k)
131 : end do
132 313200 : kptr = kmin-1
133 313200 : call ghostunpack(ghostbufQnhc, fvm(ie)%dp_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,kmin:kmax) , kblk ,kptr,ie)
134 13154400 : do q=1,ntrac
135 12841200 : kptr = kptr + nlev
136 13154400 : call ghostunpack(ghostbufQnhc, fvm(ie)%c(1-nhc:nc+nhc,1-nhc:nc+nhc,kmin:kmax,q),kblk,kptr,ie)
137 : enddo
138 29440800 : do k=kmin,kmax
139 29440800 : call compute_displacements_for_swept_areas (fvm(ie),fvm(ie)%dp_fvm(:,:,k),k,gsweights,gspts)
140 : end do
141 313200 : kptr = 4*(kmin-1)
142 357744 : call ghostpack(ghostBufFlux, fvm(ie)%se_flux(:,:,:,kmin:kmax),4*kblk,kptr,ie)
143 : end do
144 :
145 44544 : call ghost_exchange(hybridnew,ghostBufFlux,location='ghostBufFlux')
146 :
147 357744 : do ie=nets,nete
148 313200 : kptr = 4*(kmin-1)
149 313200 : call ghostunpack(ghostBufFlux, fvm(ie)%se_flux(:,:,:,kmin:kmax),4*kblk,kptr,ie)
150 29485344 : do k=kmin,kmax
151 29440800 : call ghost_flux_unpack(fvm(ie),fvm(ie)%se_flux(:,:,:,k))
152 : end do
153 : enddo
154 :
155 : !call t_stopf('fvm:orthogonal_swept_areas')
156 357744 : do ie=nets,nete
157 : ! Intel compiler version 2023.0.0 on derecho had significant slowdown on subroutine interface without
158 : ! these pointers.
159 313200 : fcube => fvm(ie)%c(:,:,:,:)
160 313200 : spherecentroid => fvm(ie)%spherecentroid(:,1-nhe:nc+nhe,1-nhe:nc+nhe)
161 29485344 : do k=kmin,kmax
162 : !call t_startf('FVM:tracers_reconstruct')
163 : call reconstruction(fcube,nlev,k,&
164 : ctracer(:,:,:,:),irecons_tracer,llimiter,ntrac,&
165 : nc,nhe,nhr,nhc,nht,ns,nhr+(nhe-1),&
166 29127600 : fvm(ie)%jx_min,fvm(ie)%jx_max,fvm(ie)%jy_min,fvm(ie)%jy_max,&
167 : fvm(ie)%cubeboundary,fvm(ie)%halo_interp_weight,fvm(ie)%ibase,&
168 : spherecentroid,&
169 29127600 : fvm(ie)%recons_metrics,fvm(ie)%recons_metrics_integral,&
170 : fvm(ie)%rot_matrix,fvm(ie)%centroid_stretch,&
171 : fvm(ie)%vertex_recons_weights,fvm(ie)%vtx_cart,&
172 87382800 : irecons_tracer_lev(k))
173 : !call t_stopf('FVM:tracers_reconstruct')
174 : !call t_startf('fvm:swept_flux')
175 29440800 : call swept_flux(elem(ie),fvm(ie),k,ctracer,irecons_tracer_lev(k),gsweights,gspts)
176 : !call t_stopf('fvm:swept_flux')
177 : end do
178 : end do
179 : !
180 : !***************************************
181 : !
182 : ! Large Courant number increment
183 : !
184 : !***************************************
185 : !
186 : ! In the jet region the effective Courant number
187 : ! in the cslam trajectory algorithm can be > 1
188 : ! (by up to 20%) in CAM
189 : !
190 : ! We limit the trajectories to < 1 but in this step
191 : ! we do a piecewise constant update for the
192 : ! amount of mass for which the Courant number is >1
193 : !
194 : !
195 44544 : if (large_Courant_incr) then
196 : !call t_startf('fvm:fill_halo_fvm:large_Courant')
197 : !if (kmin_jet<kmin.or.kmax_jet>kmax) then
198 : ! call endrun('ERROR: kmax_jet must be .le. kmax passed to run_consistent_se_cslam')
199 : !end if
200 : ! Determine the extent of the JET that is owned by this thread
201 44544 : ActiveJetThread = threadOwnsVertLevel(hybridnew,kmin_jet) .or. threadOwnsVertLevel(hybridnew,kmax_jet)
202 44544 : kmin_jet_local = max(kmin_jet,kmin)
203 44544 : kmax_jet_local = min(kmax_jet,kmax)
204 44544 : klev = kmax_jet-kmin_jet+1
205 44544 : call fill_halo_fvm(ghostbufQ1,elem,fvm,hybridnew,nets,nete,1,kmin_jet_local,kmax_jet_local,klev,active=ActiveJetThread)
206 : !call t_stopf('fvm:fill_halo_fvm:large_Courant')
207 : !call t_startf('fvm:large_Courant_number_increment')
208 44544 : if(ActiveJetThread) then
209 4187136 : do k=kmin_jet_local,kmax_jet_local !1,nlev
210 33314736 : do ie=nets,nete
211 33270192 : call large_courant_number_increment(fvm(ie),k)
212 : end do
213 : end do
214 : endif
215 : !call t_stopf('fvm:large_Courant_number_increment')
216 : end if
217 :
218 : !call t_startf('fvm:end_of_reconstruct_subroutine')
219 4187136 : do k=kmin,kmax
220 : !
221 : ! convert to mixing ratio
222 : !
223 33314736 : do ie=nets,nete
224 116510400 : do j=1,nc
225 378658800 : do i=1,nc
226 349531200 : inv_dp_area(i,j) = 1.0_r8/fvm(ie)%dp_fvm(i,j,k)
227 : end do
228 : end do
229 :
230 1223359200 : do itr=1,ntrac
231 4806054000 : do j=1,nc
232 15525010800 : do i=1,nc
233 : ! convert to mixing ratio
234 10748084400 : fvm(ie)%c(i,j,k,itr) = fvm(ie)%c(i,j,k,itr)*inv_dp_area(i,j)
235 : ! remove round-off undershoots
236 14330779200 : fvm(ie)%c(i,j,k,itr) = MAX(fvm(ie)%c(i,j,k,itr),qmin(itr))
237 : end do
238 : end do
239 : end do
240 : !
241 : ! convert to dp and scale back dp
242 : !
243 378658800 : fvm(ie)%dp_fvm(1:nc,1:nc,k) = fvm(ie)%dp_fvm(1:nc,1:nc,k)*fvm(ie)%dp_ref(k)*fvm(ie)%inv_area_sphere
244 : #ifdef waccm_debug
245 : do j=1,nc
246 : do i=1,nc
247 : fvm(ie)%CSLAM_gamma(i,j,k,1) = MAXVAL(fvm(ie)%CSLAM_gamma(i,j,k,:))
248 : end do
249 : end do
250 : #endif
251 1547905392 : elem(ie)%sub_elem_mass_flux(:,:,:,k)=0
252 : end do
253 : end do
254 : !call t_stopf('fvm:end_of_reconstruct_subroutine')
255 : !$OMP END PARALLEL
256 44544 : call omp_set_nested(.false.)
257 89088 : end subroutine run_consistent_se_cslam
258 :
259 29127600 : subroutine swept_flux(elem,fvm,ilev,ctracer,irecons_tracer_actual,gsweights,gspts)
260 44544 : use fvm_analytic_mod , only: get_high_order_weights_over_areas
261 : use dimensions_mod, only : kmin_jet,kmax_jet
262 : implicit none
263 : type (element_t) , intent(in) :: elem
264 : type (fvm_struct), intent(inout):: fvm
265 : integer , intent(in) :: ilev, irecons_tracer_actual
266 : real (kind=r8), intent(inout) :: ctracer(irecons_tracer,1-nhe:nc+nhe,1-nhe:nc+nhe,ntrac)
267 : real (kind=r8), dimension(ngpc), intent(in) :: gsweights, gspts
268 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
269 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides) :: displ
270 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides) :: base_vec
271 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides) :: base_vtx
272 : integer , dimension(2,num_area, imin:imax,imin:imax,num_sides) :: idx
273 : real (kind=r8) , dimension(imin:imax,imin:imax,num_sides) :: mass_flux_se
274 : real (kind=r8) , dimension(irecons_tracer,num_area) :: weights
275 : real (kind=r8) :: gamma
276 : integer :: i,j,iside,iarea,iw
277 :
278 : integer, parameter :: num_seg_max=5
279 : REAL(KIND=r8), dimension(2,num_seg_max,num_area) :: x, dx, x_static, dx_static
280 : integer , dimension(num_area) :: num_seg, num_seg_static
281 : REAL(KIND=r8), dimension(2,8) :: x_start, dgam_vec
282 : REAL(KIND=r8) :: gamma_max, displ_first_guess
283 :
284 58255200 : REAL(KIND=r8) :: flux,flux_tracer(ntrac)
285 :
286 : REAL(KIND=r8), dimension(num_area) :: dp_area
287 :
288 : real (kind=r8) :: dp(1-nhc:nc+nhc,1-nhc:nc+nhc)
289 :
290 : logical :: tl1,tl2,tr1,tr2
291 :
292 : integer, dimension(4), parameter :: imin_side = (/1 ,0 ,1 ,1 /)
293 : integer, dimension(4), parameter :: imax_side = (/nc ,nc ,nc ,nc+1/)
294 : integer, dimension(4), parameter :: jmin_side = (/1 ,1 ,0 ,1 /)
295 : integer, dimension(4), parameter :: jmax_side = (/nc+1,nc ,nc ,nc /)
296 :
297 : integer :: iseg, iseg_tmp,flowcase,ii,jj,itr
298 :
299 29127600 : call define_swept_areas(fvm,ilev,displ,base_vec,base_vtx,idx)
300 :
301 1543762800 : mass_flux_se(1:nc,1:nc,1:4) = -elem%sub_elem_mass_flux(1:nc,1:nc,1:4,ilev)
302 116510400 : mass_flux_se(0 ,1:nc,2 ) = elem%sub_elem_mass_flux(1 ,1:nc,4 ,ilev)
303 116510400 : mass_flux_se(nc+1,1:nc,4 ) = elem%sub_elem_mass_flux(nc ,1:nc,2 ,ilev)
304 116510400 : mass_flux_se(1:nc,0 ,3 ) = elem%sub_elem_mass_flux(1:nc,1 ,1 ,ilev)
305 116510400 : mass_flux_se(1:nc,nc+1,1 ) = elem%sub_elem_mass_flux(1:nc,nc ,3 ,ilev)
306 : !
307 : ! prepare for air/tracer update
308 : !
309 : ! dp = fvm%dp_fvm(1-nhe:nc+nhe,1-nhe:nc+nhe,ilev)
310 2650611600 : dp = fvm%dp_fvm(1-nhc:nc+nhc,1-nhc:nc+nhc,ilev)
311 378658800 : fvm%dp_fvm(1:nc,1:nc,ilev) = fvm%dp_fvm(1:nc,1:nc,ilev)*fvm%area_sphere
312 1223359200 : do itr=1,ntrac
313 15525010800 : fvm%c(1:nc,1:nc,ilev,itr) = fvm%c(1:nc,1:nc,ilev,itr)*fvm%dp_fvm(1:nc,1:nc,ilev)
314 8388748800 : do iw=1,irecons_tracer_actual
315 7165389600 : ctracer(iw,1-nhe:nc+nhe,1-nhe:nc+nhe,itr)=ctracer(iw,1-nhe:nc+nhe,1-nhe:nc+nhe,itr)*&
316 >23048*10^7 : dp(1-nhe:nc+nhe,1-nhe:nc+nhe)
317 : end do
318 : end do
319 :
320 145638000 : do iside=1,4
321 553424400 : do j=jmin_side(iside),jmax_side(iside)
322 1922421600 : do i=imin_side(iside),imax_side(iside)
323 : !DO NOT USE MASS_FLUX_SE AS THRESHOLD - THRESHOLD CONDITION MUST BE CONSISTENT WITH
324 : !THE ONE USED IN DEFINE_SWEPT_AREAS
325 : ! if (mass_flux_se(i,j,iside)>eps) then
326 1805911200 : if (fvm%se_flux(i,j,iside,ilev)>eps) then
327 : !
328 : ! || ||
329 : ! tl1 || || tr1
330 : ! || ||
331 : ! =============================
332 : ! || ||
333 : ! tl2 || || tr2
334 : ! || ||
335 : !
336 699062398 : tl1 = displ(3,i,j,iside)<0.0_r8.and.displ(6,i,j,iside).ge.0.0_r8 !departure point in tl1 quadrant
337 699062398 : tl2 = displ(6,i,j,iside)<0.0_r8.and.displ(7,i,j,iside) >0.0_r8 !departure point in tl2 quadrant
338 699062398 : tr1 = displ(2,i,j,iside)<0.0_r8.and.displ(4,i,j,iside).ge.0.0_r8 !departure point in tr1 quadrant
339 699062398 : tr2 = displ(4,i,j,iside)<0.0_r8.and.displ(5,i,j,iside) >0.0_r8 !departure point in tr2 quadrant
340 :
341 : !
342 : ! pathological cases
343 : !
344 : ! | || || || ||
345 : ! | ||-----------|| ||-----------||
346 : ! | || || || ||
347 : ! ================================ =================================
348 : ! || || | || ||
349 : ! ---------|| || ------|--|| ||
350 : ! || || | || ||
351 : !
352 : ! tl1=tl1.or.tl2
353 : ! tr1=tr1.or.tr2
354 : ! tl1=displ(3,i,j,iside)<0.0_r8.and..not.(tl1.and.tl2)
355 : ! tr1=displ(2,i,j,iside)<0.0_r8.and..not.(tr1.and.tr2)
356 :
357 8388748776 : num_seg=-1; num_seg_static=-1 !initialization
358 699062398 : if (.not.tl1.and..not.tl2.and..not.tr1.and..not.tr2) then
359 13186928 : flowcase=0
360 : !
361 : ! || || || || || ||
362 : ! || * * || || *----------* |*----------* ||
363 : ! || / \ || || / || || \ ||
364 : ! ||/ \|| ||/ || || \||
365 : ! ============================= ============================= =============================
366 : ! || || || || || ||
367 : !
368 : !
369 : call define_area3_center (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
370 13186928 : num_seg_static,x_start, dgam_vec,fvm%se_flux(i,j,iside,ilev),displ_first_guess)
371 :
372 13186928 : gamma=1.0_r8!fvm%se_flux(i,j,iside,ilev)
373 13186928 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
374 : else
375 685875470 : if (tl1.and.tr1) then
376 10844147 : flowcase=1
377 : !
378 : !
379 : ! tl1 || || tr1 || || || ||
380 : ! *--||-------------||--* *--||-------------|| ||-------------||--*
381 : ! \ || || / \ || ||\ /|| || /
382 : ! \|| ||/ \|| || \ / || ||/
383 : ! ============================= =========================*=== ==*==========================
384 : ! || || || || || ||
385 : !
386 : call define_area2 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static,&
387 10844147 : num_seg, num_seg_static,x_start, dgam_vec,displ_first_guess)
388 : call define_area3_left_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static,&
389 10844147 : num_seg, num_seg_static,x_start, dgam_vec)
390 : call define_area4 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static,&
391 10844147 : num_seg, num_seg_static,x_start, dgam_vec)
392 10844147 : gamma=1.0_r8
393 10844147 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
394 675031323 : else if (tl1.and..not.tr1.and..not.tr2) then
395 323731730 : flowcase=2
396 : !
397 : ! || || || || || ||
398 : ! *--||----------* || /||----------* || *--||-------------*
399 : ! \ || \ || / || \ || \ || ||
400 : ! \|| \|| / || \|| \|| ||
401 : ! ============================= ==*========================== =============================
402 : ! || || || || || ||
403 : !
404 : call define_area2 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, num_seg_static,&
405 323731730 : x_start, dgam_vec,displ_first_guess)
406 : call define_area3_left(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, num_seg_static,&
407 323731730 : x_start, dgam_vec)
408 323731730 : gamma=1.0_r8
409 323731730 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
410 351299593 : else if (tr1.and..not.tl1.and..not.tl2) then !displ(3).ge.0.0_r8) then
411 323632724 : flowcase=3
412 : !
413 : ! || *----------||--* || *----------||\ *-------------||--*
414 : ! || / || / || / || \ || || /
415 : ! ||/ ||/ ||/ || \ || ||/
416 : ! ============================= ==========================*== =============================
417 : ! || || || || || ||
418 : ! || || || || || ||
419 : ! || || || || || ||
420 : !
421 : call define_area3_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
422 323632724 : num_seg_static, x_start, dgam_vec)
423 : call define_area4 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
424 323632724 : num_seg_static, x_start, dgam_vec,displ_first_guess)
425 323632724 : gamma=1.0_r8
426 323632724 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
427 27666869 : else if (tl2.and..not.tr1.and..not.tr2) then !displ(2).ge.0.0_r8) then
428 13457516 : flowcase=4
429 : !
430 : ! ||----------* || ||-------------*
431 : ! /|| \ || /|| ||
432 : ! / || \|| / || ||
433 : ! ===/========================= ===/=========================
434 : ! | /|| || | /|| ||
435 : ! |/ || || |/ || ||
436 : ! * || || * || ||
437 : !
438 : call define_area1_area2(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
439 13457516 : num_seg_static,x_start, dgam_vec)
440 : call define_area3_left (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
441 : num_seg_static,&
442 13457516 : x_start, dgam_vec,displ_first_guess)
443 13457516 : gamma = 1.0_r8
444 13457516 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
445 14209353 : else if (tr2.and..not.tl1.and..not.tl2) then !displ(3).ge.0.0_r8) then
446 13454822 : flowcase=5
447 : ! case(5)
448 : !
449 : !
450 : ! || *-----2----||
451 : ! || /1 3||\
452 : ! ||/ 4 || \
453 : ! =============================
454 : ! || ||\ |
455 : ! || || \|
456 : ! || || *
457 : !
458 : call define_area3_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
459 13454822 : num_seg_static,x_start, dgam_vec)
460 : call define_area4_area5(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
461 13454822 : num_seg_static,x_start, dgam_vec,displ_first_guess)
462 13454822 : gamma=1.0_r8
463 13454822 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
464 754531 : else if (tl2.and.tr1.and..not.tr2) then
465 365804 : flowcase=6
466 : ! case(6)
467 : !
468 : !
469 : ! ||-------------||--*
470 : ! /|| || /
471 : ! / || ||/
472 : ! ===/=========================
473 : ! | /|| ||
474 : ! |/ || ||
475 : ! * || ||
476 : !
477 : !
478 : call define_area1_area2 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
479 365804 : num_seg_static,x_start, dgam_vec)
480 : call define_area3_left_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
481 365804 : num_seg_static,x_start, dgam_vec)
482 : call define_area4 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
483 365804 : num_seg_static,x_start, dgam_vec,displ_first_guess)
484 :
485 365804 : gamma=1.0_r8
486 365804 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
487 388727 : else if (tr2.and.tl1.and..not.tl2) then
488 379534 : flowcase=7
489 : ! case(7)
490 : !
491 : !
492 : ! *--||-------------||
493 : ! \ || ||\
494 : ! \|| || \
495 : ! =============================
496 : ! || ||\ |
497 : ! || || \|
498 : ! || || *
499 : !
500 : !
501 : call define_area2 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
502 379534 : num_seg_static,x_start, dgam_vec,displ_first_guess)
503 : call define_area3_left_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
504 379534 : num_seg_static,x_start, dgam_vec)
505 : call define_area4_area5 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
506 379534 : num_seg_static,x_start, dgam_vec)
507 379534 : gamma = 1.0_r8
508 379534 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
509 9193 : else if (tl2.and.tr2) then
510 9193 : flowcase=8
511 : ! case(8)
512 : !
513 : !
514 : ! ||-------------||
515 : ! /|| ||\
516 : ! / || || \
517 : ! =============================
518 : ! | /|| ||\ |
519 : ! |/ || || \|
520 : ! * || || *
521 : !
522 : !
523 : !
524 : !
525 : !
526 : call define_area1_area2 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
527 9193 : num_seg_static,x_start, dgam_vec)
528 : call define_area3_left_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
529 9193 : num_seg_static,x_start, dgam_vec)
530 : call define_area4_area5 (i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg,&
531 9193 : num_seg_static,x_start, dgam_vec,displ_first_guess)
532 9193 : gamma = 1.0_r8
533 9193 : gamma_max = fvm%displ_max(i,j,iside)/displ_first_guess
534 : else
535 0 : call endrun('ERROR - unknown flow case')
536 : end if
537 : end if
538 : !
539 : ! iterate to get flux area
540 : !
541 : !call t_startf('fvm:swept_area:get_gamma')
542 4194374388 : do iarea=1,num_area
543 4194374388 : dp_area(iarea) = dp(idx(1,iarea,i,j,iside),idx(2,iarea,i,j,iside))
544 : end do
545 : call get_flux_segments_area_iterate(x,x_static,dx_static,dx,x_start,dgam_vec,num_seg,num_seg_static,&
546 2097187194 : num_seg_max,num_area,dp_area,flowcase,gamma,mass_flux_se(i,j,iside),0.0_r8,gamma_max, &
547 2097187194 : gsweights,gspts,ilev)
548 : !call t_stopf('fvm:swept_area:get_gamma')
549 : !
550 : ! pack segments for high-order weights computation
551 : !
552 4194374388 : do iarea=1,num_area
553 5592499184 : do iseg=1,num_seg_static(iarea)
554 2097187194 : iseg_tmp=num_seg(iarea)+iseg
555 6291561582 : x (:,iseg_tmp,iarea) = x_static (:,iseg,iarea)
556 9786873572 : dx(:,iseg_tmp,iarea) = dx_static(:,iseg,iarea)
557 : end do
558 4194374388 : num_seg(iarea)=num_seg(iarea)+MAX(0,num_seg_static(iarea))
559 : end do
560 : !
561 : ! compute higher-order weights
562 : !
563 : !call t_startf('fvm:swept_area:get_high_order_w')
564 : call get_high_order_weights_over_areas(x,dx,num_seg,num_seg_max,num_area,weights,ngpc,&
565 699062398 : gsweights, gspts,irecons_tracer)
566 : !call t_stopf('fvm:swept_area:get_high_order_w')
567 : !
568 : !**************************************************
569 : !
570 : ! remap air and tracers
571 : !
572 : !**************************************************
573 : !
574 : !call t_startf('fvm:swept_area:remap')
575 29360620716 : flux=0.0_r8; flux_tracer=0.0_r8
576 4194374388 : do iarea=1,num_area
577 4194374388 : if (num_seg(iarea)>0) then
578 1424212608 : ii=idx(1,iarea,i,j,iside); jj=idx(2,iarea,i,j,iside)
579 1424212608 : flux=flux+weights(1,iarea)*dp(ii,jj)
580 59816929536 : do itr=1,ntrac
581 >41017*10^7 : do iw=1,irecons_tracer_actual
582 >40874*10^7 : flux_tracer(itr) = flux_tracer(itr)+weights(iw,iarea)*ctracer(iw,ii,jj,itr)
583 : end do
584 : end do
585 : end if
586 : end do
587 699062398 : fvm%se_flux(i,j,iside,ilev) = mass_flux_se(i,j,iside)-flux
588 699062398 : if (fvm%se_flux(i,j,iside,ilev)>1.0E-13_r8.and.(ilev<kmin_jet.or.ilev>kmax_jet)) then
589 0 : write(iulog,*) "CN excess flux outside of pre-scribed jet region"
590 0 : write(iulog,*) "Increase jet region with kmin_jet and kmax_jet ",&
591 0 : ilev,fvm%se_flux(i,j,iside,ilev),mass_flux_se(i,j,iside),flux,flowcase,&
592 0 : kmin_jet,kmax_jet
593 0 : call endrun('ERROR in CSLAM: local Courant number is > 1; Increase kmin_jet/kmax_jet?')
594 : end if
595 :
596 699062398 : fvm%dp_fvm(i ,j ,ilev ) = fvm%dp_fvm(i ,j ,ilev )-flux
597 29360620716 : fvm% c(i ,j ,ilev,1:ntrac) = fvm% c(i ,j ,ilev,1:ntrac)-flux_tracer(1:ntrac)
598 : !
599 : ! update flux in nearest neighbor cells
600 : !
601 699062398 : if (iside==1) then
602 175795778 : fvm%dp_fvm(i,j-1,ilev ) = fvm%dp_fvm(i,j-1,ilev )+flux
603 7383422676 : fvm% c(i,j-1,ilev,1:ntrac) = fvm% c(i,j-1,ilev,1:ntrac)+flux_tracer(1:ntrac)
604 : end if
605 699062398 : if (iside==2) then
606 166778984 : fvm%dp_fvm(i+1,j,ilev ) = fvm%dp_fvm(i+1,j,ilev )+flux
607 7004717328 : fvm% c(i+1,j,ilev,1:ntrac) = fvm% c(i+1,j,ilev,1:ntrac)+flux_tracer(1:ntrac)
608 : end if
609 699062398 : if (iside==3) then
610 173735422 : fvm%dp_fvm(i,j+1,ilev ) = fvm%dp_fvm(i,j+1,ilev )+flux
611 7296887724 : fvm% c(i,j+1,ilev,1:ntrac) = fvm% c(i,j+1,ilev,1:ntrac)+flux_tracer(1:ntrac)
612 : end if
613 699062398 : if (iside==4) then
614 182752214 : fvm%dp_fvm(i-1,j,ilev ) = fvm%dp_fvm(i-1,j,ilev )+flux
615 7675592988 : fvm% c(i-1,j,ilev,1:ntrac) = fvm% c(i-1,j,ilev,1:ntrac)+flux_tracer(1:ntrac)
616 : end if
617 : !call t_stopf('fvm:swept_area:remap')
618 : end if
619 : end do
620 : end do
621 : end do
622 29127600 : end subroutine swept_flux
623 :
624 :
625 29127600 : subroutine large_courant_number_increment(fvm,ilev)
626 : implicit none
627 : type (fvm_struct), intent(inout):: fvm
628 : integer , intent(in) :: ilev
629 :
630 : integer, parameter :: num_sides=4, imin= 0, imax=nc+1
631 :
632 : integer, dimension(4), parameter :: imin_side = (/1 ,0 ,1 ,1 /)
633 : integer, dimension(4), parameter :: imax_side = (/nc ,nc ,nc ,nc+1/)
634 : integer, dimension(4), parameter :: jmin_side = (/1 ,1 ,0 ,1 /)
635 : integer, dimension(4), parameter :: jmax_side = (/nc+1,nc ,nc ,nc /)
636 :
637 : integer :: i,j,iside,itr
638 58255200 : real (kind=r8) :: flux,flux_tracer(ntrac)
639 : real (kind=r8), dimension(0:nc+1,0:nc+1) :: inv_dp_area
640 58255200 : real (kind=r8), dimension(0:nc+1,0:nc+1,ntrac):: c_tmp
641 :
642 902955600 : inv_dp_area=1.0_r8/fvm%dp_fvm(0:nc+1,0:nc+1,ilev)
643 37050307200 : c_tmp = fvm%c(0:nc+1,0:nc+1,ilev,1:ntrac)
644 145638000 : do iside=1,4
645 553424400 : do j=jmin_side(iside),jmax_side(iside)
646 1922421600 : do i=imin_side(iside),imax_side(iside)
647 1805911200 : if (fvm%se_flux(i,j,iside,ilev)>eps) then
648 : flux = fvm%se_flux(i,j,iside,ilev)
649 : #ifdef waccm_debug
650 : if (i>0.and.j>0.and.i<nc+1.and.j<nc+1) then
651 : fvm%CSLAM_gamma(i,j,ilev,iside) = fvm%CSLAM_gamma(i,j,ilev,iside)+&
652 : fvm%se_flux(i,j,iside,ilev)*inv_dp_area(i,j)
653 : end if
654 : #endif
655 :
656 3950646 : do itr=1,ntrac
657 3950646 : flux_tracer(itr) = fvm%se_flux(i,j,iside,ilev)*c_tmp(i,j,itr)*inv_dp_area(i,j)
658 : end do
659 94063 : fvm%dp_fvm(i ,j ,ilev ) = fvm%dp_fvm(i ,j ,ilev )-flux
660 3950646 : fvm% c(i ,j ,ilev,1:ntrac) = fvm% c(i ,j ,ilev,1:ntrac)-flux_tracer(1:ntrac)
661 : !
662 : ! update flux in nearest neighbor cells
663 : !
664 94063 : if (iside==1) then
665 9418 : fvm%dp_fvm(i,j-1,ilev ) = fvm%dp_fvm(i,j-1,ilev )+flux
666 395556 : fvm% c(i,j-1,ilev,1:ntrac) = fvm% c(i,j-1,ilev,1:ntrac)+flux_tracer(1:ntrac)
667 : end if
668 94063 : if (iside==2) then
669 56851 : fvm%dp_fvm(i+1,j,ilev ) = fvm%dp_fvm(i+1,j,ilev )+flux
670 2387742 : fvm% c(i+1,j,ilev,1:ntrac) = fvm% c(i+1,j,ilev,1:ntrac)+flux_tracer(1:ntrac)
671 : end if
672 94063 : if (iside==3) then
673 11572 : fvm%dp_fvm(i,j+1,ilev ) = fvm%dp_fvm(i,j+1,ilev )+flux
674 486024 : fvm% c(i,j+1,ilev,1:ntrac) = fvm% c(i,j+1,ilev,1:ntrac)+flux_tracer(1:ntrac)
675 : end if
676 94063 : if (iside==4) then
677 16222 : fvm%dp_fvm(i-1,j,ilev ) = fvm%dp_fvm(i-1,j,ilev )+flux
678 681324 : fvm% c(i-1,j,ilev,1:ntrac) = fvm% c(i-1,j,ilev,1:ntrac)+flux_tracer(1:ntrac)
679 : end if
680 : end if
681 : end do
682 : end do
683 : end do
684 29127600 : end subroutine large_courant_number_increment
685 :
686 29127600 : subroutine ghost_flux_unpack(fvm,var)
687 : use control_mod, only : neast, nwest, seast, swest
688 : implicit none
689 : type (fvm_struct), intent(inout) :: fvm
690 : real(kind=r8) :: var(1-nhe:nc+nhe,1-nhe:nc+nhe,4)
691 :
692 : integer :: i,j,ishft
693 : !
694 : ! rotate coordinates if needed
695 : !
696 29127600 : if (fvm%cubeboundary.NE.0) then
697 22525344 : do j=1-nhe,nc+nhe
698 116380944 : do i=1-nhe,nc+nhe
699 93855600 : ishft = NINT(fvm%flux_orient(2,i,j))
700 488049120 : var(i,j,1:4) = cshift(var(i,j,1:4),shift=ishft)
701 : end do
702 : end do
703 : !
704 : ! non-existent cells in physical space - necessary?
705 : !
706 3754224 : if (fvm%cubeboundary==nwest) then
707 420732 : var(1-nhe:0,nc+1 :nc+nhe,:) = 0.0_r8
708 3721860 : else if (fvm%cubeboundary==swest) then
709 420732 : var(1-nhe:0,1-nhe:0 ,:) = 0.0_r8
710 3689496 : else if (fvm%cubeboundary==neast) then
711 420732 : var(nc+1 :nc+nhe,nc+1 :nc+nhe,:) = 0.0_r8
712 3657132 : else if (fvm%cubeboundary==seast) then
713 420732 : var(nc+1 :nc+nhe,1-nhe:0,:) = 0.0_r8
714 : end if
715 : end if
716 29127600 : end subroutine ghost_flux_unpack
717 :
718 29127600 : subroutine compute_displacements_for_swept_areas(fvm,cair,k,gsweights,gspts)
719 : use dimensions_mod, only: large_Courant_incr
720 : implicit none
721 : type (fvm_struct), intent(inout) :: fvm
722 : integer, intent(in) :: k
723 : real (kind=r8) :: cair(1-nhc:nc+nhc,1-nhc:nc+nhc) !high-order air density reconstruction
724 : real (kind=r8), dimension(ngpc), intent(in) :: gsweights, gspts
725 : !
726 : ! flux iside 1 flux iside 3 flux iside 2 flux iside 4
727 : !
728 : ! | | | ---1--> | | --2-->| |--1--> |
729 : ! -4----------3- /\ -4----------3- -4----------3- -4----------3- ||
730 : ! | | /||\ |\\\\\\\\\\| || | |\\\\\\| |\\\\\\| |
731 : ! | --2--> | || dv(1) |\\\\\\\\\\| || | |\\\\\\| |\\\\\\| |
732 : ! |----------| || |----------| || dv(3) | |\\\\\\| |\\\\\\| |
733 : ! |\\\\\\\\\\| || | <--2--- | \||/ | |\\\\\\| |\\\\\\| |
734 : ! |\\\\\\\\\\| || | | \/ | |\\\\\\| |\\\\\\| |
735 : ! -1----------2- -1----------2- -1----------2- -1----------2-
736 : ! | <--1-- | | | | <--1--| |<--2--
737 : !
738 : ! / \
739 : ! line-integral <========== =========>
740 : ! from vertex 2 \ dv(2) dv(4)/
741 : ! to 1
742 : !
743 : ! Note vertical
744 : ! lines have
745 : ! zero line-
746 : ! integral!
747 : !
748 : integer :: i,j,iside,ix
749 : integer, parameter :: num_area=1, num_seg_max=2
750 : REAL(KIND=r8), dimension(2,num_seg_max,num_area,4,nc,nc) :: x_static, dx_static
751 : REAL(KIND=r8), dimension(2,num_seg_max,num_area,4,nc,nc) :: x, dx
752 : REAL(KIND=r8), dimension(2,num_seg_max,num_area) :: x_tmp, dx_tmp
753 : integer , dimension( num_area,4 ) :: num_seg, num_seg_static
754 : REAL(KIND=r8), dimension(2,8, 4,nc,nc) :: x_start, dgam_vec
755 : REAL(KIND=r8), dimension(num_area) :: dp_area
756 : integer, dimension(4) :: flowcase
757 : REAL(KIND=r8) :: gamma(4), flux_se
758 :
759 29127600 : num_seg_static(1,1) = 1; num_seg(1,1) = 1; flowcase(1) = -1
760 29127600 : num_seg_static(1,2) = 0; num_seg(1,2) = 2; flowcase(2) = -2
761 29127600 : num_seg_static(1,3) = 1; num_seg(1,3) = 1; flowcase(3) = -1
762 29127600 : num_seg_static(1,4) = 0; num_seg(1,4) = 2; flowcase(4) = -4
763 :
764 116510400 : do j=1,nc
765 378658800 : do i=1,nc
766 873828000 : do ix=1,2
767 524296800 : iside=1;
768 524296800 : x_static (ix,1,1,iside,i,j) = fvm%vtx_cart(2,ix,i,j)
769 524296800 : dx_static(ix,1,1,iside,i,j) = fvm%vtx_cart(1,ix,i,j)-fvm%vtx_cart(2,ix,i,j)
770 524296800 : x_start (ix,1, iside,i,j) = fvm%vtx_cart(1,ix,i,j)
771 524296800 : x_start (ix,2, iside,i,j) = fvm%vtx_cart(2,ix,i,j)
772 524296800 : dgam_vec (ix,1, iside,i,j) = fvm%vtx_cart(4,ix,i,j)-fvm%vtx_cart(1,ix,i,j)
773 : !
774 : ! compute first guess
775 : !
776 524296800 : gamma(iside) = 0.5_r8
777 524296800 : x (ix,1,1,iside,i,j) = x_start(ix,1,iside,i,j)+gamma(iside)*dgam_vec(ix,1,iside,i,j)
778 524296800 : dx (ix,1,1,iside,i,j) = -dx_static(ix,1,1,iside,i,j)
779 : !
780 : ! side 2
781 : !
782 524296800 : iside=2;
783 524296800 : x_start (ix,1, iside,i,j) = fvm%vtx_cart(2,ix,i,j)
784 524296800 : x_start (ix,2, iside,i,j) = fvm%vtx_cart(3,ix,i,j)
785 524296800 : dgam_vec (ix,1, iside,i,j) = fvm%vtx_cart(1,ix,i,j)-fvm%vtx_cart(2,ix,i,j)
786 524296800 : x (ix,1,1,iside,i,j) = x_start(ix,1,iside,i,j)
787 : !
788 : ! compute first guess - gamma=1
789 : !
790 524296800 : gamma(iside) = 0.5_r8
791 524296800 : dx (ix,1,1,iside,i,j) = gamma(iside)*dgam_vec (ix,1, iside,i,j)
792 524296800 : x (ix,2,1,iside,i,j) = x_start(ix,2,iside,i,j)+gamma(iside)*dgam_vec(ix,1,iside,i,j)
793 524296800 : dx (ix,2,1,iside,i,j) = -gamma(iside)*dgam_vec (ix,1, iside,i,j)
794 : !
795 : ! side 3
796 : !
797 524296800 : iside=3;
798 524296800 : x_static (ix,1,1,iside,i,j) = fvm%vtx_cart(4,ix,i,j)
799 524296800 : dx_static(ix,1,1,iside,i,j) = fvm%vtx_cart(3,ix,i,j)-fvm%vtx_cart(4,ix,i,j)
800 524296800 : x_start (ix,1, iside,i,j) = fvm%vtx_cart(3,ix,i,j)
801 524296800 : x_start (ix,2, iside,i,j) = fvm%vtx_cart(4,ix,i,j)
802 524296800 : dgam_vec (ix,1, iside,i,j) = fvm%vtx_cart(2,ix,i,j)-fvm%vtx_cart(3,ix,i,j)
803 : !
804 : ! compute first guess - gamma(iside)=1
805 : !
806 524296800 : gamma(iside) = 0.5_r8
807 524296800 : x (ix,1,1,iside,i,j) = x_start(ix,1,iside,i,j)+gamma(iside)*dgam_vec(ix,1,iside,i,j)
808 524296800 : dx (ix,1,1,iside,i,j) = -dx_static(ix,1,1,iside,i,j)
809 : !
810 : ! side 4
811 : !
812 524296800 : iside=4;
813 524296800 : x_start (ix,1, iside,i,j) = fvm%vtx_cart(1,ix,i,j)
814 524296800 : x_start (ix,2, iside,i,j) = fvm%vtx_cart(4,ix,i,j)
815 524296800 : dgam_vec (ix,1, iside,i,j) = fvm%vtx_cart(2,ix,i,j)-fvm%vtx_cart(1,ix,i,j)
816 524296800 : x (ix,2,1,iside,i,j) = x_start(ix,2,iside,i,j)
817 : !
818 : ! compute first guess - gamma(iside)=1
819 : !
820 524296800 : gamma(iside) = 0.5_r8
821 524296800 : dx (ix,2,1,iside,i,j) = gamma(iside)*dgam_vec (ix,1, iside,i,j)
822 524296800 : x (ix,1,1,iside,i,j) = x_start(ix,1,iside,i,j)+gamma(iside)*dgam_vec(ix,1,iside,i,j)
823 786445200 : dx (ix,1,1,iside,i,j) = -gamma(iside)*dgam_vec (ix,1, iside,i,j)
824 : end do
825 : end do
826 : end do
827 :
828 : ! do k=1,nlev
829 116510400 : do j=1,nc
830 378658800 : do i=1,nc
831 524296800 : dp_area = cair(i,j)
832 1398124800 : do iside=1,4
833 1048593600 : flux_se = -fvm%se_flux(i,j,iside,k)
834 1310742000 : if (flux_se>eps) then
835 524296799 : gamma(iside)=0.5_r8
836 : !
837 : ! this copying is necessary since get_flux_segments_area_iterate change x and dx
838 : !
839 3408261280 : x_tmp (:,1:num_seg(1,iside),:)=x (:,1:num_seg(1,iside),:,iside,i,j)
840 3408261280 : dx_tmp(:,1:num_seg(1,iside),:)=dx(:,1:num_seg(1,iside),:,iside,i,j)
841 : call get_flux_segments_area_iterate(&
842 : x_tmp(:,:,:),x_static(:,:,:,iside,i,j),dx_static(:,:,:,iside,i,j),dx_tmp(:,:,:),&
843 : x_start(:,:,iside,i,j),dgam_vec(:,:,iside,i,j),num_seg(:,iside),num_seg_static(:,iside),&
844 : num_seg_max,num_area,dp_area,flowcase(iside),gamma(iside),flux_se,0.0_r8,1.0_r8, &
845 524296799 : gsweights,gspts,k)
846 1572890397 : fvm%se_flux(i,j,iside,k) = ABS(SUM(gamma(iside)*dgam_vec(:,1,iside,i,j)))
847 : #ifdef waccm_debug
848 : fvm%CSLAM_gamma(i,j,k,iside) = gamma(iside)
849 : #endif
850 524296799 : if (gamma(iside)>1_r8) then
851 0 : if (.not.large_Courant_incr) then
852 0 : write(iulog,*) 'ERROR in CSLAM: local Courant number is >1: gamma=',gamma(iside),' k=',k
853 0 : call endrun('ERROR in CSLAM: local Courant number is > 1; set namelist se_large_Courant_incr=.true. ')
854 : endif
855 0 : gamma(iside)=1.0_r8-eps
856 : end if
857 : else
858 524296801 : fvm%se_flux(i,j,iside,k) = 0.0_r8
859 : #ifdef waccm_debug
860 : fvm%CSLAM_gamma(i,j,k,iside) = 0.0_r8
861 : #endif
862 : end if
863 : enddo
864 : end do
865 : end do
866 : ! end do
867 29127600 : end subroutine compute_displacements_for_swept_areas
868 :
869 :
870 :
871 1223359197 : subroutine get_flux_segments_area_iterate(x,x_static,dx_static,dx,x_start,dgam_vec,num_seg,num_seg_static,&
872 1223359197 : num_seg_max,num_area,c,flow_case,gamma,flux,gamma_min,gamma_max,gsweights,gspts,ilev)
873 : implicit none
874 : integer , intent(in) :: num_area, num_seg_max
875 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(in) :: x_static, dx_static
876 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx
877 : integer , dimension(num_area ), intent(in) :: num_seg, num_seg_static
878 : REAL(KIND=r8), dimension(2,8) , intent(in) :: x_start, dgam_vec
879 : REAL(KIND=r8) , intent(inout) :: gamma
880 : REAL(KIND=r8) , intent(in) :: flux,gamma_min,gamma_max
881 : integer , intent(in) :: flow_case,ilev
882 :
883 : real (kind=r8), dimension(num_area) , intent(in) :: c
884 : real (kind=r8), dimension(ngpc) , intent(in) :: gsweights, gspts
885 :
886 : real (kind=r8) :: flux_static
887 2446718394 : real (kind=r8) :: weight_area(num_area), xtmp(2), xtmp2(2)
888 : real (kind=r8) :: gamma1, gamma2, gamma3, dgamma, f1, f2
889 :
890 : real (kind=r8), dimension( ngpc ) :: xq,yq
891 : real (kind=r8), dimension( ngpc,1) :: F !linear
892 :
893 1223359197 : real (kind=r8) :: xq2,xq2i, rho, rhoi, yrh, w_static(num_area)
894 :
895 : integer :: iseg,iarea,iter,ipt
896 : integer, parameter :: iter_max=40
897 : logical :: lexit_after_one_more_iteration
898 :
899 1223359197 : lexit_after_one_more_iteration = .false.
900 : !
901 : ! compute static line-integrals (not necessary to recompute them for every iteration)
902 : !
903 1223359197 : flux_static = 0.0_r8
904 5242967986 : w_static = 0.0_r8
905 5242967986 : weight_area = 0.0_r8
906 5242967986 : do iarea=1,num_area
907 6378833687 : do iseg=1,num_seg_static(iarea)
908 :
909 : !rck vector directive needed here
910 : !DIR$ SIMD
911 9436899592 : do ipt=1,ngpc
912 7077674694 : xq(ipt) = x_static(1,iseg,iarea)+dx_static(1,iseg,iarea)*gspts(ipt)! create quadrature point locations
913 7077674694 : yq(ipt) = x_static(2,iseg,iarea)+dx_static(2,iseg,iarea)*gspts(ipt)
914 9436899592 : F(ipt,1) = yq(ipt)/(SQRT(1.0_r8+xq(ipt)*xq(ipt) + yq(ipt)*yq(ipt))*(1.0_r8+xq(ipt)*xq(ipt)))! potential ! potential
915 : enddo
916 13456508381 : weight_area(iarea) = weight_area(iarea)+sum(gsweights(:)*F(:,1))*0.5_r8*dx_static(1,iseg,iarea) !integral
917 : end do
918 4019608789 : w_static(iarea)= weight_area(iarea)
919 5242967986 : flux_static = flux_static+weight_area(iarea)*c(iarea) !add to swept flux
920 : end do
921 : !
922 : ! initilization
923 : !
924 1223359197 : gamma1=0.0_r8; f1=-flux ! zero flux guess 1
925 : !
926 : ! compute flux integrals of first guess passed to subroutine
927 : !
928 1223359197 : gamma2=gamma
929 1223359197 : f2 = 0.0_r8
930 5242967986 : weight_area=w_static
931 5242967986 : do iarea=1,num_area
932 7693864639 : do iseg=1,num_seg(iarea)
933 : !rck vector directive needed here
934 : !DIR$ SIMD
935 14697023400 : do ipt=1,ngpc
936 11022767550 : xq(ipt) = x(1,iseg,iarea)+dx(1,iseg,iarea)*gspts(ipt)! create quadrature point locations
937 11022767550 : yq(ipt) = x(2,iseg,iarea)+dx(2,iseg,iarea)*gspts(ipt)
938 11022767550 : xq2 = xq(ipt)*xq(ipt)
939 11022767550 : xq2i = 1.0_r8/(1.0_r8+xq2)
940 11022767550 : rho = SQRT(1.0_r8+xq2+yq(ipt)*yq(ipt))
941 11022767550 : rhoi = 1.0_r8/rho
942 11022767550 : yrh = yq(ipt)*rhoi
943 14697023400 : F(ipt,1) = yrh*xq2i
944 : enddo
945 18716632189 : weight_area(iarea) = weight_area(iarea)+sum(gsweights(:)*F(:,1))*0.5_r8*dx(1,iseg,iarea)! integral
946 : end do
947 5242967986 : f2 = f2+weight_area(iarea)*c(iarea)
948 : end do
949 1223359197 : f2 = f2-flux !integral error
950 1223359197 : iter=0
951 1223359197 : if (abs(f2-f1)<eps) then
952 : !
953 : ! in case the first guess is converged
954 : !
955 : return
956 : end if
957 :
958 :
959 1223359197 : dgamma=(gamma2-gamma1)*f2/(f2-f1);
960 1223359197 : gamma3 = gamma2-dgamma; ! Newton "guess" for gamma
961 1223359197 : gamma1 = gamma2; f1 = f2; gamma2 = gamma3; ! prepare for iteration
962 3423715905 : do iter=1,iter_max
963 : !
964 : ! update vertex location: flow_case dependent to avoid many zero operations
965 : !
966 3855597594 : select case(flow_case)
967 : case(-4)
968 431881689 : iarea=1
969 1295645067 : dx (:,2,1) = gamma3*dgam_vec (:,1)
970 1295645067 : x (:,1,1) = x_start(:,1)+gamma3*dgam_vec(:,1)
971 1295645067 : dx (:,1,1) = -gamma3*dgam_vec (:,1)
972 :
973 : case(-2)
974 387734063 : iarea=1
975 1163202189 : dx (:,1,iarea) = gamma3*dgam_vec (:,1)
976 1163202189 : x (:,2,iarea) = x_start(:,2)+gamma3*dgam_vec(:,1)
977 1163202189 : dx (:,2,iarea) = -gamma3*dgam_vec (:,1)
978 : case(-1)
979 : !
980 : ! to compute first-guess perpendicular displacements for iside=1
981 : !
982 808995093 : iarea=1
983 2426985279 : x (:,1,iarea) = x_start(:,1)+gamma3*dgam_vec(:,1)
984 2426985279 : dx (:,1,iarea) = -dx_static(:,1,iarea)
985 2426985279 : x (:,2,iarea) = x_start(:,2)+gamma3*dgam_vec(:,1)
986 2426985279 : dx (:,2,iarea) = x_start(:,2)-x(:,2,iarea)
987 : case(0)
988 35890700 : iarea=3
989 107672100 : xtmp = x_start(:,1)+gamma3*dgam_vec(:,1)
990 107672100 : dx (:,1,iarea) = xtmp(: )-x(:,1,iarea) !dynamic - line 2
991 107672100 : x (:,2,iarea) = xtmp(: ) !dynamic - line 3
992 107672100 : dx (:,2,iarea) = x_static(:,2,iarea)-x(:,2,iarea) !dynamic - line 3
993 : case(1)
994 22580687 : iarea=2
995 67742061 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
996 67742061 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
997 67742061 : x (:,2,iarea) = xtmp(:) !dynamic - line 3
998 67742061 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 3
999 :
1000 22580687 : iarea = 3
1001 67742061 : xtmp (: ) = x_start(:,4)+gamma3*dgam_vec(:,4)
1002 67742061 : xtmp2(: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1003 67742061 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1004 67742061 : x (:,2,iarea) = xtmp (:) !dynamic
1005 67742061 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1006 67742061 : x (:,3,iarea) = xtmp2(:) !dynamic
1007 67742061 : dx (:,3,iarea) = x_start(:,5)-xtmp2(:) !dynamic
1008 :
1009 22580687 : iarea = 4
1010 67742061 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1011 67742061 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1012 67742061 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1013 67742061 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1014 : case(2)
1015 824750996 : iarea=2
1016 2474252988 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
1017 2474252988 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1018 2474252988 : x (:,2,iarea) = xtmp(:) !dynamic - line 3
1019 2474252988 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 3
1020 :
1021 824750996 : iarea=3
1022 2474252988 : xtmp(: ) = x_start(:,4)+gamma3*dgam_vec(:,4)!
1023 2474252988 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1024 2474252988 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1025 2474252988 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1026 : case(3)
1027 826372229 : iarea = 3
1028 2479116687 : xtmp (: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1029 2479116687 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1030 2479116687 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1031 2479116687 : dx (:,2,iarea) = x_static(:,2,iarea)-xtmp(:) !dynamic - line 2
1032 :
1033 826372229 : iarea = 4
1034 2479116687 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1035 2479116687 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1036 2479116687 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1037 2479116687 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1038 : case(4)
1039 42138372 : iarea = 1
1040 126415116 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
1041 126415116 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1042 126415116 : x (:,2,iarea) = xtmp(:) !dynamic
1043 126415116 : dx(:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic
1044 :
1045 42138372 : iarea = 2
1046 126415116 : xtmp (: ) = x_start(:,2)+gamma3*dgam_vec(:,2)
1047 126415116 : xtmp2 (: ) = x_start(:,3)+gamma3*dgam_vec(:,3)
1048 :
1049 126415116 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1050 :
1051 126415116 : x (:,2,iarea) = xtmp (:) !dynamic
1052 126415116 : dx(:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1053 :
1054 126415116 : x (:,3,iarea) = xtmp2(:) !dynamic
1055 126415116 : dx(:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1056 :
1057 42138372 : iarea = 3
1058 126415116 : xtmp (: ) = x_start(:,4)+gamma3*dgam_vec(:,4)
1059 126415116 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1060 126415116 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1061 126415116 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1062 : case(5)
1063 41853471 : iarea = 3
1064 125560413 : xtmp (: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1065 125560413 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1066 125560413 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1067 125560413 : dx (:,2,iarea) = x_static(:,2,iarea)-xtmp(:) !dynamic - line 2
1068 :
1069 41853471 : iarea = 4
1070 125560413 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1071 125560413 : xtmp2 (: ) = x_start(:,7)+gamma3*dgam_vec(:,7)
1072 :
1073 125560413 : dx(:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1074 125560413 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1075 125560413 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic - line 2
1076 125560413 : x (:,3,iarea) = xtmp2(:) !dynamic -line 1
1077 125560413 : dx (:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic - line 1
1078 :
1079 41853471 : iarea = 5
1080 125560413 : xtmp (: ) = x_start(:,8)+gamma3*dgam_vec(:,8)
1081 :
1082 125560413 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1083 125560413 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1084 125560413 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1085 : case(6)
1086 736092 : iarea = 1
1087 2208276 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
1088 2208276 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1089 2208276 : x (:,2,iarea) = xtmp(:) !dynamic
1090 2208276 : dx(:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic
1091 :
1092 736092 : iarea = 2
1093 2208276 : xtmp (: ) = x_start(:,2)+gamma3*dgam_vec(:,2)
1094 2208276 : xtmp2 (: ) = x_start(:,3)+gamma3*dgam_vec(:,3)
1095 :
1096 2208276 : dx(:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1097 2208276 : x (:,2,iarea) = xtmp (:) !dynamic
1098 2208276 : dx(:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1099 2208276 : x (:,3,iarea) = xtmp2(:) !dynamic
1100 2208276 : dx(:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1101 :
1102 736092 : iarea = 3
1103 2208276 : xtmp (: ) = x_start(:,4)+gamma3*dgam_vec(:,4)
1104 2208276 : xtmp2(: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1105 2208276 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1106 2208276 : x (:,2,iarea) = xtmp (:) !dynamic
1107 2208276 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1108 2208276 : x (:,3,iarea) = xtmp2(:) !dynamic
1109 2208276 : dx (:,3,iarea) = x_start(:,5)-xtmp2(:) !dynamic
1110 :
1111 736092 : iarea = 4
1112 2208276 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1113 2208276 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1114 2208276 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1115 2208276 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1116 : case(7)
1117 764163 : iarea=2
1118 2292489 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
1119 2292489 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1120 2292489 : x (:,2,iarea) = xtmp(:) !dynamic - line 3
1121 2292489 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 3
1122 :
1123 764163 : iarea = 3
1124 2292489 : xtmp (: ) = x_start(:,4)+gamma3*dgam_vec(:,4)
1125 2292489 : xtmp2(: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1126 2292489 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1127 2292489 : x (:,2,iarea) = xtmp (:) !dynamic
1128 2292489 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1129 2292489 : x (:,3,iarea) = xtmp2(:) !dynamic
1130 2292489 : dx (:,3,iarea) = x_start(:,5)-xtmp2(:) !dynamic
1131 :
1132 764163 : iarea = 4
1133 2292489 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1134 2292489 : xtmp2 (: ) = x_start(:,7)+gamma3*dgam_vec(:,7)
1135 :
1136 2292489 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1137 2292489 : x (:,2,iarea) = xtmp(:) !dynamic
1138 2292489 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1139 2292489 : x (:,3,iarea) = xtmp2(:) !dynamic
1140 2292489 : dx (:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1141 :
1142 764163 : iarea = 5
1143 2292489 : xtmp (: ) = x_start(:,8)+gamma3*dgam_vec(:,8)
1144 2292489 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1145 2292489 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1146 2292489 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1147 : case(8)
1148 18350 : iarea = 1
1149 55050 : xtmp(: ) = x_start(:,1)+gamma3*dgam_vec(:,1)
1150 55050 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1151 55050 : x (:,2,iarea) = xtmp(:) !dynamic
1152 55050 : dx(:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic
1153 :
1154 18350 : iarea = 2
1155 55050 : xtmp (: ) = x_start(:,2)+gamma3*dgam_vec(:,2)
1156 55050 : xtmp2 (: ) = x_start(:,3)+gamma3*dgam_vec(:,3)
1157 :
1158 55050 : dx(:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1159 55050 : x (:,2,iarea) = xtmp (:) !dynamic
1160 55050 : dx(:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1161 55050 : x (:,3,iarea) = xtmp2(:) !dynamic
1162 55050 : dx(:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1163 :
1164 18350 : iarea = 3
1165 55050 : xtmp (: ) = x_start(:,4)+gamma3*dgam_vec(:,4)
1166 55050 : xtmp2(: ) = x_start(:,5)+gamma3*dgam_vec(:,5)
1167 55050 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1168 55050 : x (:,2,iarea) = xtmp (:) !dynamic
1169 55050 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1170 55050 : x (:,3,iarea) = xtmp2(:) !dynamic
1171 55050 : dx (:,3,iarea) = x_start(:,5)-xtmp2(:) !dynamic
1172 :
1173 18350 : iarea = 4
1174 55050 : xtmp (: ) = x_start(:,6)+gamma3*dgam_vec(:,6)
1175 55050 : xtmp2 (: ) = x_start(:,7)+gamma3*dgam_vec(:,7)
1176 :
1177 55050 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1178 55050 : x (:,2,iarea) = xtmp(:) !dynamic
1179 55050 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1180 55050 : x (:,3,iarea) = xtmp2(:) !dynamic
1181 55050 : dx (:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1182 :
1183 18350 : iarea = 5
1184 55050 : xtmp (: ) = x_start(:,8)+gamma3*dgam_vec(:,8)
1185 55050 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1186 55050 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1187 55050 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1188 : case default
1189 3423715905 : call endrun('flow case not defined in get_flux_segments_area_iterate')
1190 : end select
1191 : !
1192 : ! compute flux integral
1193 : !
1194 14027852050 : f2 = 0.0_r8
1195 14027852050 : weight_area=w_static
1196 14027852050 : do iarea=1,num_area
1197 20489885852 : do iseg=1,num_seg(iarea)
1198 : !rck vector directive needed here
1199 : !DIR$ SIMD
1200 39542998828 : do ipt=1,ngpc
1201 :
1202 29657249121 : xq(ipt) = x(1,iseg,iarea)+dx(1,iseg,iarea)*gspts(ipt)! create quadrature point locations
1203 29657249121 : yq(ipt) = x(2,iseg,iarea)+dx(2,iseg,iarea)*gspts(ipt)
1204 :
1205 29657249121 : xq2 = xq(ipt)*xq(ipt)
1206 29657249121 : xq2i = 1.0_r8/(1.0_r8+xq2)
1207 29657249121 : rho = SQRT(1.0_r8+xq2+yq(ipt)*yq(ipt))
1208 29657249121 : rhoi = 1.0_r8/rho
1209 29657249121 : yrh = yq(ipt)*rhoi
1210 39542998828 : F(ipt,1) = yrh*xq2i
1211 : end do
1212 50147134973 : weight_area(iarea) = weight_area(iarea)+sum(gsweights(:)*F(:,1))*0.5_r8*dx(1,iseg,iarea)! integral
1213 : end do
1214 14027852050 : f2 = f2+weight_area(iarea)*c(iarea)
1215 : end do
1216 3423715905 : f2 = f2-flux !integral error
1217 :
1218 : !
1219 : ! uncommented logic leads to noise in PS in FKESSLER at element boundary
1220 : !
1221 : ! if (ABS(f2)<eps.or.ABS((gamma2-gamma1)*f2)<eps.or.lexit_after_one_more_iteration) then
1222 : !
1223 4647075102 : if (ABS(f2)<eps.or.lexit_after_one_more_iteration) then
1224 1223520027 : gamma=gamma3
1225 1223520027 : if (gamma>gamma_max) then
1226 160830 : lexit_after_one_more_iteration=.true.
1227 160830 : gamma=gamma_max
1228 160830 : gamma3=gamma_max
1229 : else
1230 : exit
1231 : end if
1232 : else
1233 : !
1234 : ! Newton increment
1235 : !
1236 2200195878 : if (abs(f2-f1)<eps) then
1237 : !
1238 : ! if entering here abs(f2)>eps and abs(f1)>eps but abs(f2-f1)<eps
1239 : !
1240 7 : dgamma=-0.5_r8*(gamma2-gamma1)
1241 7 : lexit_after_one_more_iteration=.true.
1242 : else
1243 2200195871 : dgamma=(gamma2-gamma1)*f2/(f2-f1)
1244 : endif
1245 2200195878 : if (ABS(dgamma)>eps) then
1246 2200195878 : gamma3 = gamma2-dgamma;
1247 : else
1248 : !
1249 : ! dgamma set to minimum displacement to avoid f2-f1=0
1250 : !
1251 0 : gamma3=gamma2-SIGN(1.0_r8,dgamma)*eps
1252 : end if
1253 2200195878 : gamma3=MAX(gamma3,gamma_min)
1254 : !
1255 : ! prepare for next iteration
1256 : !
1257 2200195878 : gamma1 = gamma2; f1 = f2; gamma2 = gamma3;
1258 : endif
1259 : end do
1260 1223359197 : if (iter>iter_max) write(iulog,*) "WARNING: iteration not converged",&
1261 0 : ABS(f2),flux,gamma1,gamma2,gamma3,ilev
1262 : end subroutine get_flux_segments_area_iterate
1263 :
1264 29127600 : subroutine define_swept_areas(fvm,ilev,displ,base_vec,base_vtx,idx)
1265 : use control_mod, only : neast, nwest, seast, swest
1266 : implicit none
1267 : type (fvm_struct), intent(inout) :: fvm
1268 : integer , intent(in) :: ilev
1269 :
1270 :
1271 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1272 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides), intent(out) :: displ
1273 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(out) :: base_vec
1274 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(out) :: base_vtx
1275 : integer , dimension(2,num_area, imin:imax,imin:imax,num_sides), intent(out) :: idx
1276 :
1277 : real (kind=r8) :: flux_sum (0:nc+1,0:nc+1,2)
1278 : integer :: degenerate (1:nc+1,1:nc+1 )
1279 : integer :: circular_flow(1:nc+1,1:nc+1 )
1280 : integer :: illcond (1:nc+1,1:nc+1)
1281 : integer :: ib,i,j,sgn, iside, iarea
1282 :
1283 : !
1284 : ! set where reconstruction function is as a function of area and side
1285 : !
1286 : integer, dimension(num_area*4), parameter :: idx_shift_tmp = (/-1,-1, 0, 1, 1,& !iside=1
1287 : 1, 0, 0, 0, 1,& !iside=2
1288 : 1, 1, 0,-1,-1,& !iside=3
1289 : -1, 0, 0, 0,-1/) !iside=4
1290 :
1291 : integer, dimension(num_area*4), parameter :: idy_shift_tmp = (/-1, 0, 0, 0,-1,& !iside=1
1292 : -1,-1, 0, 1, 1,& !iside=2
1293 : 1, 0, 0, 0, 1,& !iside=3
1294 : 1, 1, 0,-1,-1/) !iside=4
1295 :
1296 : integer, dimension(num_area,4), parameter :: idx_shift = RESHAPE(idx_shift_tmp,(/num_area,4/))
1297 : integer, dimension(num_area,4), parameter :: idy_shift = RESHAPE(idy_shift_tmp,(/num_area,4/))
1298 :
1299 : integer, dimension(4), parameter :: iside_m1 = (/4,1,2,3/)
1300 : integer, dimension(4), parameter :: iside_p1 = (/2,3,4,1/)
1301 : integer, dimension(4), parameter :: iside_p2 = (/3,4,1,2/)
1302 : integer, dimension(4), parameter :: iside_p3 = (/4,1,2,3/)
1303 :
1304 : integer, dimension(4), parameter :: imin_side = (/1 ,0 ,1 ,1 /)
1305 : integer, dimension(4), parameter :: imax_side = (/nc ,nc ,nc ,nc+1/)
1306 : integer, dimension(4), parameter :: jmin_side = (/1 ,1 ,0 ,1 /)
1307 : integer, dimension(4), parameter :: jmax_side = (/nc+1,nc ,nc ,nc /)
1308 :
1309 :
1310 :
1311 : integer :: iur,jur,ilr,jlr,iul,jul,ill,jll
1312 :
1313 29127600 : ib = fvm%cubeboundary
1314 728190000 : flux_sum(0:nc+1,1:nc+1,1) = fvm%se_flux(0:nc+1,0:nc ,3,ilev)-fvm%se_flux(0:nc+1,1:nc+1,1,ilev)
1315 757317600 : flux_sum(1:nc+1,0:nc+1,2) = fvm%se_flux(0:nc ,0:nc+1,2,ilev)-fvm%se_flux(1:nc+1,0:nc+1,4,ilev)
1316 :
1317 : !
1318 : ! Degenerate case ("two departure points")
1319 : !
1320 : ! || | || no change in this situation || no change in this situation
1321 : ! || | || ||
1322 : ! ||-------- ||---------- ||----------
1323 : ! || | || ||
1324 : ! ======================= ======================= =====================
1325 : ! | || | || ||
1326 : ! -----|---|| ------|---|| ---------||
1327 : ! | || | || ||
1328 : ! | || | || ||
1329 : !
1330 : !
1331 611679600 : where (flux_sum(0:nc,1:nc+1,1)*flux_sum(1:nc+1,1:nc+1,1)<0.0_r8.and.flux_sum(1:nc+1,0:nc,2)*flux_sum(1:nc+1,1:nc+1,2)<0.0_r8)
1332 : degenerate(:,:) = 0
1333 : elsewhere
1334 : degenerate(:,:) = 1
1335 : end where
1336 :
1337 29127600 : if (ib>0) then
1338 3754224 : if (ib==swest) degenerate(1 ,1 ) = 1
1339 3721860 : if (ib==nwest) degenerate(1 ,nc+1) = 1
1340 3721860 : if (ib==neast) degenerate(nc+1,nc+1) = 1
1341 3721860 : if (ib==seast) degenerate(nc+1,1 ) = 1
1342 : end if
1343 :
1344 145638000 : do j=1,nc+1
1345 611679600 : do i=1,nc+1
1346 1048593600 : do sgn=-1,1,2
1347 : if (&
1348 3728332800 : sgn*flux_sum(i-1,j,1)<0.0_r8.and.sgn*flux_sum(i,j-1,2)>0.0_r8.and.&
1349 5126457600 : sgn*flux_sum(i ,j,1)>0.0_r8.and.sgn*flux_sum(i,j ,2)<0.0_r8) then
1350 719470 : circular_flow(i,j) = 0
1351 : else
1352 931363730 : circular_flow(i,j) = 1
1353 : end if
1354 : end do
1355 : end do
1356 : end do
1357 : !
1358 : ! wrap around corners
1359 : !
1360 29127600 : if (ib==nwest) then
1361 32364 : flux_sum(0,nc+1,1) = fvm%se_flux(0,nc,3,ilev)-fvm%se_flux(1,nc+1,4,ilev)
1362 32364 : flux_sum(1,nc+1,2) = fvm%se_flux(0,nc,3,ilev)-fvm%se_flux(1,nc+1,4,ilev)
1363 :
1364 32364 : i=1;j=nc+1;
1365 32364 : circular_flow(i,j) = 1
1366 97092 : do sgn=-1,1,2
1367 : if (&
1368 : sgn*flux_sum(i,j-1,2)>0.0_r8.and.&
1369 97092 : sgn*flux_sum(i ,j,1)>0.0_r8.and.sgn*flux_sum(i,j ,2)<0.0_r8) then
1370 62 : circular_flow(i,j) = 0
1371 : end if
1372 : end do
1373 29095236 : else if (ib==swest) then
1374 32364 : flux_sum(0,1,1) = fvm%se_flux(1,0,4,ilev)-fvm%se_flux(0,1,1,ilev)
1375 32364 : flux_sum(1,0,2) = fvm%se_flux(0,1,1,ilev)-fvm%se_flux(1,0,4,ilev)
1376 32364 : i=1;j=1;
1377 32364 : circular_flow(i,j) = 1
1378 97092 : do sgn=-1,1,2
1379 : if (&
1380 : sgn*flux_sum(i-1,j,1)<0.0_r8.and.&
1381 97092 : sgn*flux_sum(i ,j,1)>0.0_r8.and.sgn*flux_sum(i,j ,2)<0.0_r8) then
1382 120 : circular_flow(i,j) = 0
1383 : end if
1384 : end do
1385 29062872 : else if (ib==neast) then
1386 32364 : flux_sum(nc+1,nc+1,1) = fvm%se_flux(nc+1,nc,3,ilev)-fvm%se_flux(nc,nc+1,2,ilev)
1387 32364 : flux_sum(nc+1,nc+1,2) = fvm%se_flux(nc,nc+1,2,ilev)-fvm%se_flux(nc+1,nc,3,ilev)
1388 32364 : i=nc+1;j=nc+1;
1389 32364 : circular_flow(i,j) = 1
1390 97092 : do sgn=-1,1,2
1391 : if (&
1392 64728 : sgn*flux_sum(i-1,j,1)<0.0_r8.and.sgn*flux_sum(i,j-1,2)>0.0_r8.and.&
1393 32364 : sgn*flux_sum(i,j ,2)<0.0_r8) then
1394 69 : circular_flow(i,j) = 0
1395 : end if
1396 : end do
1397 29030508 : else if (ib==seast) then
1398 32364 : flux_sum(nc+1,1 ,1) = fvm%se_flux(nc,0,2,ilev)-fvm%se_flux(nc+1,1,1,ilev)
1399 32364 : flux_sum(nc+1,0 ,2) = fvm%se_flux(nc,0,2,ilev)-fvm%se_flux(nc+1,1,1,ilev)
1400 32364 : i=nc+1;j=1;
1401 32364 : circular_flow(i,j) = 1
1402 97092 : do sgn=-1,1,2
1403 : if (&
1404 64728 : sgn*flux_sum(i-1,j,1)<0.0_r8.and.sgn*flux_sum(i,j-1,2)>0.0_r8.and.&
1405 32364 : sgn*flux_sum(i,j ,2)<0.0_r8) then
1406 142 : circular_flow(i,j) = 0
1407 : end if
1408 : end do
1409 : end if
1410 611679600 : illcond = circular_flow*degenerate
1411 : !
1412 : !
1413 : !
1414 : !
1415 145638000 : do iside=1,4
1416 553424400 : do j=jmin_side(iside),jmax_side(iside)
1417 1922421600 : do i=imin_side(iside),imax_side(iside)
1418 1805911200 : if (fvm%se_flux(i,j,iside,ilev)>eps) then
1419 699062398 : iur = i+idx_shift(4,iside); jur = j+idy_shift(4,iside) !(i,j) index of upper right quadrant
1420 699062398 : ilr = i+idx_shift(5,iside); jlr = j+idy_shift(5,iside) !(i,j) index of lower left quadrant
1421 699062398 : iul = i+idx_shift(2,iside); jul = j+idy_shift(2,iside) !(i,j) index of upper right quadrant
1422 699062398 : ill = i+idx_shift(1,iside); jll = j+idy_shift(1,iside) !(i,j) index of lower left quadrant
1423 :
1424 : !iside=1
1425 699062398 : if (iside==1) then
1426 175795778 : displ(0,i,j,iside) = -flux_sum (i ,j ,1)*illcond(i,j) !center left
1427 175795778 : displ(1,i,j,iside) = -flux_sum (i ,j ,1)*illcond(i+1,j) !center right
1428 175795778 : displ(2,i,j,iside) = flux_sum (i+1,j ,2)*illcond(i+1,j) !c2
1429 175795778 : displ(3,i,j,iside) = -flux_sum (i ,j ,2)*illcond(i ,j) !c3
1430 175795778 : displ(4,i,j,iside) = -flux_sum (i+1,j ,1)*illcond(i+1,j) !r1
1431 175795778 : displ(5,i,j,iside) = -flux_sum (i+1,j-1,2)*illcond(i+1,j) !r2
1432 175795778 : displ(6,i,j,iside) = -flux_sum (i-1,j ,1)*illcond(i ,j) !l1
1433 175795778 : displ(7,i,j,iside) = flux_sum (i ,j-1,2)*illcond(i ,j) !l2
1434 :
1435 : end if
1436 699062398 : if (iside==2) then
1437 : !iside=2
1438 166778984 : displ(0,i,j,iside) = flux_sum (i+1,j ,2)*illcond(i+1,j ) !center left
1439 166778984 : displ(1,i,j,iside) = flux_sum (i+1,j ,2)*illcond(i+1,j+1) !center right
1440 166778984 : displ(2,i,j,iside) = flux_sum (i ,j+1,1)*illcond(i+1,j+1) !c2
1441 166778984 : displ(3,i,j,iside) = -flux_sum (i ,j ,1)*illcond(i+1,j ) !c3
1442 166778984 : displ(4,i,j,iside) = flux_sum (i+1,j+1,2)*illcond(i+1,j+1) !r1
1443 166778984 : displ(5,i,j,iside) = -flux_sum (i+1,j+1,1)*illcond(i+1,j+1) !r2
1444 166778984 : displ(6,i,j,iside) = flux_sum (i+1,j-1,2)*illcond(i+1,j) !l1
1445 166778984 : displ(7,i,j,iside) = flux_sum (i+1,j ,1)*illcond(i+1,j) !l2
1446 : end if
1447 : !iside=3
1448 699062398 : if (iside==3) then
1449 173735422 : displ(0,i,j,iside) = flux_sum (i ,j+1,1)*illcond(i+1,j+1) !center left
1450 173735422 : displ(1,i,j,iside) = flux_sum (i ,j+1,1)*illcond(i ,j+1) !center right
1451 173735422 : displ(2,i,j,iside) = -flux_sum (i ,j ,2)*illcond(i ,j+1) !c2
1452 173735422 : displ(3,i,j,iside) = flux_sum (i+1,j ,2)*illcond(i+1,j+1) !c3
1453 173735422 : displ(4,i,j,iside) = flux_sum (i-1,j+1,1)*illcond(i ,j+1) !r1
1454 173735422 : displ(5,i,j,iside) = flux_sum (i ,j+1,2)*illcond(i ,j+1) !r2
1455 173735422 : displ(6,i,j,iside) = flux_sum (i+1,j+1,1)*illcond(i+1,j+1) !l1
1456 173735422 : displ(7,i,j,iside) = -flux_sum (i+1,j+1,2)*illcond(i+1,j+1) !l2
1457 : end if
1458 699062398 : if (iside==4) then
1459 : !iside=4
1460 182752214 : displ(0,i,j,iside) = -flux_sum (i ,j ,2)*illcond(i ,j+1) !center left
1461 182752214 : displ(1,i,j,iside) = -flux_sum (i ,j ,2)*illcond(i ,j ) !center right
1462 182752214 : displ(2,i,j,iside) = -flux_sum (i ,j ,1)*illcond(i ,j ) !c2
1463 182752214 : displ(3,i,j,iside) = flux_sum (i ,j+1,1)*illcond(i ,j+1) !c3
1464 182752214 : displ(4,i,j,iside) = -flux_sum (i ,j-1,2)*illcond(i ,j ) !r1
1465 182752214 : displ(5,i,j,iside) = flux_sum (i-1,j ,1)*illcond(i ,j ) !r2
1466 182752214 : displ(6,i,j,iside) = -flux_sum (i ,j+1,2)*illcond(i ,j+1) !l1
1467 182752214 : displ(7,i,j,iside) = -flux_sum (i-1,j+1,1)*illcond(i ,j+1) !l2
1468 : end if
1469 :
1470 2097187194 : base_vtx(:,1,i,j,iside) = fvm%vtx_cart(iside,:,i ,j ) !vertex center left
1471 2097187194 : base_vtx(:,2,i,j,iside) = fvm%vtx_cart(iside_p1(iside),:,i ,j ) !vertex center right
1472 2097187194 : base_vtx(:,3,i,j,iside) = fvm%vtx_cart(iside,:,iur,jur ) !vertex upper right
1473 2097187194 : base_vtx(:,4,i,j,iside) = fvm%vtx_cart(iside_p3(iside),:,ilr,jlr) !vertex lower right
1474 2097187194 : base_vtx(:,5,i,j,iside) = fvm%vtx_cart(iside_p1(iside),:,iul,jul) !vertex upper left
1475 2097187194 : base_vtx(:,6,i,j,iside) = fvm%vtx_cart(iside_p2(iside),:,ill,jll) !vertex lower left
1476 :
1477 2097187194 : base_vec(:, 1,i,j,iside) = fvm%flux_vec (:,i ,j ,iside ) !vector center
1478 2097187194 : base_vec(:, 2,i,j,iside) = fvm%flux_vec (:,i ,j ,iside_p1(iside)) !vector center right
1479 2097187194 : base_vec(:, 3,i,j,iside) = fvm%flux_vec (:,i ,j ,iside_p3(iside)) !vector center left
1480 2097187194 : base_vec(:, 4,i,j,iside) = fvm%flux_vec (:,iur,jur,iside ) !vector upper right 1
1481 2097187194 : base_vec(:, 5,i,j,iside) = fvm%flux_vec (:,iur,jur,iside_p3(iside)) !vector upper right 2
1482 2097187194 : base_vec(:, 6,i,j,iside) = fvm%flux_vec (:,ilr,jlr,iside_p3(iside)) !vector lower right 1
1483 2097187194 : base_vec(:, 7,i,j,iside) = fvm%flux_vec (:,ilr,jlr,iside_p2(iside)) !vector lower right 2
1484 2097187194 : base_vec(:, 8,i,j,iside) = fvm%flux_vec (:,iul,jul,iside ) !vector upper left 1
1485 2097187194 : base_vec(:, 9,i,j,iside) = fvm%flux_vec (:,iul,jul,iside_p1(iside)) !vector upper left 2
1486 2097187194 : base_vec(:,10,i,j,iside) = fvm%flux_vec (:,ill,jll,iside_p1(iside)) !vector lower left 1
1487 2097187194 : base_vec(:,11,i,j,iside) = fvm%flux_vec (:,ill,jll,iside_p2(iside)) !vector lower left 2
1488 :
1489 4194374388 : do iarea=1,5
1490 3495311990 : idx(1,iarea,i,j,iside) = i+idx_shift(iarea,iside)
1491 4194374388 : idx(2,iarea,i,j,iside) = j+idy_shift(iarea,iside)
1492 : end do
1493 : else
1494 6291561618 : displ(:,i,j,iside) = 9D99!for debugging
1495 : end if
1496 : end do
1497 : end do
1498 : end do
1499 : !
1500 : ! wrap around corners here
1501 : !
1502 :
1503 29127600 : end subroutine define_swept_areas
1504 :
1505 :
1506 : !
1507 : ! Notation conventions used in define_area subroutines
1508 : !
1509 : !
1510 : !
1511 : ! ^ ||---> ^ <---|| ^
1512 : ! /|\ || 3 /|\ 2 || /|\
1513 : ! | 6 || 1 | || | 4
1514 : ! | || | || |
1515 : ! =================================
1516 : ! || ||
1517 : ! || ||
1518 : ! 7 || || 5
1519 : ! <---|| ||--->
1520 : !
1521 :
1522 13832513 : subroutine define_area1_area2(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, num_seg_static,&
1523 : x_start, dgam_vec)
1524 : implicit none
1525 : integer, intent(in) :: i,j,iside
1526 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1527 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1528 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1529 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1530 : integer, parameter :: num_seg_max=5
1531 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1532 : integer , dimension(num_area) , intent(inout) :: num_seg, num_seg_static
1533 : REAL(KIND=r8), dimension(2,8) , intent(inout):: x_start, dgam_vec
1534 :
1535 :
1536 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1537 : real (kind=r8) :: gamma
1538 : integer :: iarea
1539 :
1540 :
1541 : REAL(KIND=r8) :: xtmp(2),xtmp2(2)
1542 : !
1543 : !
1544 : ! ||----- ||
1545 : ! /|| ||
1546 : ! / || ||
1547 : ! ===X=========================
1548 : ! | /|| ||
1549 : ! |/ || ||
1550 : ! * || ||
1551 : !
1552 : !
1553 : ! crossing X
1554 41497539 : if (SUM(ABS(base_vec(:,9,i,j,iside))).NE.0) then
1555 13810962 : gamma = displ(0,i,j,iside)*displ(7,i,j,iside)/(displ(0,i,j,iside)-displ(6,i,j,iside))
1556 : ! gamma = MAX(MIN(gamma,displ(7,i,j,iside),-displ(3,i,j,iside)),0.0_r8)!MWR manuscript
1557 13810962 : gamma = MAX(MIN(gamma,displ(7,i,j,iside),-0.25_r8*displ(3,i,j,iside)),0.0_r8)
1558 : else
1559 : !
1560 : ! corner case
1561 : !
1562 21551 : gamma=displ(0,i,j,iside)
1563 : end if
1564 :
1565 :
1566 41497539 : xdep (:,1) = base_vtx(:, 6,i,j,iside)+displ(7,i,j,iside)*base_vec(:,10,i,j,iside)-displ(6,i,j,iside)*base_vec(:,11,i,j,iside)
1567 41497539 : x_start (:,1) = base_vtx(:, 6,i,j,iside)
1568 41497539 : dgam_vec(:,1) = base_vec(:,10,i,j,iside)*gamma
1569 :
1570 41497539 : xdep(:,2) = base_vtx(:,2,i,j,iside)+displ(1,i,j,iside)*base_vec(:, 1,i,j,iside)+displ(2,i,j,iside)*base_vec(:, 2,i,j,iside)
1571 :
1572 13832513 : iarea = 1
1573 13832513 : num_seg (iarea) = 2
1574 13832513 : num_seg_static(iarea) = 1
1575 :
1576 41497539 : x_static (:,1,iarea) = base_vtx(:,6,i,j,iside) !static
1577 41497539 : dx_static(:,1,iarea) = xdep(:,1)-x_static(:,1,iarea) !static
1578 :
1579 41497539 : xtmp(: ) = x_start(:,1)+dgam_vec(:,1)
1580 41497539 : x (:,1,iarea) = xdep(:,1) !static
1581 41497539 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1582 :
1583 41497539 : x (:,2,iarea) = xtmp(:) !dynamic
1584 41497539 : dx(:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic
1585 : !
1586 : !
1587 : !
1588 13832513 : iarea = 2
1589 13832513 : num_seg (iarea) = 3
1590 :
1591 41497539 : x_start (:,2) = base_vtx(:,5,i,j,iside)
1592 41497539 : dgam_vec(:,2) = base_vec(:,9,i,j,iside)*gamma
1593 41497539 : xtmp (: ) = x_start(:,2)+dgam_vec(:,2)
1594 :
1595 41497539 : x_start (:,3) = base_vtx(:,5,i,j,iside)
1596 41497539 : dgam_vec(:,3) = base_vec(:,8,i,j,iside)*displ(0,i,j,iside)
1597 41497539 : xtmp2 (: ) = x_start(:,3)+dgam_vec(:,3)
1598 :
1599 41497539 : x (:,1,iarea) = base_vtx(:,5,i,j,iside) !static
1600 41497539 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1601 :
1602 41497539 : x (:,2,iarea) = xtmp (:) !dynamic
1603 41497539 : dx(:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1604 :
1605 41497539 : x (:,3,iarea) = xtmp2(:) !dynamic
1606 41497539 : dx(:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic
1607 13832513 : end subroutine define_area1_area2
1608 :
1609 :
1610 334955411 : subroutine define_area2(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, num_seg_static,x_start, dgam_vec,&
1611 : displ_first_guess)
1612 : implicit none
1613 : integer, intent(in) :: i,j,iside
1614 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1615 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1616 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1617 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1618 : integer, parameter :: num_seg_max=5
1619 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1620 : integer , dimension(num_area) , intent(inout) :: num_seg, num_seg_static
1621 : REAL(KIND=r8), dimension(2,8) , intent(inout):: x_start, dgam_vec
1622 :
1623 :
1624 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1625 : real (kind=r8), optional, intent(out) :: displ_first_guess
1626 : real (kind=r8) :: gamma
1627 : integer :: iarea
1628 :
1629 :
1630 : REAL(KIND=r8) :: xtmp(2)
1631 : ! *: xdep(:,1)
1632 : ! x: xtmp
1633 : !
1634 : ! 2 || ||
1635 : ! *--x ||
1636 : ! 1\3||1 ||
1637 : ! \|| ||
1638 : ! =============================
1639 : ! || ||
1640 : !
1641 : !
1642 : ! compute departure points (xdep(1) is left; xdep(3) is right and xdep(2) is midway
1643 : !
1644 : xdep(:,1) = base_vtx(:,5,i,j,iside)+&
1645 1004866233 : MAX(0.0_r8,displ(6,i,j,iside))*base_vec(:,8,i,j,iside)-displ(3,i,j,iside)*base_vec(:,9,i,j,iside)
1646 1004866233 : x_start (:,1) = base_vtx(:,5,i,j,iside)
1647 334955411 : gamma = displ(0,i,j,iside)
1648 1004866233 : dgam_vec(:,1) = base_vec(:,8,i,j,iside)*gamma
1649 334955411 : if (present(displ_first_guess)) displ_first_guess = gamma
1650 :
1651 334955411 : iarea = 2
1652 334955411 : num_seg (iarea) = 2
1653 334955411 : num_seg_static(iarea) = 1
1654 :
1655 1004866233 : x_static (:,1,iarea) = base_vtx(:,5,i,j,iside) !static - line 1
1656 1004866233 : dx_static(:,1,iarea) = xdep(:,1)-x_static(:,1,iarea) !static - line 1
1657 :
1658 1004866233 : xtmp (: ) = x_start(:,1)+dgam_vec(:,1)
1659 1004866233 : x (:,1,iarea) = xdep(:,1) !static - line 2
1660 1004866233 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1661 :
1662 1004866233 : x (:,2,iarea) = xtmp(:) !dynamic - line 3
1663 1004866233 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 3
1664 334955411 : end subroutine define_area2
1665 :
1666 :
1667 337189246 : subroutine define_area3_left(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, &
1668 : num_seg, num_seg_static,x_start, dgam_vec,displ_first_guess)
1669 : implicit none
1670 : integer, intent(in) :: i,j,iside
1671 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1672 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1673 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1674 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1675 : integer, parameter :: num_seg_max=5
1676 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1677 : integer , dimension(num_area) , intent(inout) :: num_seg, num_seg_static
1678 : REAL(KIND=r8), dimension(2,8) , intent(inout):: x_start, dgam_vec
1679 : real (kind=r8), optional, intent(out) :: displ_first_guess
1680 :
1681 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1682 : real (kind=r8) :: gamma
1683 : integer :: iarea
1684 :
1685 :
1686 : REAL(KIND=r8) :: xtmp(2)
1687 :
1688 : ! iarea = 3
1689 : !-------------------------------------------------------------------------------------------
1690 : !
1691 : ! xtmp xdep(2)
1692 : ! |x-----2------* ||
1693 : ! || \ ||
1694 : ! |1 3 ||
1695 : ! || \||
1696 : ! ===========4==============
1697 : !
1698 : !
1699 337189246 : xdep(:,2) = base_vtx(:,2,i,j,iside)+displ(1,i,j,iside)*base_vec(:,1,i,j,iside)&
1700 1348756984 : +MAX(0.0_r8,displ(2,i,j,iside))*base_vec(:,2,i,j,iside)
1701 1011567738 : x_start (:,4) = base_vtx(:,1,i,j,iside)
1702 337189246 : gamma = displ(0,i,j,iside)
1703 1011567738 : dgam_vec(:,4) = base_vec(:,1,i,j,iside)*gamma
1704 1011567738 : xtmp (: ) = x_start(:,4)+dgam_vec(:,4)
1705 :
1706 337189246 : if (present(displ_first_guess)) displ_first_guess = gamma
1707 :
1708 337189246 : iarea = 3
1709 337189246 : num_seg (iarea) = 2
1710 337189246 : num_seg_static(iarea) = 2
1711 :
1712 1011567738 : x_static (:,1,iarea) = xdep(:,2) !static - line 3
1713 1011567738 : dx_static(:,1,iarea) = base_vtx(:,2,i,j,iside)-xdep(:,2) !static - line 3
1714 :
1715 1011567738 : x_static (:,2,iarea) = base_vtx(:,2,i,j,iside) !static - line 4
1716 1011567738 : dx_static(:,2,iarea) = base_vtx(:,1,i,j,iside)-base_vtx(:,2,i,j,iside) !static - line 4
1717 :
1718 1011567738 : x (:,1,iarea) = base_vtx(:,1,i,j,iside) !static - line 1
1719 1011567738 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1720 :
1721 1011567738 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1722 1011567738 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1723 337189246 : end subroutine define_area3_left
1724 :
1725 337087546 : subroutine define_area3_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
1726 : num_seg_static,x_start, dgam_vec)
1727 : implicit none
1728 : integer, intent(in) :: i,j,iside
1729 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1730 : real (kind=r8) , dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1731 : integer (kind=r8) , dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1732 : real (kind=r8) , dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1733 : integer, parameter :: num_seg_max=5
1734 : REAL(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1735 : integer , dimension(num_area) , intent(inout) :: num_seg, num_seg_static
1736 : REAL(KIND=r8), dimension(2,8) , intent(inout):: x_start, dgam_vec
1737 :
1738 :
1739 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1740 : real (kind=r8) :: gamma
1741 : integer :: iarea
1742 :
1743 : REAL(KIND=r8) :: xtmp(2)
1744 : !
1745 : !
1746 : ! || *-----2----||\
1747 : ! || /1 3|| \
1748 : ! ||/ 4 ||
1749 : ! =============================
1750 : ! || ||
1751 : ! || ||
1752 : ! || ||
1753 : !
1754 337087546 : xdep(:,1) = base_vtx(:,1,i,j,iside)+displ(0,i,j,iside)*base_vec(:,1,i,j,iside)&
1755 1348350184 : +MAX(0.0_r8,displ(3,i,j,iside))*base_vec(:,3,i,j,iside)
1756 1011262638 : x_start (:,5) = base_vtx(:,2,i,j,iside)
1757 337087546 : gamma = displ(1,i,j,iside)
1758 1011262638 : dgam_vec(:,5) = base_vec(:,1,i,j,iside)*gamma
1759 1011262638 : xtmp (: ) = x_start(:,5)+dgam_vec(:,5)
1760 :
1761 337087546 : iarea = 3
1762 337087546 : num_seg (iarea) = 2
1763 337087546 : num_seg_static(iarea) = 2
1764 :
1765 1011262638 : x_static (:,1,iarea) = base_vtx(:,1,i,j,iside) !static - line 1
1766 1011262638 : dx_static(:,1,iarea) = xdep(:,1)-base_vtx(:,1,i,j,iside) !static - line 1
1767 :
1768 1011262638 : x_static (:,2,iarea) = base_vtx(:,2,i,j,iside) !static - line 4
1769 1011262638 : dx_static(:,2,iarea) = base_vtx(:,1,i,j,iside)-base_vtx(:,2,i,j,iside) !static - line 4
1770 :
1771 1011262638 : x (:,1,iarea) = xdep(:,1) !static - line 2
1772 1011262638 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1773 :
1774 1011262638 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1775 1011262638 : dx (:,2,iarea) = x_static(:,2,iarea)-xtmp(:) !dynamic - line 2
1776 337087546 : end subroutine define_area3_right
1777 :
1778 :
1779 11598678 : subroutine define_area3_left_right(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
1780 : num_seg_static,x_start, dgam_vec)
1781 : implicit none
1782 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1783 : integer, parameter :: num_seg_max=5
1784 : integer, intent(in) :: i,j,iside
1785 : real (kind=r8), dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout):: displ
1786 : integer (kind=r8), dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout):: base_vec
1787 : real (kind=r8), dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout):: base_vtx
1788 : real(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout):: x, dx, x_static, dx_static
1789 : integer, dimension(num_area), intent(inout):: num_seg, num_seg_static
1790 : real(KIND=r8), dimension(2,8), intent(inout):: x_start, dgam_vec
1791 :
1792 : real (kind=r8) :: gamma
1793 : integer :: iarea
1794 : real(KIND=r8) :: xtmp(2),xtmp2(2)
1795 : !
1796 : ! ||-------------||
1797 : ! /|| ||\
1798 : ! || ||
1799 : ! =============================
1800 : ! || ||
1801 : ! || ||
1802 : ! || ||
1803 : !
1804 34796034 : x_start (:,4) = base_vtx(:,1,i,j,iside)
1805 34796034 : x_start (:,5) = base_vtx(:,2,i,j,iside)
1806 11598678 : gamma = displ(0,i,j,iside)
1807 34796034 : dgam_vec(:,4) = base_vec(:,1,i,j,iside)*gamma
1808 34796034 : dgam_vec(:,5) = base_vec(:,1,i,j,iside)*gamma
1809 34796034 : xtmp (: ) = x_start(:,4)+dgam_vec(:,4)
1810 34796034 : xtmp2 (: ) = x_start(:,5)+dgam_vec(:,5)
1811 :
1812 11598678 : iarea = 3
1813 11598678 : num_seg (iarea) = 3
1814 11598678 : num_seg_static(iarea) = 1
1815 :
1816 34796034 : x_static (:,1,iarea) = base_vtx(:,2,i,j,iside) !static
1817 34796034 : dx_static(:,1,iarea) = base_vtx(:,1,i,j,iside)-base_vtx(:,2,i,j,iside) !static
1818 :
1819 34796034 : x (:,1,iarea) = base_vtx(:,1,i,j,iside) !static
1820 34796034 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic
1821 :
1822 34796034 : x (:,2,iarea) = xtmp (:) !dynamic
1823 34796034 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic
1824 :
1825 34796034 : x (:,3,iarea) = xtmp2(:) !dynamic
1826 34796034 : dx (:,3,iarea) = x_start(:,5)-xtmp2(:) !dynamic
1827 11598678 : end subroutine define_area3_left_right
1828 :
1829 13843549 : subroutine define_area4_area5(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
1830 : num_seg_static,x_start, dgam_vec,displ_first_guess)
1831 : implicit none
1832 : integer, intent(in) :: i,j,iside
1833 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1834 : integer, parameter :: num_seg_max=5
1835 : real (kind=r8), dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1836 : integer (kind=r8), dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1837 : real (kind=r8), dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1838 : real(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1839 : integer, dimension(num_area), intent(inout) :: num_seg, num_seg_static
1840 : real(KIND=r8), dimension(2,8), intent(inout) :: x_start, dgam_vec
1841 : real(KIND=r8), optional, intent(out) :: displ_first_guess
1842 :
1843 :
1844 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1845 : real (kind=r8) :: gamma
1846 : integer :: iarea
1847 :
1848 : real(KIND=r8) :: xtmp(2),xtmp2(2)
1849 : !
1850 : ! || --------||
1851 : ! || ||\
1852 : ! || || \
1853 : ! =============================
1854 : ! || ||\ |
1855 : ! || || \|
1856 : ! || || *
1857 : !
1858 : !
1859 : ! iarea = 4
1860 : !
1861 13843549 : iarea = 4
1862 13843549 : num_seg (iarea) = 3
1863 :
1864 41530647 : if (SUM(ABS(base_vec(:,5,i,j,iside))).NE.0) then
1865 13822079 : gamma = displ(1,i,j,iside)*displ(5,i,j,iside)/(displ(1,i,j,iside)-displ(4,i,j,iside))
1866 : ! gamma = MAX(MIN(gamma,displ(5,i,j,iside),-displ(2,i,j,iside)),0.0_r8)!MWR manuscript
1867 13822079 : gamma = MAX(MIN(gamma,displ(5,i,j,iside),-0.25_r8*displ(2,i,j,iside)),0.0_r8)
1868 : else
1869 : !
1870 : ! corner case
1871 : !
1872 21470 : gamma = displ(1,i,j,iside)
1873 : end if
1874 :
1875 13843549 : if (present(displ_first_guess)) displ_first_guess = displ(1,i,j,iside)
1876 :
1877 41530647 : x_start (:,6) = base_vtx(:,3,i,j,iside)
1878 41530647 : dgam_vec(:,6) = base_vec(:,4,i,j,iside)*displ(1,i,j,iside)
1879 41530647 : xtmp (: ) = x_start(:,6)+dgam_vec(:,6)
1880 41530647 : x_start (:,7) = base_vtx(:,3,i,j,iside)
1881 41530647 : dgam_vec(:,7) = base_vec(:,5,i,j,iside)*gamma
1882 41530647 : xtmp2 (: ) = x_start(:,7)+dgam_vec(:,7)
1883 :
1884 41530647 : x (:,1,iarea) = base_vtx(:,3,i,j,iside)!static -line 1
1885 41530647 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1886 :
1887 41530647 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1888 41530647 : dx (:,2,iarea) = xtmp2(:)-xtmp(:) !dynamic - line 2
1889 :
1890 41530647 : x (:,3,iarea) = xtmp2(:) !static -line 1
1891 41530647 : dx (:,3,iarea) = x(:,1,iarea)-xtmp2(:) !dynamic - line 1
1892 : !
1893 : !iarea = 5
1894 : !
1895 : xdep(:,1) = base_vtx(:,4,i,j,iside)+displ(5,i,j,iside)*base_vec(:,6,i,j,iside)&
1896 41530647 : -displ(4,i,j,iside)*base_vec(:,7,i,j,iside)
1897 41530647 : x_start (:,8) = base_vtx(:,4,i,j,iside)
1898 41530647 : dgam_vec(:,8) = base_vec(:,6,i,j,iside)*gamma
1899 41530647 : xtmp (: ) = x_start(:,8)+dgam_vec(:,8)
1900 :
1901 13843549 : iarea = 5
1902 13843549 : num_seg (iarea) = 2
1903 13843549 : num_seg_static(iarea) = 1
1904 :
1905 41530647 : x (:,1,iarea) = base_vtx(:,4,i,j,iside)!static -line 1
1906 41530647 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 1
1907 :
1908 41530647 : x_static (:,1,iarea) = xdep(:,1) !static - line 1
1909 41530647 : dx_static(:,1,iarea) = x(:,1,iarea)-x_static(:,1,iarea) !static - line 1
1910 :
1911 41530647 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1912 41530647 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1913 13843549 : end subroutine define_area4_area5
1914 :
1915 :
1916 334842675 : subroutine define_area4(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, &
1917 : num_seg_static,x_start, dgam_vec,displ_first_guess)
1918 : implicit none
1919 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1920 : integer, parameter :: num_seg_max=5
1921 : integer, intent(in) :: i,j,iside
1922 : real (kind=r8), dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1923 : integer (kind=r8), dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1924 : real (kind=r8), dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1925 :
1926 : real(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1927 : integer, dimension(num_area) , intent(inout) :: num_seg, num_seg_static
1928 : real(KIND=r8), dimension(2,8) , intent(inout) :: x_start, dgam_vec
1929 : real(KIND=r8), optional, intent(out) :: displ_first_guess
1930 :
1931 :
1932 :
1933 : real (kind=r8), dimension(2,3) :: xdep !departure points
1934 : real (kind=r8) :: gamma
1935 : integer :: iarea
1936 : real(KIND=r8) :: xtmp(2)
1937 :
1938 334842675 : iarea = 4
1939 334842675 : num_seg (iarea) = 2
1940 334842675 : num_seg_static(iarea) = 1
1941 :
1942 334842675 : xdep(:,1) = base_vtx(:,3,i,j,iside)+MAX(0.0_r8,displ(4,i,j,iside))*base_vec(:,4,i,j,iside)&
1943 1339370700 : -displ(2,i,j,iside)*base_vec(:,5,i,j,iside)
1944 1004528025 : x_start (:,6) = base_vtx(:,3,i,j,iside)
1945 334842675 : gamma = displ(1,i,j,iside)
1946 1004528025 : dgam_vec(:,6) = base_vec(:,4,i,j,iside)*gamma
1947 1004528025 : xtmp (: ) = x_start(:,6)+dgam_vec(:,6)
1948 :
1949 334842675 : if (present(displ_first_guess)) displ_first_guess = gamma
1950 :
1951 1004528025 : x_static (:,1,iarea) = xdep(:,1) !static
1952 1004528025 : dx_static(:,1,iarea) = base_vtx(:,3,i,j,iside)-xdep(:,1) !static
1953 :
1954 1004528025 : x (:,1,iarea) = base_vtx(:,3,i,j,iside) !static - line 2
1955 1004528025 : dx (:,1,iarea) = xtmp(:)-x(:,1,iarea) !dynamic - line 2
1956 :
1957 1004528025 : x (:,2,iarea) = xtmp(:) !dynamic -line 2
1958 1004528025 : dx (:,2,iarea) = x_static(:,1,iarea)-xtmp(:) !dynamic - line 2
1959 334842675 : end subroutine define_area4
1960 :
1961 13186928 : subroutine define_area3_center(i,j,iside,displ,base_vec,base_vtx,x, dx, x_static, dx_static, num_seg, num_seg_static,&
1962 : x_start, dgam_vec,se_flux_center,displ_first_guess)
1963 : implicit none
1964 : integer, intent(in) :: i,j,iside
1965 : integer, parameter :: num_area=5, num_sides=4, imin= 0, imax=nc+1
1966 : integer, parameter :: num_seg_max=5
1967 : real (kind=r8), dimension(0:7 , imin:imax,imin:imax,num_sides), intent(inout) :: displ
1968 : integer (kind=r8), dimension(1:2,11 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vec
1969 : real (kind=r8), dimension(1:2, 6 , imin:imax,imin:imax,num_sides), intent(inout) :: base_vtx
1970 :
1971 : real(KIND=r8), dimension(2,num_seg_max,num_area), intent(inout) :: x, dx, x_static, dx_static
1972 : integer, dimension(num_area), intent(inout) :: num_seg, num_seg_static
1973 : real(KIND=r8), dimension(2,8), intent(inout) :: x_start, dgam_vec
1974 : real(KIND=r8) , intent(in ) :: se_flux_center
1975 : real(KIND=r8), optional, intent(out) :: displ_first_guess
1976 :
1977 : real (kind=r8) , dimension(2,3) :: xdep !departure points
1978 : real (kind=r8) :: gamma
1979 : integer :: iarea
1980 : !
1981 : ! xdep(2)
1982 : ! ______X______
1983 : ! || / \ ||
1984 : ! || *--/ \--* ||
1985 : ! || /xdep(1) xdep(3)\ ||
1986 : ! ||/ \||
1987 : ! ========================================
1988 : ! || ||
1989 : !
1990 : !
1991 : ! compute departure points (xdep(1) is left; xdep(3) is right and xdep(2) is midway
1992 : !
1993 :
1994 : xdep(:,1) = base_vtx(:,1,i,j,iside)+&
1995 39560784 : displ(0,i,j,iside)*base_vec(:,1,i,j,iside)+displ(3,i,j,iside)*base_vec(:,3,i,j,iside)
1996 : xdep(:,3) = base_vtx(:,2,i,j,iside)+&
1997 39560784 : displ(1,i,j,iside)*base_vec(:,1,i,j,iside)+displ(2,i,j,iside)*base_vec(:,2,i,j,iside)
1998 39560784 : xdep(:,2) = 0.5_r8*(xdep(:,1)+xdep(:,3))
1999 :
2000 13186928 : gamma= se_flux_center
2001 : x_start(:,1) = ABS(base_vec(:,3,i,j,iside))*((xdep(:,2)-base_vtx(:,1,i,j,iside)))+&
2002 39560784 : base_vtx(:,1,i,j,iside) !xdep(2) - midway between departure points projected to side 1
2003 :
2004 39560784 : dgam_vec(:,1) = gamma*base_vec(:,1,i,j,iside)
2005 :
2006 13186928 : if (present(displ_first_guess)) displ_first_guess = gamma
2007 :
2008 39560784 : xdep(:,2) = x_start(:,1)+dgam_vec(:,1)
2009 13186928 : iarea = 3
2010 13186928 : num_seg (iarea) = 2
2011 13186928 : num_seg_static(iarea) = 3
2012 :
2013 : ! ______X______
2014 : ! || 2 / \ 3 ||
2015 : ! || *--/ \--* ||
2016 : ! || / \ ||
2017 : ! ||/ 1 5 4\||
2018 : ! ========================================
2019 : ! || ||
2020 : !
2021 39560784 : x_static (:,1,iarea) = base_vtx(:,1,i,j,iside) !static - line 1
2022 39560784 : dx_static(:,1,iarea) = xdep(:,1)-x_static(:,1,iarea) !static - line 1
2023 :
2024 39560784 : x (:,1,iarea) = xdep(:,1) !static - line 2
2025 39560784 : dx (:,1,iarea) = xdep(:,2)-x(:,1,iarea) !dynamic - line 2
2026 :
2027 39560784 : x (:,2,iarea) = xdep(:,2) !dynamic - line 3
2028 39560784 : dx (:,2,iarea) = xdep(:,3)-x(:,2,iarea) !dynamic - line 3
2029 :
2030 39560784 : x_static (:,2,iarea) = xdep(:,3) !static - line 4
2031 39560784 : dx_static(:,2,iarea) = base_vtx(:,2,i,j,iside)-x_static(:,2,iarea)!static - line 4
2032 :
2033 39560784 : x_static (:,3,iarea) = base_vtx(:,2,i,j,iside) !static - line 5
2034 39560784 : dx_static(:,3,iarea) = base_vtx(:,1,i,j,iside)-base_vtx(:,2,i,j,iside) !static - line 5
2035 :
2036 13186928 : end subroutine define_area3_center
2037 : end module fvm_consistent_se_cslam
|