25 use fv_mp_nlm_mod,
only: start_group_halo_update, complete_group_halo_update
47 subroutine tracer_2d_1l(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, &
48 nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, dpA)
51 integer,
intent(IN) :: npx
52 integer,
intent(IN) :: npy
53 integer,
intent(IN) :: npz
54 integer,
intent(IN) :: nq
55 integer,
intent(IN) :: hord, nord_tr
56 integer,
intent(IN) :: q_split
57 integer,
intent(IN) :: id_divg
58 real ,
intent(IN) :: dt, trdm
59 type(group_halo_update_type),
intent(inout) :: q_pack
60 real ,
intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq)
61 real ,
intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
62 real ,
intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz)
63 real ,
intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz)
64 real ,
intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
65 real ,
intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz)
66 real ,
optional,
intent(OUT) :: dpa(bd%is:bd%ie,bd%js:bd%je)
68 type(
domain2d),
intent(INOUT) :: domain
71 real :: qn2(bd%isd:bd%ied,bd%jsd:bd%jed,nq)
72 real :: dp2(bd%is:bd%ie,bd%js:bd%je)
73 real :: fx(bd%is:bd%ie+1,bd%js:bd%je )
74 real :: fy(bd%is:bd%ie , bd%js:bd%je+1)
75 real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed)
76 real :: ra_y(bd%isd:bd%ied,bd%js:bd%je)
77 real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
78 real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz)
82 integer :: i,j,k,it,iq
84 real,
pointer,
dimension(:,:) :: area, rarea
85 real,
pointer,
dimension(:,:,:) :: sin_sg
86 real,
pointer,
dimension(:,:) :: dxa, dya, dx, dy
88 integer :: is, ie, js, je
89 integer :: isd, ied, jsd, jed
100 area => gridstruct%area
101 rarea => gridstruct%rarea
103 sin_sg => gridstruct%sin_sg
104 dxa => gridstruct%dxa
105 dya => gridstruct%dya
114 if (cx(i,j,k) > 0.)
then 115 xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3)
117 xfx(i,j,k) = cx(i,j,k)*dxa(i, j)*dy(i,j)*sin_sg(i, j,1)
123 if (cy(i,j,k) > 0.)
then 124 yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4)
126 yfx(i,j,k) = cy(i,j,k)*dya(i,j )*dx(i,j)*sin_sg(i,j, 2)
132 if ( k < npz/6 )
then 135 cmax(k) =
max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) )
141 cmax(k) =
max( cmax(k),
max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) )
147 call mp_reduce_max(cmax,npz)
154 nsplt = int(1. + cmax(k))
155 if ( nsplt > 1 )
then 156 frac = 1. /
real(nsplt)
159 cx(i,j,k) = cx(i,j,k) * frac
160 xfx(i,j,k) = xfx(i,j,k) * frac
165 mfx(i,j,k) = mfx(i,j,k) * frac
170 cy(i,j,k) = cy(i,j,k) * frac
171 yfx(i,j,k) = yfx(i,j,k) * frac
176 mfy(i,j,k) = mfy(i,j,k) * frac
184 call complete_group_halo_update(q_pack, domain)
194 ra_x(i,j) = area(i,j) + (xfx(i,j,k) - xfx(i+1,j,k))
196 if ( j>=js .and. j<=je )
then 198 ra_y(i,j) = area(i,j) + (yfx(i,j,k) - yfx(i,j+1,k))
203 nsplt = int(1. + cmax(k))
209 dp2(i,j) = dp1(i,j,k) + ((mfx(i,j,k)-mfx(i+1,j,k))+(mfy(i,j,k)-mfy(i,j+1,k)))*rarea(i,j)
217 if ( nsplt /= 1 )
then 221 qn2(i,j,iq) = q(i,j,k,iq)
225 call fv_tp_2d(qn2(isd,jsd,iq), cx(is,jsd,k), cy(isd,js,k), &
226 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
227 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k))
228 if ( it < nsplt )
then 231 qn2(i,j,iq) = (qn2(i,j,iq)*dp1(i,j,k)+((fx(i,j)-fx(i+1,j))+(fy(i,j)-fy(i,j+1)))*rarea(i,j))/dp2(i,j)
237 q(i,j,k,iq) = (qn2(i,j,iq)*dp1(i,j,k)+((fx(i,j)-fx(i+1,j))+(fy(i,j)-fy(i,j+1)))*rarea(i,j))/dp2(i,j)
242 call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
243 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
244 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k))
247 q(i,j,k,iq) = (q(i,j,k,iq)*dp1(i,j,k)+((fx(i,j)-fx(i+1,j))+(fy(i,j)-fy(i,j+1)))*rarea(i,j))/dp2(i,j)
253 if ( it < nsplt )
then 256 dp1(i,j,k) = dp2(i,j)
268 if (
present(dpa))
then 275 subroutine tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, &
276 nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, dpA)
279 integer,
intent(IN) :: npx
280 integer,
intent(IN) :: npy
281 integer,
intent(IN) :: npz
282 integer,
intent(IN) :: nq
283 integer,
intent(IN) :: hord, nord_tr
284 integer,
intent(IN) :: q_split
285 integer,
intent(IN) :: id_divg
286 real ,
intent(IN) :: dt, trdm
287 type(group_halo_update_type),
intent(inout) :: q_pack
288 real ,
intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq)
289 real ,
intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
290 real ,
intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz)
291 real ,
intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz)
292 real ,
intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
293 real ,
intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz)
294 real ,
optional,
intent(OUT) :: dpa(bd%is:bd%ie,bd%js:bd%je,npz)
296 type(
domain2d),
intent(INOUT) :: domain
299 real :: dp2(bd%is:bd%ie,bd%js:bd%je)
300 real :: fx(bd%is:bd%ie+1,bd%js:bd%je )
301 real :: fy(bd%is:bd%ie , bd%js:bd%je+1)
302 real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed)
303 real :: ra_y(bd%isd:bd%ied,bd%js:bd%je)
304 real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
305 real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz)
309 integer :: ksplt(npz)
311 integer :: i,j,k,it,iq
313 real,
pointer,
dimension(:,:) :: area, rarea
314 real,
pointer,
dimension(:,:,:) :: sin_sg
315 real,
pointer,
dimension(:,:) :: dxa, dya, dx, dy
317 integer :: is, ie, js, je
318 integer :: isd, ied, jsd, jed
329 area => gridstruct%area
330 rarea => gridstruct%rarea
332 sin_sg => gridstruct%sin_sg
333 dxa => gridstruct%dxa
334 dya => gridstruct%dya
343 if (cx(i,j,k) > 0.)
then 344 xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3)
346 xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1)
352 if (cy(i,j,k) > 0.)
then 353 yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4)
355 yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2)
360 if ( q_split == 0 )
then 362 if ( k < npz/6 )
then 365 cmax(k) =
max( cmax(k), abs(cx(i,j,k)), abs(cy(i,j,k)) )
371 cmax(k) =
max( cmax(k),
max(abs(cx(i,j,k)),abs(cy(i,j,k)))+1.-sin_sg(i,j,5) )
383 if ( q_split == 0 )
then 384 call mp_reduce_max(cmax,npz)
389 c_global =
max(cmax(k), c_global)
392 nsplt = int(1. + c_global)
393 if ( is_master() .and. nsplt > 4 )
write(*,*)
'Tracer_2d_split=', nsplt, c_global
400 if( nsplt /= 1 )
then 408 ksplt(k) = int(1. + cmax(k))
410 frac = 1. /
real(ksplt(k))
414 cx(i,j,k) = cx(i,j,k) * frac
415 xfx(i,j,k) = xfx(i,j,k) * frac
420 mfx(i,j,k) = mfx(i,j,k) * frac
426 cy(i,j,k) = cy(i,j,k) * frac
427 yfx(i,j,k) = yfx(i,j,k) * frac
432 mfy(i,j,k) = mfy(i,j,k) * frac
442 call complete_group_halo_update(q_pack, domain)
451 if ( it .le. ksplt(k) )
then 455 dp2(i,j) = dp1(i,j,k) + ((mfx(i,j,k)-mfx(i+1,j,k))+(mfy(i,j,k)-mfy(i,j+1,k)))*rarea(i,j)
461 ra_x(i,j) = area(i,j) + (xfx(i,j,k) - xfx(i+1,j,k))
466 ra_y(i,j) = area(i,j) + (yfx(i,j,k) - yfx(i,j+1,k))
471 if ( it==1 .and. trdm>1.e-4 )
then 472 call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
473 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
474 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k), &
475 mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm)
477 call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
478 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
479 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k))
483 q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + &
484 ((fx(i,j)-fx(i+1,j))+(fy(i,j)-fy(i,j+1)))*rarea(i,j) )/dp2(i,j)
489 if ( it /= nsplt )
then 492 dp1(i,j,k) = dp2(i,j)
501 if ( it /= nsplt )
then 504 call start_group_halo_update(q_pack, q, domain)
512 if (
present(dpa))
then 513 dpa=dp1(bd%is:bd%ie,bd%js:bd%je,1:npz)
518 subroutine tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, &
519 nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, &
520 k_split, neststruct, parent_grid)
523 integer,
intent(IN) :: npx
524 integer,
intent(IN) :: npy
525 integer,
intent(IN) :: npz
526 integer,
intent(IN) :: nq
527 integer,
intent(IN) :: hord, nord_tr
528 integer,
intent(IN) :: q_split, k_split
529 integer,
intent(IN) :: id_divg
530 real ,
intent(IN) :: dt, trdm
531 type(group_halo_update_type),
intent(inout) :: q_pack
532 real ,
intent(INOUT) :: q(bd%isd:bd%ied,bd%jsd:bd%jed,npz,nq)
533 real ,
intent(INOUT) :: dp1(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
534 real ,
intent(INOUT) :: mfx(bd%is:bd%ie+1,bd%js:bd%je, npz)
535 real ,
intent(INOUT) :: mfy(bd%is:bd%ie ,bd%js:bd%je+1,npz)
536 real ,
intent(INOUT) :: cx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
537 real ,
intent(INOUT) :: cy(bd%isd:bd%ied,bd%js :bd%je +1,npz)
541 type(
domain2d),
intent(INOUT) :: domain
544 real :: dp2(bd%is:bd%ie,bd%js:bd%je)
545 real :: fx(bd%is:bd%ie+1,bd%js:bd%je )
546 real :: fy(bd%is:bd%ie , bd%js:bd%je+1)
547 real :: ra_x(bd%is:bd%ie,bd%jsd:bd%jed)
548 real :: ra_y(bd%isd:bd%ied,bd%js:bd%je)
549 real :: xfx(bd%is:bd%ie+1,bd%jsd:bd%jed ,npz)
550 real :: yfx(bd%isd:bd%ied,bd%js: bd%je+1, npz)
555 integer :: nsplt, nsplt_parent, msg_split_steps = 1
556 integer :: i,j,k,it,iq
558 real,
pointer,
dimension(:,:) :: area, rarea
559 real,
pointer,
dimension(:,:,:) :: sin_sg
560 real,
pointer,
dimension(:,:) :: dxa, dya, dx, dy
562 integer :: is, ie, js, je
563 integer :: isd, ied, jsd, jed
574 area => gridstruct%area
575 rarea => gridstruct%rarea
577 sin_sg => gridstruct%sin_sg
578 dxa => gridstruct%dxa
579 dya => gridstruct%dya
588 if (cx(i,j,k) > 0.)
then 589 xfx(i,j,k) = cx(i,j,k)*dxa(i-1,j)*dy(i,j)*sin_sg(i-1,j,3)
591 xfx(i,j,k) = cx(i,j,k)*dxa(i,j)*dy(i,j)*sin_sg(i,j,1)
597 if (cy(i,j,k) > 0.)
then 598 yfx(i,j,k) = cy(i,j,k)*dya(i,j-1)*dx(i,j)*sin_sg(i,j-1,4)
600 yfx(i,j,k) = cy(i,j,k)*dya(i,j)*dx(i,j)*sin_sg(i,j,2)
607 if ( q_split == 0 )
then 618 cmax_t =
max( abs(cx(i,j,k)), abs(cy(i,j,k)) )
619 cmax(k) =
max( cmax_t, cmax(k) )
625 cmax_t =
max(abs(cx(i,j,k)), abs(cy(i,j,k))) + 1.-sin_sg(i,j,5)
626 cmax(k) =
max( cmax_t, cmax(k) )
631 call mp_reduce_max(cmax,npz)
637 c_global =
max(cmax(k), c_global)
640 nsplt = int(1. + c_global)
641 if ( is_master() .and. nsplt > 3 )
write(*,*)
'Tracer_2d_split=', nsplt, c_global
644 if (gridstruct%nested .and. neststruct%nestbctype > 1) msg_split_steps =
max(q_split/parent_grid%flagstruct%q_split,1)
649 frac = 1. /
real(nsplt)
651 if( nsplt /= 1 )
then 656 cx(i,j,k) = cx(i,j,k) * frac
657 xfx(i,j,k) = xfx(i,j,k) * frac
662 mfx(i,j,k) = mfx(i,j,k) * frac
668 cy(i,j,k) = cy(i,j,k) * frac
669 yfx(i,j,k) = yfx(i,j,k) * frac
675 mfy(i,j,k) = mfy(i,j,k) * frac
683 if ( gridstruct%nested )
then 684 neststruct%tracer_nest_timestep = neststruct%tracer_nest_timestep + 1
688 call complete_group_halo_update(q_pack, domain)
692 if (gridstruct%nested)
then 695 0, 0, npx, npy, npz, bd, &
696 real(neststruct%tracer_nest_timestep)+
real(nsplt*k_split),
real(nsplt*k_split), &
697 neststruct%q_bc(iq), bctype=neststruct%nestbctype )
709 dp2(i,j) = dp1(i,j,k) + ((mfx(i,j,k)-mfx(i+1,j,k))+(mfy(i,j,k)-mfy(i,j+1,k)))*rarea(i,j)
715 ra_x(i,j) = area(i,j) + (xfx(i,j,k) - xfx(i+1,j,k))
720 ra_y(i,j) = area(i,j) + (yfx(i,j,k) - yfx(i,j+1,k))
725 if ( it==1 .and. trdm>1.e-4 )
then 726 call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
727 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
728 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k), &
729 mass=dp1(isd,jsd,k), nord=nord_tr, damp_c=trdm)
731 call fv_tp_2d(q(isd,jsd,k,iq), cx(is,jsd,k), cy(isd,js,k), &
732 npx, npy, hord, fx, fy, xfx(is,jsd,k), yfx(isd,js,k), &
733 gridstruct, bd, ra_x, ra_y, mfx=mfx(is,js,k), mfy=mfy(is,js,k))
737 q(i,j,k,iq) = ( q(i,j,k,iq)*dp1(i,j,k) + &
738 ((fx(i,j)-fx(i+1,j))+(fy(i,j)-fy(i,j+1)))*rarea(i,j) )/dp2(i,j)
744 if ( it /= nsplt )
then 747 call start_group_halo_update(q_pack, q, domain)
752 if ( gridstruct%nested )
then 757 0, 0, npx, npy, npz, bd, &
758 real(neststruct%tracer_nest_timestep),
real(nsplt*k_split), &
759 neststruct%q_bc(iq), bctype=neststruct%nestbctype )
767 if ( id_divg > 0 )
then 774 dp1(i,j,k) = ((xfx(i+1,j,k)-xfx(i,j,k)) + (yfx(i,j+1,k)-yfx(i,j,k)))*rarea(i,j)*rdt
783 gridstruct, flagstruct, bd, domain, &
784 ak, bk, ptop, npx, npy, npz, &
785 nq, hord, kord, q_split, k_split, dt, z_tracer, fill)
790 integer,
intent(IN) :: npx
791 integer,
intent(IN) :: npy
792 integer,
intent(IN) :: npz
793 integer,
intent(IN) :: nq
794 integer,
intent(IN) :: hord
795 integer,
intent(IN) :: kord
796 integer,
intent(IN) :: q_split
797 integer,
intent(IN) :: k_split
798 logical,
intent(IN) :: z_tracer
799 logical,
intent(IN) :: fill
803 type(
domain2d),
intent(INOUT) :: domain
805 real,
intent(IN ) :: dt
806 real,
intent(IN ) ::ple0(bd%is:bd%ie,bd%js:bd%je,npz+1)
807 real,
intent(INOUT) ::ple1(bd%is:bd%ie,bd%js:bd%je,npz+1)
808 real,
intent(IN ) :: cx(bd%is:bd%ie,bd%js:bd%je,npz)
809 real,
intent(IN ) :: cy(bd%is:bd%ie,bd%js:bd%je,npz)
810 real,
intent(IN ) :: mfx(bd%is:bd%ie,bd%js:bd%je,npz)
811 real,
intent(IN ) :: mfy(bd%is:bd%ie,bd%js:bd%je,npz)
812 real,
intent(INOUT) :: q(bd%is:bd%ie,bd%js:bd%je,npz,nq)
813 real,
intent(IN ) :: ak(npz+1)
814 real,
intent(IN ) :: bk(npz+1)
815 real,
intent(IN ) :: ptop
817 real :: xl(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
818 real :: yl(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
819 real :: cxl(bd%is :bd%ie +1,bd%jsd:bd%jed ,npz)
820 real :: cyl(bd%isd:bd%ied ,bd%js :bd%je +1,npz)
821 real :: mfxl(bd%is :bd%ie +1,bd%js :bd%je ,npz)
822 real :: mfyl(bd%is :bd%ie ,bd%js :bd%je +1,npz)
823 real :: dpl(bd%is :bd%ie ,bd%js :bd%je ,npz)
824 real :: dpa(bd%is :bd%ie ,bd%js :bd%je ,npz)
826 real :: q1(bd%is:bd%ie ,bd%js:bd%je, npz )
827 real :: q2(bd%isd:bd%ied ,bd%jsd:bd%jed ,nq)
828 real :: q3(bd%isd:bd%ied ,bd%jsd:bd%jed, npz,nq)
830 real :: wbuffer(bd%js:bd%je,npz)
831 real :: sbuffer(bd%is:bd%ie,npz)
832 real :: ebuffer(bd%js:bd%je,npz)
833 real :: nbuffer(bd%is:bd%ie,npz)
835 real pe1(bd%is:bd%ie,npz+1)
836 real pe2(bd%is:bd%ie,npz+1)
837 real dp2(bd%is:bd%ie,bd%js:bd%je,npz)
840 integer :: i,j,k,n,iq
842 real :: scalingfactor
844 type(group_halo_update_type),
save :: i_pack
846 integer :: is, ie, js, je
847 integer :: isd, ied, jsd, jed
860 xl(is:ie,js:je,:) = cx(:,:,:)
861 yl(is:ie,js:je,:) = cy(:,:,:)
863 wbufferx=wbuffer, ebufferx=ebuffer, &
864 sbuffery=sbuffer, nbuffery=nbuffer, &
866 xl(ie+1,js:je,:) = ebuffer
867 yl(is:ie,je+1,:) = nbuffer
869 cxl(is:ie+1,jsd:jed,:) = xl(is:ie+1,jsd:jed,:)
870 cyl(isd:ied,js:je+1,:) = yl(isd:ied,js:je+1,:)
873 xl(is:ie,js:je,:) = mfx(:,:,:)
874 yl(is:ie,js:je,:) = mfy(:,:,:)
876 wbufferx=wbuffer, ebufferx=ebuffer, &
877 sbuffery=sbuffer, nbuffery=nbuffer, &
879 xl(ie+1,js:je,:) = ebuffer
880 yl(is:ie,je+1,:) = nbuffer
881 mfxl(is:ie+1,js:je,:) = xl(is:ie+1,js:je,:)
882 mfyl(is:ie,js:je+1,:) = yl(is:ie,js:je+1,:)
885 dpl(:,:,:) = ple0(:,:,2:npz+1) - ple0(:,:,1:npz)
886 q3(is:ie,js:je,:,:) = q(is:ie,js:je,:,:)
894 q2(i,j,iq) = q3(i,j,k,iq)
899 call start_group_halo_update(i_pack, q2, domain)
900 call tracer_2d_1l(q2, dpl(is,js,k), mfxl(is,js,k), mfyl(is,js,k), cxl(is,js,k), cyl(is,js,k), &
901 gridstruct, bd, domain, npx, npy, npz, nq, &
902 flagstruct%hord_tr, q_split, dt, 0, i_pack, &
903 flagstruct%nord_tr, flagstruct%trdm2, dpa=dpa)
907 q3(i,j,k,iq) = q2(i,j,iq)
914 call start_group_halo_update(i_pack, q3, domain)
915 call tracer_2d(q3, dpl, mfxl, mfyl, cxl, cyl, gridstruct, bd, domain, npx, npy, npz, nq, &
916 flagstruct%hord_tr, q_split, dt, 0, i_pack, &
917 flagstruct%nord_tr, flagstruct%trdm2, dpa=dpa)
931 pe1(:,k) = pe1(:,k-1) + dpa(:,j,k-1)
935 pe2(:,npz+1) = pe1(:,npz+1)
937 pe2(: ,k) = ak(k) + bk(k)*pe1(:,npz+1)
940 dp2(:,j,k) = pe2(:,k+1) - pe2(:,k)
942 call map1_q2(npz, pe1, q3(isd,jsd,1,iq), &
943 npz, pe2, q1(:,j,:), dp2(:,j,:), &
944 is, ie, 0, kord, j, &
945 isd, ied, jsd, jed, 0.)
946 if (fill)
call fillz(ie-is+1, npz, 1, q1(:,j,:), dp2(:,j,:))
956 q(is:ie,js:je,1:npz,iq) = q1(is:ie,js:je,1:npz) * scalingfactor
971 function calcscalingfactor(q1, dp2, ple1, npx, npy, npz, gridstruct, bd)
result(scaling)
973 integer,
intent(in) :: npx
974 integer,
intent(in) :: npy
975 integer,
intent(in) :: npz
976 real,
intent(in) :: q1(:,:,:)
977 real,
intent(in) :: dp2(:,:,:)
978 real,
intent(in) :: ple1(:,:,:)
984 real :: partialsums(2,npz), globalsums(2)
985 real,
parameter :: tiny_denominator = tiny(1.0)
995 partialsums(1,k) = sum(q1(:,:,k)*dp2(:,:,k)*gridstruct%area(bd%is:bd%ie,bd%js:bd%je))
997 partialsums(2,k) = sum(q1(:,:,k)*(ple1(:,:,k+1)-ple1(:,:,k))*gridstruct%area(bd%is:bd%ie,bd%js:bd%je))
1000 globalsums(1) = sum(partialsums(1,:))
1001 globalsums(2) = sum(partialsums(2,:))
1005 if (globalsums(2) > tiny_denominator)
then 1006 scaling = globalsums(1) / globalsums(2)
1010 scaling =
REAL(scaling, kind=kind(1.00))
real, dimension(:,:,:), allocatable nest_fx_east_accum
subroutine, public nested_grid_bc_apply_intt(var_nest, istag, jstag, npx, npy, npz, bd, step, split, BC, bctype)
real, dimension(:,:,:), allocatable nest_fx_west_accum
subroutine, public tracer_2d_1l(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, dpA)
real function calcscalingfactor(q1, dp2, ple1, npx, npy, npz, gridstruct, bd)
subroutine, public fillz(im, km, nq, q, dp)
real, dimension(:,:,:), allocatable nest_fx_north_accum
real, dimension(:,:,:), allocatable nest_fx_south_accum
subroutine, public map1_q2(km, pe1, q1, kn, pe2, q2, dp2, i1, i2, iv, kord, j, ibeg, iend, jbeg, jend, q_min)
integer, parameter, public ng
subroutine timing_on(blk_name)
subroutine, public copy_corners(q, npx, npy, dir, nested, bd, sw_corner, se_corner, nw_corner, ne_corner)
subroutine, public offline_tracer_advection(q, ple0, ple1, mfx, mfy, cx, cy, gridstruct, flagstruct, bd, domain, ak, bk, ptop, npx, npy, npz, nq, hord, kord, q_split, k_split, dt, z_tracer, fill)
subroutine, public tracer_2d(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, dpA)
subroutine, public fv_tp_2d(q, crx, cry, npx, npy, hord, fx, fy, xfx, yfx, gridstruct, bd, ra_x, ra_y, mfx, mfy, mass, nord, damp_c)
subroutine timing_off(blk_name)
subroutine, public tracer_2d_nested(q, dp1, mfx, mfy, cx, cy, gridstruct, bd, domain, npx, npy, npz, nq, hord, q_split, dt, id_divg, q_pack, nord_tr, trdm, k_split, neststruct, parent_grid)