diff --git a/Makefile b/Makefile index f41c3432cc..af8a5f2cd6 100644 --- a/Makefile +++ b/Makefile @@ -123,17 +123,17 @@ pgi: "CC_SERIAL = pgcc" \ "CXX_SERIAL = pgc++" \ "FFLAGS_PROMOTION = -r8" \ - "FFLAGS_OPT = -O4 -byteswapio -Mfree" \ + "FFLAGS_OPT = -O4 -gopt -byteswapio -Mfree -Mnosave -Mrecursive -Mstack_arrays -DMPAS_NVTX_RANGES" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ - "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_OPT = -O3 -lnvhpcwrapnvtx" \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback -Mnosave -Mrecursive -DMPAS_NVTX_RANGES" \ "CFLAGS_DEBUG = -O0 -g -traceback" \ "CXXFLAGS_DEBUG = -O0 -g -traceback" \ - "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback -lnvhpcwrapnvtx" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ - "FFLAGS_ACC = -Mnofma -acc -ta=tesla:cc70,cc80 -Minfo=accel" \ + "FFLAGS_ACC = -acc=gpu -Minfo=acc -gpu=lineinfo,ccnative,safecache -cuda" \ "CFLAGS_ACC =" \ "PICFLAG = -fpic" \ "BUILD_TARGET = $(@)" \ diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index f6af318fcb..7c2af26b24 100755 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -132,6 +132,24 @@ module atm_time_integration contains + !----------------------------------------------------------------------- + ! routine MPAS_gang_size + ! + !> \brief Compute the suitable OpenACC gang size + !> \author Dmitry Alexeev + !> \date 3 Sept 2024 + !> \details + !> Compute the OpenACC gang size such that it's multiple of 32 + !> and larger than the given number of levels + ! + !----------------------------------------------------------------------- + function mpas_gang_size(numLevels) + integer, intent(in) :: numLevels + integer :: mpas_gang_size + integer, parameter :: warpSize = 32 + + mpas_gang_size = ((numLevels + warpSize-1) / warpSize) * warpSize + end function mpas_gang_size !----------------------------------------------------------------------- ! routine MPAS_atm_dynamics_init @@ -3181,230 +3199,274 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart real (kind=RKIND), dimension(nCells+1) :: specZoneMaskCell real (kind=RKIND), dimension(nEdges+1) :: specZoneMaskEdge - integer, intent(in) :: small_step - real (kind=RKIND), intent(in) :: dts, epssm, cf1, cf2, cf3 - real (kind=RKIND), dimension(nVertLevels) :: ts, rs - ! ! Local variables ! - integer :: cell1, cell2, iEdge, iCell, i, k + integer :: cell1, cell2, iEdge, iCell, i, k, ichunk, icstart + real (kind=RKIND) :: c2, rcv, rtheta_pp_tmp real (kind=RKIND) :: pgrad, flux, resm, rdts + integer, parameter :: chunk = 16 + real (kind=RKIND), intent(in) :: dts, epssm, cf1, cf2, cf3 + real (kind=RKIND), dimension(nVertLevels) :: ts, rs + real (kind=RKIND), dimension(nVertLevels+1, chunk) :: rs_tile + logical, dimension(chunk) :: process + integer :: gang_size + + gang_size = mpas_gang_size(nVertLevels) rcv = rgas / (cp - rgas) c2 = cp * rcv resm = (1.0 - epssm) / (1.0 + epssm) rdts = 1./dts -!$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, rho_pp, & -!$acc rw_p, wwavg, & -!$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & -!$acc tend_ru, zxu, tend_rho, a_tri, alpha_tri, cofrz, & -!$acc coftz, cofwr, cofwt, cofwz, dss, dvedge, edgesoncell, edgesoncell_sign, & -!$acc fzm, fzp, gamma_tri, invareacell, nedgesoncell, rdzw, rho_zz, rw, & -!$acc rw_save, tend_rho, tend_rt, tend_rw, theta_m, w) + !$acc data present(rtheta_pp, rtheta_pp_old, ru_p, ruavg, rho_pp, & + !$acc rw_p, wwavg, & + !$acc zz, cellsonedge, cqu, dcedge, exner, invdcedge, & + !$acc tend_ru, zxu, tend_rho, a_tri, alpha_tri, cofrz, & + !$acc coftz, cofwr, cofwt, cofwz, dss, dvedge, edgesoncell, edgesoncell_sign, & + !$acc fzm, fzp, gamma_tri, invareacell, nedgesoncell, rdzw, rho_zz, rw, & + !$acc rw_save, tend_rho, tend_rt, tend_rw, theta_m, w) if(small_step /= 1) then ! not needed on first small step -!$acc parallel vector_length(32) -!$acc loop gang - do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + !$acc parallel vector_length(gang_size) + !$acc loop gang + do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - ! update edges for block-owned cells - if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) - pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad - pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - (1.0_RKIND - specZoneMaskEdge(iEdge))*pgrad) - end do + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - ! accumulate ru_p for use later in scalar transport -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) - end do + ! update edges for block-owned cells + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1,nVertLevels + pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) + pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad + pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - (1.0_RKIND - specZoneMaskEdge(iEdge))*pgrad) + end do + ! accumulate ru_p for use later in scalar transport + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1,nVertLevels + ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) + end do end if ! end test for block-owned cells - end do ! end loop over edges -!$acc end parallel - end if + end do ! end loop over edges + !$acc end parallel - if(small_step ==1) then -! else ! this is all that us needed for ru_p update for first acoustic step in RK substep -!$acc parallel vector_length(32) -!$acc loop gang - do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? + end if - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) + if(small_step ==1) then + ! this is all that us needed for ru_p update for first acoustic step in RK substep - ! update edges for block-owned cells - if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - ru_p(k,iEdge) = dts*tend_ru(k,iEdge) - end do -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels -!! ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) - ruAvg(k,iEdge) = ru_p(k,iEdge) - end do + ! + !$acc parallel vector_length(gang_size) + !$acc loop gang + do iEdge=edgeStart,edgeEnd ! MGD do we really just need edges touching owned cells? - end if ! end test for block-owned cells + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) - end do ! end loop over edges -!$acc end parallel + ! update edges for block-owned cells + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1,nVertLevels + ru_p(k,iEdge) = dts*tend_ru(k,iEdge) + end do + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1,nVertLevels + !! ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge) + ruAvg(k,iEdge) = ru_p(k,iEdge) + end do + + end if ! end test for block-owned cells + + end do ! end loop over edges + !$acc end parallel end if ! test for first acoustic step !$OMP BARRIER if (small_step == 1) then ! initialize here on first small timestep. -!$acc parallel vector_length(32) -!$acc loop gang vector - do iCell=cellStart,cellEnd - rtheta_pp_old(1:nVertLevels,iCell) = 0.0 - end do -!$acc end parallel + !$acc kernels + rtheta_pp_old(1:nVertLevels,cellStart:cellEnd) = 0.0 + !$acc end kernels else -!$acc parallel vector_length(32) -!$acc loop gang vector - do iCell=cellStart,cellEnd - rtheta_pp_old(1:nVertLevels,iCell) = rtheta_pp(1:nVertLevels,iCell) - end do -!$acc end parallel + !$acc kernels + rtheta_pp_old(1:nVertLevels,cellStart:cellEnd) = rtheta_pp(1:nVertLevels,cellStart:cellEnd) + !$acc end kernels end if -!!!OMP BARRIER -- not needed, since rtheta_pp_old not used below when small_step == 1 -!$acc parallel vector_length(32) -!$acc loop gang private(ts, rs) + !$acc parallel vector_length(gang_size) + !$acc loop gang(static:2) private(ts, rs) do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve -!!$acc cache(ts) -!!$acc cache(rs) - + !$acc cache(ts, rs) + if(small_step == 1) then ! initialize here on first small timestep. - wwAvg(1:nVertLevels+1,iCell) = 0.0 - rho_pp(1:nVertLevels,iCell) = 0.0 - rtheta_pp(1:nVertLevels,iCell) = 0.0 -!MGD moved to loop above over all cells -! rtheta_pp_old(1:nVertLevels,iCell) = 0.0 - rw_p(:,iCell) = 0.0 + !$acc loop vector shortloop + do k=1,nVertLevels + wwAvg (k,iCell) = 0.0 + rho_pp (k,iCell) = 0.0 + rtheta_pp(k,iCell) = 0.0 + rw_p (k,iCell) = 0.0 + end do + wwAvg(nVertLevels+1,iCell) = 0.0 + rw_p (nVertLevels+1,iCell) = 0.0 end if - - if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... -!$acc loop vector + if(specZoneMaskCell(iCell) /= 0.0) continue + + !$acc loop vector shortloop do k=1,nVertLevels ts(k) = 0.0 rs(k) = 0.0 end do -!$acc loop seq - + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP -!$acc loop vector + !DIR$ IVDEP + !$acc loop vector private(flux) shortloop do k=1,nVertLevels flux = edgesOnCell_sign(i,iCell)*dts*dvEdge(iEdge)*ru_p(k,iEdge) * invAreaCell(iCell) rs(k) = rs(k)-flux ts(k) = ts(k)-flux*0.5*(theta_m(k,cell2)+theta_m(k,cell1)) end do end do - ! vertically implicit acoustic and gravity wave integration. - ! this follows Klemp et al MWR 2007, with the addition of an implicit Rayleigh damping of w - ! serves as a gravity-wave absorbing layer, from Klemp et al 2008. -!DIR$ IVDEP -!$acc loop vector + ! vertically implicit acoustic and gravity wave integration. + ! this follows Klemp et al MWR 2007, with the addition of an implicit Rayleigh damping of w + ! serves as a gravity-wave absorbing layer, from Klemp et al 2008. + + !DIR$ IVDEP + !$acc loop vector shortloop do k=1, nVertLevels rs(k) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k) & - - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) + - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell)) ts(k) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k) & - - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k,iCell)*rw_p(k,iCell)) + - resm*rdzw(k)*( coftz(k+1,iCell)*rw_p(k+1,iCell) & + -coftz(k,iCell)*rw_p(k,iCell)) end do -!DIR$ IVDEP -!$acc loop vector + !DIR$ IVDEP + !$acc loop vector shortloop do k=2, nVertLevels wwavg(k,iCell) = wwavg(k,iCell) + 0.5*(1.0-epssm)*rw_p(k,iCell) - end do -!DIR$ IVDEP -!$acc loop vector - do k=2, nVertLevels rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) & - - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & - -zz(k-1,iCell)*ts(k-1)) & - +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & - -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & - - cofwr(k,iCell)*((rs(k)+rs(k-1)) & - +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & - + cofwt(k ,iCell)*(ts(k)+resm*rtheta_pp(k ,iCell)) & - + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) + - cofwz(k,iCell)*((zz(k ,iCell)*ts(k) & + -zz(k-1,iCell)*ts(k-1)) & + +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) & + -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) & + - cofwr(k,iCell)*((rs(k)+rs(k-1)) & + +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) & + + cofwt(k ,iCell)*(ts(k )+resm*rtheta_pp(k ,iCell)) & + + cofwt(k-1,iCell)*(ts(k-1)+resm*rtheta_pp(k-1,iCell)) end do - ! tridiagonal solve sweeping up and then down the column + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1, nVertLevels + rho_pp (k,iCell) = rs(k) + rtheta_pp(k,iCell) = ts(k) + end do -!MGD VECTOR DEPENDENCE -!$acc loop seq - do k=2,nVertLevels - rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell) + end do + !$acc end parallel + + + ! Gang size of 64 is optimal here regardless of the number of levels + ! The last vector loop over nVertLevels therefore is not a "shortloop" + ! + !$acc parallel vector_length(64) + !$acc loop gang(static:2) private(rs_tile, process) + do icstart=cellSolveStart,cellSolveEnd, chunk + !$acc cache(rs_tile, process) + + !$acc loop vector shortloop + do ichunk=1, chunk + iCell = ichunk + icstart-1 + if (iCell > cellSolveEnd) continue + process(ichunk) = specZoneMaskCell(iCell) == 0.0 end do -!MGD VECTOR DEPENDENCE -!$acc loop seq - do k=nVertLevels,1,-1 - rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell) + !$acc loop vector shortloop + do ichunk=1, chunk + iCell = ichunk + icstart-1 + + rs_tile(1,ichunk) = rw_p(1,iCell) + !$acc loop seq + do k=2,nVertLevels + if (process(ichunk)) rs_tile(k,ichunk) = (rw_p(k,iCell)-a_tri(k,iCell)*rs_tile(k-1,ichunk))*alpha_tri(k,iCell) + end do + + rs_tile(nVertLevels+1,ichunk) = rw_p(nVertLevels+1,iCell) + !$acc loop seq + do k=nVertLevels,1,-1 + if (process(ichunk)) rs_tile(k,ichunk) = rs_tile(k,ichunk) - gamma_tri(k,iCell)*rs_tile(k+1,ichunk) + end do + end do + + !$acc loop seq + do ichunk=1, chunk + iCell = ichunk + icstart-1 + !$acc loop vector + do k=1,nVertLevels + if (process(ichunk)) rw_p(k,iCell) = rs_tile(k, ichunk) + end do end do + end do + !$acc end parallel + !$acc parallel loop gang(static:2) vector_length(gang_size) + do iCell=cellSolveStart,cellSolveEnd ! the implicit Rayleigh damping on w (gravity-wave absorbing) -!DIR$ IVDEP -!$acc loop vector - do k=2,nVertLevels - rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k ,iCell) - rw(k ,iCell)) -dts*dss(k,iCell)* & - (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) & - *(fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) & - *w(k,iCell) )/(1.0+dts*dss(k,iCell)) & - - (rw_save(k ,iCell) - rw(k ,iCell)) - end do - ! accumulate (rho*omega)' for use later in scalar transport -!DIR$ IVDEP -!$acc loop vector - do k=2,nVertLevels - wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) - end do + if(specZoneMaskCell(iCell) == 0.0) then - ! update rho_pp and theta_pp given updated rw_p -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - rho_pp(k,iCell) = rs(k) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) - rtheta_pp(k,iCell) = ts(k) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & - -coftz(k ,iCell)*rw_p(k ,iCell)) - end do + !DIR$ IVDEP + !$acc loop vector shortloop + do k=2,nVertLevels + rw_p(k,iCell) = (rw_p(k,iCell) + (rw_save(k ,iCell) - rw(k ,iCell)) -dts*dss(k,iCell)* & + (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) & + *(fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) & + *w(k,iCell) )/(1.0+dts*dss(k,iCell)) & + - (rw_save(k ,iCell) - rw(k ,iCell)) + end do + + ! accumulate (rho*omega)' for use later in scalar transport + !DIR$ IVDEP + !$acc loop vector shortloop + do k=2,nVertLevels + wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + end do + + ! update rho_pp and theta_pp given updated rw_p + !DIR$ IVDEP + !$acc loop vector shortloop + do k=1,nVertLevels + rho_pp(k,iCell) = rho_pp(k,iCell) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell)) + rtheta_pp(k,iCell) = rtheta_pp(k,iCell) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) & + -coftz(k ,iCell)*rw_p(k ,iCell)) + end do else ! specifed zone in regional_MPAS + !$acc loop vector shortloop do k=1,nVertLevels rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) @@ -3413,10 +3475,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do end if - end do ! end of loop over cells -!$acc end parallel -!$acc end data + !$acc end parallel + + !$acc end data end subroutine atm_advance_acoustic_step_work subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart, edgeEnd ) @@ -5616,7 +5678,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: scalar_weight real (kind=RKIND) :: inv_r_earth - real (kind=RKIND) :: invDt, flux, workpv, tendk + real (kind=RKIND) :: invDt, flux, workpv real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 @@ -5693,11 +5755,11 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm kdiff(k,iCell) = min((c_s * config_len_disp)**2 * sqrt(d_diag(k)**2 + d_off_diag(k)**2),(0.01*config_len_disp**2) * invDt) end do end do +!$acc end parallel h_mom_eddy_visc4 = config_visc4_2dsmag * config_len_disp**3 h_theta_eddy_visc4 = h_mom_eddy_visc4 -!$acc end parallel end if ! else @@ -6668,7 +6730,7 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels real (kind=RKIND), dimension(nVertLevels,nCells+1) :: t_init real (kind=RKIND) :: cf1, cf2, cf3 - real (kind=RKIND) :: prandtl_inv, r_areaCell, rgas_cprcv + real (kind=RKIND) :: r_areaCell, rgas_cprcv real (kind=RKIND) :: r_earth real (kind=RKIND), dimension(nVertLevels,nCells+1) :: ur_cell @@ -6699,101 +6761,75 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - ! ! Local variables ! integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq, iAdvCell - !real (kind=RKIND), parameter :: c_s = 0.125 - real (kind=RKIND), dimension( 64 ) :: d_diag, d_off_diag,flux_arr1, flux_arr, ru_edge_w, ru_save_temp , tend_wk, delsq_wk, wduz, wdwz, wdtz, we_w, u_mix, h_wk + real (kind=RKIND), dimension( 64 ) :: flux_arr, ru_edge_w, ru_save_temp, tend_wk, wduz, wdwz, wdtz + real (kind=RKIND) :: tend_ws, ru_edge_ws, flux_ws, tend_us, ru_edge_us, flux_us, h_ws integer, dimension(15) :: iadv_cell_w - integer, dimension(64) :: eoe_w + integer :: iadv_cell_s real (kind=RKIND), dimension(15) :: coefs_w, coefs_3rd_w - real (kind=RKIND), dimension( nVertLevels + 1 ) :: dpzx - real (kind=RKIND) :: theta_turb_flux, w_turb_flux, r - real (kind=RKIND) :: scalar_weight - real (kind=RKIND) :: inv_r_earth - - real (kind=RKIND) :: invDt, flux, workpv, tendk - real (kind=RKIND) :: edge_sign, pr_scale, r_dc, r_dv, u_mix_scale - real (kind=RKIND) :: h_mom_eddy_visc4, v_mom_eddy_visc2 - real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 - real (kind=RKIND) :: u_diffusion, t_w, q1, q2 - - real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND) :: coefs_s, coefs_3rd_s + real (kind=RKIND) :: scalar_weight, workpv, edge_sign + real (kind=RKIND) :: t_w, q1, q2 + ! Lambda functions real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 flux4(q_im2, q_im1, q_i, q_ip1, ua) = & - ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 + ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) ) * 0.08333333333333333 flux3(q_im2, q_im1, q_i, q_ip1, ua, coef3) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & - coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 + coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) * 0.08333333333333333 - prandtl_inv = 1.0_RKIND / prandtl - invDt = 1.0_RKIND / dt - inv_r_earth = 1.0_RKIND / r_earth - v_mom_eddy_visc2 = config_v_mom_eddy_visc2 - v_theta_eddy_visc2 = config_v_theta_eddy_visc2 - -!$acc data present(cellsonedge,dvedge,edgesoncell, & -!$acc tend_ru_physics, & -!$acc tend_rtheta_physics, & -!$acc edgesoncell_sign,fzm,fzp,invareacell,nedgesoncell & -!$acc ,ru,rw,u,edgesonedge, & -!$acc invdcedge,ke,nedgesonedge, & -!$acc pv_edge,rdzw,rho_edge, & -!$acc weightsonedge,adv_coefs,adv_coefs_3rd,advcellsforedge, & -!$acc w,rdzu, tend_w_euler, & -!$acc theta_m,ru_save,theta_m_save,tend_u_euler, & -!$acc nadvcellsforedge,rho_zz, & -!$acc rt_diabatic_tend,rw_save, & -!$acc tend_theta_euler, & -!$acc h_divergence,tend_u, & -!$acc tend_theta,tend_w,& -!$acc tend_rtheta_adv, rthdynten) - - + !$acc data present(cellsonedge,dvedge,edgesoncell, & + !$acc tend_ru_physics, & + !$acc tend_rtheta_physics, & + !$acc edgesoncell_sign,fzm,fzp,invareacell,nedgesoncell & + !$acc ,ru,rw,u,edgesonedge, & + !$acc invdcedge,ke,nedgesonedge, & + !$acc pv_edge,rdzw,rho_edge, & + !$acc weightsonedge,adv_coefs,adv_coefs_3rd,advcellsforedge, & + !$acc w,rdzu, tend_w_euler, & + !$acc theta_m,ru_save,theta_m_save,tend_u_euler, & + !$acc nadvcellsforedge,rho_zz, & + !$acc rt_diabatic_tend,rw_save, & + !$acc tend_theta_euler, & + !$acc h_divergence,tend_u, & + !$acc tend_theta,tend_w,& + !$acc tend_rtheta_adv, rthdynten) ! tendency for density. ! accumulate total water here for later use in w tendency calculation. ! accumulate horizontal mass-flux -!$acc parallel vector_length(64) -!$acc loop gang private(h_wk) - do iCell=cellStart,cellEnd -!$acc cache(h_wk) -!$acc loop vector + !$acc parallel + !$acc loop gang vector collapse(2) private(h_ws) + do iCell=cellStart,cellEnd do k=1,nVertLevels - h_wk(k) = 0.0 - end do -!$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - h_wk(k) = h_wk(k) + edge_sign * ru(k,iEdge) + h_ws = 0.0 + + !$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) + + h_ws = h_ws + edge_sign * ru(k,iEdge) end do - end do -!$acc loop vector - do k=1,nVertLevels - r = invAreaCell(iCell) - h_divergence(k,iCell) = h_wk(k) * r + + h_divergence(k,iCell) = h_ws * invAreaCell(iCell) end do end do -!$acc end parallel - - + !$acc end parallel ! ! dp / dz and tend_rho @@ -6804,70 +6840,52 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels ! ! Compute u (normal) velocity tendency for each edge (cell face) ! -!$acc parallel vector_length(64) -!$acc loop gang private(wduz, tend_wk, eoe_w, we_w) + !$acc parallel vector_length(64) + !$acc loop gang(static:2) private(wduz, tend_wk) do iEdge=edgeSolveStart,edgeSolveEnd -!$acc cache(tend_wk) -!$acc cache(wduz) -!$acc cache(eoe_w) -!$acc cache(we_w) + !$acc cache(wduz, tend_wk) cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) ! horizontal pressure gradient -!$acc loop vector + !$acc loop vector shortloop do k=1,nVertLevels tend_wk(k) = u(k,iEdge) end do -!$acc loop vector shortloop + !$acc loop vector shortloop do k=1,nVertLevels+1,nVertLevels wduz(k) = 0. end do -!$acc loop vector shortloop + !$acc loop vector shortloop do k=2,nVertLevels,nVertLevels-2 wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2))*(fzm(k)*tend_wk(k)+fzp(k)*tend_wk(k-1)) end do -!$acc loop vector + !$acc loop vector shortloop do k=3,nVertLevels-1 wduz(k) = flux3( tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND ) end do -!$acc loop vector shortloop - do j = 1,nEdgesOnEdge(iEdge) - eoe_w(j) = edgesOnEdge(j,iEdge) - we_w(j) = weightsOnEdge(j,iEdge) - end do - -!$acc loop vector + !$acc loop vector shortloop do k=1,nVertLevels q1 = pv_edge(k,iEdge) q2 = 0.0 -!$acc loop seq + !$acc loop seq do j = 1,nEdgesOnEdge(iEdge) - eoe = eoe_w(j) + eoe = edgesOnEdge(j,iEdge) workpv = 0.5 * (q1 + pv_edge(k,eoe)) - q2 = q2 + we_w(j) * u(k,eoe) * workpv + q2 = q2 + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv end do t_w = - rdzw(k)*(wduz(k+1)-wduz(k)) tend_u(k,iEdge) = t_w + rho_edge(k,iEdge) * & (q2 - (ke(k,cell2) - ke(k,cell1)) * & invDcEdge(iEdge)) - tend_wk(k) * 0.5 * & - (h_divergence(k,cell1)+h_divergence(k,cell2)) + (h_divergence(k,cell1)+h_divergence(k,cell2)) + & + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) end do end do -!$acc end parallel - -!$acc parallel vector_length(64) -!$acc loop gang - do iEdge=edgeSolveStart,edgeSolveEnd -!$acc loop vector - do k=1,nVertLevels - tend_u(k,iEdge) = tend_u(k,iEdge) + tend_u_euler(k,iEdge) + tend_ru_physics(k,iEdge) - end do - end do -!$acc end parallel + !$acc end parallel ! mixing terms are integrated using forward-Euler, so this tendency is only computed in the ! first Runge-Kutta substep and saved for use in later RK substeps 2 and 3. @@ -6881,73 +6899,56 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels !----------- rhs for w - ! ! horizontal advection for w ! -!$acc parallel vector_length(64) -!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... -!$acc cache(ru_edge_w) -!$acc cache(flux_arr) -!$acc cache(iadv_cell_w) -!$acc cache(coefs_w) -!$acc cache(coefs_3rd_w) -!$acc cache(tend_wk) + !$acc parallel + !$acc loop gang vector collapse(2) + do iCell=cellSolveStart,cellSolveEnd + do k=1,nVertLevels + ! w should be computed on levels 2..nVertLevels + ! theta should be computed on levels 1..nVertLevels -!$acc loop vector - do k=1,nVertLevels+1 - tend_wk(k) = 0.0 - end do + tend_ws = 0.0 + tend_us = 0.0 -!$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) -!$acc loop vector - do k=2,nVertLevels - ru_edge_w(k) = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) - end do + !$acc loop seq + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + if (k >= 2) ru_edge_ws = fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) + ru_edge_us = ru(k,iEdge) -!$acc loop vector - do j=1,nAdvCellsForEdge(iEdge) - iadv_cell_w(j) = advCellsForEdge(j,iEdge) - coefs_w(j) = adv_coefs(j,iEdge) - coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) - end do + flux_ws = 0.0 + flux_us = 0.0 -!$acc loop vector - do k=1,nVertLevels - flux_arr(k) = 0.0 - end do + !$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) + iadv_cell_s = advCellsForEdge(j,iEdge) + coefs_s = adv_coefs(j,iEdge) + coefs_3rd_s = adv_coefs_3rd(j,iEdge) - ! flux_arr stores the value of w at the cell edge used in the - ! horizontal transport + scalar_weight = coefs_s + sign(1.0_RKIND,ru_edge_ws) * coefs_3rd_s + flux_ws = flux_ws + scalar_weight * w(k,iadv_cell_s) -!$acc loop seq - do j=1,nAdvCellsForEdge(iEdge) -!$acc loop vector - do k=2,nVertLevels - iAdvCell = iadv_cell_w(j) - scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k)) * coefs_3rd_w(j) - flux_arr(k) = flux_arr(k) + scalar_weight * w(k,iAdvCell) + scalar_weight = coefs_s + sign(1.0_RKIND,ru_edge_us) * coefs_3rd_s + flux_us = flux_us + scalar_weight * theta_m(k,iadv_cell_s) end do - end do -!DIR$ IVDEP -!$acc loop vector - do k=2,nVertLevels - tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell)*ru_edge_w(k)*flux_arr(k) + tend_ws = tend_ws - edgesOnCell_sign(i,iCell) * ru_edge_ws * flux_ws + tend_us = tend_us - edgesOnCell_sign(i,iCell) * ru_edge_us * flux_us + + ! extra term for theta + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + tend_us = tend_us - edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * (ru_save(k,iEdge)-ru_edge_us) & + * 0.5 * (theta_m_save(k,cell2)+theta_m_save(k,cell1)) end do - end do -!DIR$ IVDEP -!$acc loop vector - do k=2,nVertLevels - tend_w(k,iCell) = tend_wk(k) + if (k >= 2) tend_w(k,iCell) = tend_ws + tend_theta (k,iCell) = tend_us end do end do -!$acc end parallel - + !$acc end parallel ! @@ -6967,155 +6968,36 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels ! vertical advection, pressure gradient and buoyancy for w ! -!$acc parallel vector_length(64) -!$acc loop gang private(tend_wk, wdwz) + !$acc parallel vector_length(64) + !$acc loop gang(static:2) private(tend_wk, wdwz) do iCell=cellSolveStart,cellSolveEnd + !$acc cache(tend_wk, wdwz) -!$acc loop vector + !$acc loop vector shortloop do k=1,nVertLevels tend_wk(k) = w(k,iCell) end do -!$acc loop vector shortloop + !$acc loop vector shortloop do k=1,nVertLevels+1,nVertLevels wdwz(k) = 0. end do -!$acc loop vector shortloop + !$acc loop vector shortloop do k=2,nVertLevels,nVertLevels-2 wdwz(k) = 0.25*(rw(k,iCell)+rw(k-1,iCell))*(tend_wk(k)+tend_wk(k-1)) end do -!$acc loop vector + !$acc loop vector shortloop do k=3,nVertLevels-1 wdwz(k) = flux3(tend_wk(k-2),tend_wk(k-1),tend_wk(k),tend_wk(k+1),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND ) end do -!DIR$ IVDEP -!$acc loop vector - do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) - end do - end do -!$acc end parallel - -!$acc parallel vector_length(64) -!$acc loop gang worker - do iCell = cellSolveStart,cellSolveEnd -!DIR$ IVDEP + !DIR$ IVDEP + !$acc loop vector shortloop do k=2,nVertLevels - tend_w(k,iCell) = tend_w(k,iCell) + tend_w_euler(k,iCell) - end do - end do -!$acc end parallel - - -!----------- rhs for theta - - ! - ! horizontal advection for theta - ! -!$acc parallel vector_length(64) -!$acc loop gang private(ru_edge_w, flux_arr, iadv_cell_w, coefs_w, coefs_3rd_w, tend_wk) - do iCell=cellSolveStart,cellSolveEnd ! Technically updating fewer cells than before... -!$acc cache(ru_edge_w) -!$acc cache(flux_arr) -!$acc cache(iadv_cell_w) -!$acc cache(coefs_w) -!$acc cache(coefs_3rd_w) -!$acc cache(tend_wk) - -!$acc loop vector - do k=1,nVertLevels+1 - tend_wk(k) = 0.0 - end do - -!$acc loop seq - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - -!$acc loop vector - do k=1,nVertLevels - ru_edge_w(k) = ru(k,iEdge) - flux_arr(k) = 0.0 - end do - -!$acc loop vector shortloop - do j=1,nAdvCellsForEdge(iEdge) - iadv_cell_w(j) = advCellsForEdge(j,iEdge) - coefs_w(j) = adv_coefs(j,iEdge) - coefs_3rd_w(j) = adv_coefs_3rd(j,iEdge) - end do - -!$acc loop seq - do j=1,nAdvCellsForEdge(iEdge) -!$acc loop vector - do k=1,nVertLevels - iAdvCell = iadv_cell_w(j) - scalar_weight = coefs_w(j) + sign(1.0_RKIND,ru_edge_w(k))*coefs_3rd_w(j) - flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iAdvCell) - end do - end do - -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - tend_wk(k) = tend_wk(k) - edgesOnCell_sign(i,iCell) * ru_edge_w(k) * flux_arr(k) - end do - - end do - -!$acc loop vector - do k=1,nVertLevels - tend_theta(k,iCell) = tend_wk(k) + tend_w(k,iCell) = tend_w(k,iCell) * invAreaCell(iCell) - rdzu(k)*(wdwz(k+1)-wdwz(k)) + tend_w_euler(k,iCell) end do end do -!$acc end parallel -! addition to pick up perturbation flux for rtheta_pp equation - -!$acc parallel vector_length(64) -!$acc loop gang private(flux_arr1,tend_wk, ru_edge_w,ru_save_temp) - do iCell=cellSolveStart,cellSolveEnd -!$acc cache(ru_edge_w) -!$acc cache(flux_arr1) -!$acc cache(ru_save_temp) -!$acc cache(tend_wk) - -!$acc loop vector - do k=1,nVertLevels - tend_wk(k) = tend_theta(k,iCell) - end do - -!$acc loop vector - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - cell1 = cellsOnEdge(1,iEdge) - cell2 = cellsOnEdge(2,iEdge) -!$acc loop vector - do k=1,nVertLevels - ru_edge_w(k) = ru(k,iEdge) - ru_save_temp(k) = ru_save(k,iEdge) - flux_arr1(k) = 0.0 - end do -!DIR$ IVDEP -!$acc loop vector - do k=1,nVertLevels - flux_arr1(k) = edgesOnCell_sign(i,iCell)*dvEdge(iEdge)*(ru_save_temp(k)-ru_edge_w(k))*0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) - !flux_arr1(k) = edgesOnCell_sign(i,iCell) *dvEdge(iEdge)*(ru_save(k,iCell)-ru_edge_w(k)) & - ! *0.5*(theta_m_save(k,cell2)+theta_m_save(k,cell1)) - end do -!DIR$ IVDEP -!$acc loop vector - do k = 1,nVertLevels -! tend_theta(k,iCell) = tend_theta(k,iCell)-flux_arr1(k) ! division by areaCell picked up down below - tend_wk(k) = tend_wk(k)-flux_arr1(k) - end do - end do -!$acc loop vector - do k=1,nVertLevels - tend_theta(k,iCell) = tend_wk(k) - end do - - end do -!$acc end parallel + !$acc end parallel ! ! horizontal mixing for theta_m - we could combine this with advection directly (i.e. as a turbulent flux), @@ -7124,16 +7006,16 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels ! Note: we are also dividing through by the cell area after the horizontal flux divergence ! -!$acc parallel vector_length(64) -!$acc loop gang private(wdtz) + !$acc parallel vector_length(64) + !$acc loop gang(static:2) private(wdtz) do iCell = cellSolveStart,cellSolveEnd -!$acc cache(wdtz) + !$acc cache(wdtz) -!$acc loop vector shortloop + !$acc loop vector shortloop do k=1,nVertLevels+1,nVertLevels wdtz(k) = 0. end do -!$acc loop vector shortloop + !$acc loop vector shortloop do k=2,nVertLevels,nVertLevels-2 if (k.eq.2) then wdtz(k) = rw(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) @@ -7142,25 +7024,25 @@ subroutine atm_compute_dyn_tend_work_rk23(nCells, nEdges, nVertices, nVertLevels wdtz(k) = rw_save(k,icell)*(fzm(k)*theta_m(k,iCell)+fzp(k)*theta_m(k-1,iCell)) !rtheta_pp redefinition end if end do -!$acc loop vector + !$acc loop vector shortloop do k=3,nVertLevels-1 wdtz(k) = flux3( theta_m(k-2,iCell),theta_m(k-1,iCell),theta_m(k,iCell),theta_m(k+1,iCell), rw(k,iCell), coef_3rd_order ) wdtz(k) = wdtz(k) + (rw_save(k,icell)-rw(k,iCell))*(fzm(k)*theta_m_save(k,iCell)+fzp(k)*theta_m_save(k-1,iCell))! rtheta_pp redefinition end do -!DIR$ IVDEP -!$acc loop vector + !DIR$ IVDEP + !$acc loop vector shortloop do k=1,nVertLevels - tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) + tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) - rdzw(k)*(wdtz(k+1)-wdtz(k)) tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) tend_theta(k,iCell) = tend_theta(k,iCell) + tend_theta_euler(k,iCell) + tend_rtheta_physics(k,iCell) end do end do -!$acc end parallel + !$acc end parallel -!$acc end data + !$acc end data end subroutine atm_compute_dyn_tend_work_rk23 diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 1fd3e6aed7..7e9e04dab3 100755 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -185,14 +185,20 @@ integer function atm_component_role(self) ! equal, all "excess" ranks on a socket beyond min(dynamics_ranks_per_node, radiation_ranks_per_node) ! will be assigned either ROLE_INTEGRATE or ROLE_RADIATION as needed. ! - if (socket_rank >= min(dynamics_ranks_per_node, radiation_ranks_per_node)) then - if (dynamics_ranks_per_node > radiation_ranks_per_node) then - role = ROLE_INTEGRATE - else - role = ROLE_RADIATION - end if - end if +!!! if (socket_rank >= min(dynamics_ranks_per_node, radiation_ranks_per_node)) then +!!! if (dynamics_ranks_per_node > radiation_ranks_per_node) then +!!! role = ROLE_INTEGRATE +!!! else +!!! role = ROLE_RADIATION +!!! end if +!!! end if + if (socket_rank >= dynamics_ranks_per_node) then + role = ROLE_RADIATION + endif + if (dynamics_ranks_per_node == 1 .and. local_rank == 1) then + role = ROLE_INTEGRATE + end if ! ! Assign devices based on rank in the role within a shared-memory node @@ -209,11 +215,56 @@ integer function atm_component_role(self) if (role == ROLE_INTEGRATE) then num_devices = acc_get_num_devices(acc_device_nvidia) - my_device = (role_rank * num_devices) / role_size +!!! Version 1 +!!! if(local_rank emstotField%block%domain%mpas_cpl +!!! +if (coupler%role_is(ROLE_INTEGRATE)) then +!$acc update host(absnxt, abstot, emstot) +end if !call mpas_log_write('--- writing absnxt,abstot,and emstot to restart = $l', logicArgs=(/l_camlw/)) do j = jts,jte @@ -1010,6 +1029,11 @@ subroutine radiation_camlw_to_MPAS(diag_physics,its,ite) enddo enddo +!!! +if (coupler%role_is(ROLE_INTEGRATE)) then +!$acc update device(absnxt, abstot, emstot) +end if + end subroutine radiation_camlw_to_MPAS !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index e90d80e63b..eb21cde011 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -797,7 +797,7 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) enddo !$acc end parallel endif -!$acc update host(fh, fm) +!!!$acc update host(fh, fm) case("sf_mynn") call mpas_pool_get_array_gpu(diag_physics,'ch',ch) @@ -892,7 +892,7 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) call mpas_pool_get_array_gpu(mesh,'areaCell',areaCell) -!$acc update host(areaCell) +!!!$acc update host(areaCell) !copy all MPAS arrays to rectanguler grid: call sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 93b725cfd9..efdaee0f0d 100755 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -674,7 +674,7 @@ subroutine MPAS_to_physics_gpu(configs,mesh,state,time_lev,diag,diag_physics,mpa end if do j = jts, jte -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -756,7 +756,7 @@ subroutine MPAS_to_physics_gpu(configs,mesh,state,time_lev,diag,diag_physics,mpa !arrays located at w points: do j = jts, jte -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts,kte+1 do i = its,ite @@ -1003,10 +1003,10 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, ! qc => scalars(index_qc,:,:) ! qr => scalars(index_qr,:,:) -!$acc parallel vector_length(32) -!$acc loop gang vector collapse(3) !initialize variables needed in the cloud microphysics schemes: do j = jts, jte +!$acc parallel +!$acc loop gang vector collapse(2) do i = its, ite do k = kts, kte qv_p(i,k,j) = scalars(sindex_qv,k,i) @@ -1024,8 +1024,8 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, w_p(i,k,j) = w(k,i) enddo enddo - enddo !$acc end parallel + enddo !additional initialization as function of cloud microphysics scheme: microp_select_init: select case(microp_scheme) @@ -1035,11 +1035,11 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, ! qs => scalars(index_qs,:,:) ! qg => scalars(index_qg,:,:) -!$acc parallel vector_length(32) -!$acc loop gang vector collapse(3) do j = jts, jte - do k = kts, kte +!$acc parallel +!$acc loop gang vector collapse(2) do i = its, ite + do k = kts, kte qi_p(i,k,j) = scalars(sindex_qi,k,i) qs_p(i,k,j) = scalars(sindex_qs,k,i) qg_p(i,k,j) = scalars(sindex_qg,k,i) @@ -1048,8 +1048,8 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, resnow_p(i,k,j) = re_snow(k,i) enddo enddo - enddo !$acc end parallel + enddo microp2_select: select case(microp_scheme) @@ -1175,7 +1175,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te !update variables needed in the dynamical core: do j = jts,jte -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do i = its,ite do k = kts,kte @@ -1232,10 +1232,10 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te ! qs => scalars(index_qs,:,:) ! qg => scalars(index_qg,:,:) do j = jts, jte -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) - do k = kts, kte do i = its, ite + do k = kts, kte scalars(sindex_qi,k,i) = qi_p(i,k,j) scalars(sindex_qs,k,i) = qs_p(i,k,j) scalars(sindex_qg,k,i) = qg_p(i,k,j) diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index b4db9fa0ca..eebda14da7 100755 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -422,6 +422,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008: if(size(bb) < slcats .or. & size(drysmc) < slcats .or. & + size(hc ) < slcats .or. & size(f11 ) < slcats .or. & size(maxsmc) < slcats .or. & size(refsmc) < slcats .or. & @@ -434,7 +435,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) endif if(sltype.eq.mminsl) then do lc = 1, slcats - read(read_unit,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & + read(read_unit,*) iindex,bb(lc),drysmc(lc),hc(lc), f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & satdk(lc),satdw(lc),wltsmc(lc),qtz(lc) enddo endif @@ -457,6 +458,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) DM_BCAST_INTEGER(iindex) DM_BCAST_REALS(bb) DM_BCAST_REALS(drysmc) + DM_BCAST_REALS(hc) DM_BCAST_REALS(f11) DM_BCAST_REALS(maxsmc) DM_BCAST_REALS(refsmc) @@ -473,8 +475,8 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !call mpas_log_write(' IINDEX =$i',intArgs=(/iindex/)) !call mpas_log_write('') !do lc = 1, slcats -! call mpas_log_write('$i $r $r $r $r $r $r $r $r $r $r', intArgs=(/lc/), & -! realArgs=(/bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & +! call mpas_log_write('$i $r $r $r $r $r $r $r $r $r $r $r', intArgs=(/lc/), & +! realArgs=(/bb(lc),drysmc(lc),hc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & ! satdk(lc),satdw(lc),wltsmc(lc),qtz(lc)/)) !enddo call mpas_log_write(' end read SOILPARM.TBL') @@ -558,7 +560,7 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !$acc Z0MINTBL,Z0MAXTBL,ZTOPVTBL,ZBOTVTBL,TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,& !$acc RSMAX_DATA,BARE,NATURAL,LOW_DENSITY_RESIDENTIAL, & !$acc HIGH_DENSITY_RESIDENTIAL,HIGH_INTENSITY_INDUSTRIAL,SLTYPE,SLCATS,BB, & -!$acc DRYSMC,F11,MAXSMC,REFSMC,SATPSI,SATDK,SATDW,WLTSMC,QTZ,SLPCATS, & +!$acc DRYSMC,HC,F11,MAXSMC,REFSMC,SATPSI,SATDK,SATDW,WLTSMC,QTZ,SLPCATS, & !$acc SLOPE_DATA,SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & !$acc REFKDT_DATA,FRZK_DATA,ZBOT_DATA,CZIL_DATA,SMLOW_DATA,SMHIGH_DATA,LVCOEF_DATA) diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index 8bf7279e75..1f469c5a39 100755 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -217,7 +217,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi ! tend_rho_physics(:,:) = 0._RKIND ! NB: rho tendency is not currently supplied by physics, but this ! field may be later filled with IAU or other tendencies -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolveScalar do k = 1, nVertLevels @@ -455,7 +455,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !MGD for PV budget? should a similar line be in the cumulus section below? !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nEdges do k = 1, nVertLevels @@ -469,7 +469,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge end if !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nEdgesSolve do k = 1, nVertLevels @@ -480,7 +480,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !$acc end parallel !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -498,7 +498,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge case("bl_mynn") !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -517,7 +517,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge if (config_convection_scheme .ne. 'off') then !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -534,7 +534,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge case('cu_kain_fritsch') !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -559,7 +559,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge gpu_compactHaloInfoSize_c_v ) !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nEdges do k = 1, nVertLevels @@ -571,7 +571,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !$acc end parallel end if !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nEdgesSolve do k = 1, nVertLevels @@ -588,7 +588,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !add coupled tendencies due to longwave radiation: if (config_radt_lw_scheme .ne. 'off') then !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -602,7 +602,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !add coupled tendencies due to shortwave radiation: if (config_radt_sw_scheme .ne. 'off') then !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -616,7 +616,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !if non-hydrostatic core, convert the tendency for the potential temperature to a !tendency for the modified potential temperature: !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) do i = 1, nCellsSolve do k = 1, nVertLevels @@ -703,7 +703,7 @@ subroutine tend_toEdges_gpu(block,mesh,Ux_tend,Uy_tend,U_tend, & gpu_compactHaloInfoSize_c_v, size(Uy_tend,1), size(Uy_tend,2)) !!! - !$acc parallel vector_length(32) + !$acc parallel !$acc loop gang vector collapse(2) private(cell1, cell2) do iEdge = 1, nEdgesScalar do k = 1, nVertLevels diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index 5bd36fcb0d..80124badc5 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -1505,10 +1505,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! ! compute tridiagonal matrix elements for momentum ! -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector collapse(2) - do i = its,ite do k = kts,kte + do i = its,ite au(i,k) = 0. al(i,k) = 0. ad(i,k) = 0. @@ -1520,10 +1520,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! ! paj: ctopo=1 if topo_wind=0 (default) !raquel---paj tke code (could be replaced with shin-hong tke in future -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector collapse(2) private(zk,rlamdz) - do i = its,ite do k= kts, kte-1 + do i = its,ite shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F index d3b57229a9..5870169b56 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F @@ -330,9 +330,13 @@ subroutine cu_ntiedtke( & !-------other local variables---- integer :: zz, pp !----------------------------------------------------------------------- -!$acc data create(rcs,rn,evap,heatflux,dx2d, & -!$acc slimsk,prsi,ghti,zi,dot,prsl,q1,q2,q3,q1b,t1b,q11,q12,t1,u1,v1,zl, & -!$acc omg,ghtl,kbot,ktop) +!$acc data present(raincv,pratec,qfx,hfx,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d, & +!$acc rho3d,qvften,thften,dz8w,pcps,p8w,xland,cu_act_flag, & +!$acc dx,rthcuten,rqvcuten,rqccuten,rqicuten, & +!$acc rucuten,rvcuten) & +!$acc create(rcs,rn,evap,heatflux,dx2d, & +!$acc slimsk,prsi,ghti,zi,dot,prsl,q1,q2,q3,q1b,t1b,q11,q12,t1,u1,v1,zl, & +!$acc omg,ghtl,kbot,ktop) ! ! !*** check to see if this is a convection timestep @@ -364,14 +368,15 @@ subroutine cu_ntiedtke( & enddo !$acc end parallel ! +!$acc parallel +!$acc loop seq do k=kts,kte -!$acc parallel vector_length(128) !$acc loop gang vector do i=its,ite zi(i,k+1)=zi(i,k)+dz8w(i,k,j) enddo -!$acc end parallel enddo +!$acc end parallel ! !$acc parallel vector_length(128) !$acc loop gang vector collapse(2) @@ -390,13 +395,13 @@ subroutine cu_ntiedtke( & enddo !$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel do i=its,ite dx2d(i) = dx(i,j) enddo !$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector collapse(2) do k=kts,kte !!! kp=k+1 @@ -478,7 +483,6 @@ subroutine cu_ntiedtke( & !!! pp = pp + 1 enddo !$acc end parallel -!$acc update host (raincv) if(present(rqccuten))then if ( f_qc ) then @@ -629,9 +633,14 @@ subroutine tiecnvn(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & integer i,j,k,lq,km,km1 real dt,ztpp1 real zew,zqs,zcor -!$acc data create(pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo, & -!$acc zqq,pcte,ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat,pqhfl, & -!$acc prsfc,pssfc,phhfl,zrain,pgeoh,icbot,ictop,locum) + + +!$acc data present(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & +!$acc pap,paph,evap,hfx,zprecc,lndj,dx & +!$acc ) & +!$acc create(pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo, & +!$acc zqq,pcte,ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat,pqhfl, & +!$acc prsfc,pssfc,phhfl,zrain,pgeoh,icbot,ictop,locum,ktype) ! ztmst=dt ! @@ -876,13 +885,17 @@ subroutine cumastrn & real zmfs(klon),pmean(klev),zlon real zduten,zdvten,ztdis,pgf_u,pgf_v -!$acc data create(ztenh,zqenh,zqsenh,ztd,zqd,zmfus,zmfds,zmfuq, & -!$acc zmfdq,zdmfup,zdmfdp,zmful,zuu,zvu,zud,zvd,zlglac,zrfl, & -!$acc zdpmel,pmfude_rate,pmfdde_rate,zmfuus,zmfdus,zuv2,ztenu, & -!$acc ztenv,zhcbase,zmfub,zmfub1,zdhpbl,zsfl,zcape,zcape1,zcape2, & -!$acc ztauc,ztaubl,zheat,wup,wbase,zmfuub,upbl,zmfuvb,zsum12, & -!$acc zsum22,pmflxr,pmflxs,ilab,idtop,ictop0,ilwmin,kdpl, & -!$acc loddraf,llo2,zmfs,pmean) +!$acc data present(pten,pqen,puen,pven,pverv,pqsen,pqhfl,pap,paph, & +!$acc pgeo,ptte,pqte,pvom,pvol,prsfc,pssfc,ldcum,ktype,kcbot, & +!$acc kctop,ptu,pqu,plu,plude,pmfu,pmfd,prain,pcte,phhfl,lndj, & +!$acc zgeoh,dx) & +!$acc create(ztenh,zqenh,zqsenh,ztd,zqd,zmfus,zmfds,zmfuq, & +!$acc zmfdq,zdmfup,zdmfdp,zmful,zuu,zvu,zud,zvd,zlglac,zrfl, & +!$acc zdpmel,pmfude_rate,pmfdde_rate,zmfuus,zmfdus,zuv2,ztenu, & +!$acc ztenv,zhcbase,zmfub,zmfub1,zdhpbl,zsfl,zcape,zcape1,zcape2, & +!$acc ztauc,ztaubl,zheat,wup,wbase,zmfuub,upbl,zmfuvb,zsum12, & +!$acc zsum22,pmflxr,pmflxs,ilab,idtop,ictop0,ilwmin,kdpl, & +!$acc loddraf,llo2,zmfs,pmean) !------------------------------------------- ! 1. specify constants and parameters !------------------------------------------- @@ -1678,7 +1691,14 @@ subroutine cuinin & integer icall,ik real zzs real zqsat,zcor,zqp,zcond1 -!$acc data create(zwmax,zph,loflag) + +!$acc data present(pten,pqen,pqsen,puen,pven,pverv,pgeo, & +!$acc paph,pgeoh,ptenh,pqenh,pqsenh,klwmin, & +!$acc ptu,pqu,ptd,pqd,puu,pvu,pud,pvd,pmfu, & +!$acc pmfd,pmfus,pmfds,pmfuq,pmfdq,pdmfup, & +!$acc pdmfdp,pdpmel,plu,plude,klab) & +!$acc create(zwmax,zph,loflag) + !------------------------------------------------------------ !* 1. specify large scale parameters at half levels !* adjust temperature fields if staticly unstable @@ -1725,7 +1745,6 @@ subroutine cuinin & end do !$acc end parallel !********************************************************************************** - !$acc parallel vector_length(128) !$acc loop gang vector do jl=1,klon @@ -1898,9 +1917,14 @@ subroutine cutypen & logical needreset, lldcum(klon) logical flag real zqsat,zqp,zcond,zcond1,zl,zi,zf -!$acc data create(ptu,pqu,plu,zph,klab,kctop,kcbot,loflag,deepflag, & -!$acc resetflag,dhen,dh,plude,kup,vptu,vten,zbuo,abuoy,zqold,eta,dz, & -!$acc coef,zcbase,itoppacel,lldcum) + +!$acc data present(pqen,ptenh,pqenh,pqsenh,pgeoh,paph,hfx,qfx,pgeo,pqsen, & +!$acc pap,pten,lndj,cutu,cuqu,culab,ldcum,cubot,cutop,ktype, & +!$acc wbase,culu,kdpl & +!$acc ) & +!$acc create(ptu,pqu,plu,zph,klab,kctop,kcbot,loflag,deepflag, & +!$acc resetflag,dhen,dh,plude,kup,vptu,vten,zbuo,abuoy,zqold,eta,dz, & +!$acc coef,zcbase,itoppacel,lldcum) !-------------------------------------------------------------- !$acc parallel vector_length(128) !$acc loop gang vector @@ -2591,9 +2615,18 @@ subroutine cuascn & real zzzmb logical llo10 real zdz , zmf -!$acc data create(zlrain,zbuo,kup,zodetr,zph,zdmfen,zdmfde,zmfuu, & -!$acc zmfuv,zpbase,zqold,zluold,zprecip,eta,dz,zentr,pdmfen,zoentr, & -!$acc zdpmean,loflag,llo1) + + + + +!$acc data present(ptenh,pqenh,puen,pven,pten,pqen,pqsen,pgeo,pgeoh,pap,paph, & +!$acc pqte,pverv,klwmin,ldcum,phcbase,ktype,klab,ptu,pqu,plu, & +!$acc puu,pvu,pmfu,pmfub,pmfus,pmfuq,pmful,plude,pdmfup,kcbot, & +!$acc kctop,kctop0,pqsenh,plglac,lndj,wup,wbase,kdpl,pmfude_rate & +!$acc ) & +!$acc create(zlrain,zbuo,kup,zodetr,zph,zdmfen,zdmfde,zmfuu, & +!$acc zmfuv,zpbase,zqold,zluold,zprecip,eta,dz,zentr,pdmfen,zoentr, & +!$acc zdpmean,loflag,llo1) !-------------------------------- !* 1. specify parameters !-------------------------------- @@ -3142,115 +3175,115 @@ subroutine cuascn & !$acc end data return - end subroutine cuascn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudlfsn & - & (klon, klev, & - & kcbot, kctop, lndj, ldcum, & - & ptenh, pqenh, puen, pven, & - & pten, pqsen, pgeo, & - & pgeoh, paph, ptu, pqu, plu,& - & puu, pvu, pmfub, prfl, & - & ptd, pqd, pud, pvd, & - & pmfd, pmfds, pmfdq, pdmfdp, & - & kdtop, lddraf) + end subroutine cuascn + !--------------------------------------------------------- + ! level 3 souroutines + !-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu,& + & puu, pvu, pmfub, prfl, & + & ptd, pqd, pud, pvd, & + & pmfd, pmfds, pmfdq, pdmfdp, & + & kdtop, lddraf) -! this routine calculates level of free sinking for -! cumulus downdrafts and specifies t,q,u and v values + ! this routine calculates level of free sinking for + ! cumulus downdrafts and specifies t,q,u and v values -! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + ! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 -! purpose. -! -------- -! to produce lfs-values for cumulus downdrafts -! for massflux cumulus parameterization + ! purpose. + ! -------- + ! to produce lfs-values for cumulus downdrafts + ! for massflux cumulus parameterization -! interface -! --------- -! this routine is called from *cumastr*. -! input are environmental values of t,q,u,v,p,phi -! and updraft values t,q,u and v and also -! cloud base massflux and cu-precipitation rate. -! it returns t,q,u and v values and massflux at lfs. + ! interface + ! --------- + ! this routine is called from *cumastr*. + ! input are environmental values of t,q,u,v,p,phi + ! and updraft values t,q,u and v and also + ! cloud base massflux and cu-precipitation rate. + ! it returns t,q,u and v values and massflux at lfs. -! method. + ! method. -! check for negative buoyancy of air of equal parts of -! moist environmental air and cloud air. + ! check for negative buoyancy of air of equal parts of + ! moist environmental air and cloud air. -! parameter description units -! --------- ----------- ----- -! input parameters (integer): + ! parameter description units + ! --------- ----------- ----- + ! input parameters (integer): -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level + ! *klon* number of grid points per packet + ! *klev* number of levels + ! *kcbot* cloud base level + ! *kctop* cloud top level -! input parameters (logical): + ! input parameters (logical): -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points + ! *lndj* land sea mask (1 for land) + ! *ldcum* flag: .true. for convective points -! input parameters (real): + ! input parameters (real): -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pten* provisional environment temperature (t+1) k -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *ptu* temperature in updrafts k -! *pqu* spec. humidity in updrafts kg/kg -! *plu* liquid water content in updrafts kg/kg -! *puu* u-velocity in updrafts m/s -! *pvu* v-velocity in updrafts m/s -! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + ! *ptenh* env. temperature (t+1) on half levels k + ! *pqenh* env. spec. humidity (t+1) on half levels kg/kg + ! *puen* provisional environment u-velocity (t+1) m/s + ! *pven* provisional environment v-velocity (t+1) m/s + ! *pten* provisional environment temperature (t+1) k + ! *pqsen* environment spec. saturation humidity (t+1) kg/kg + ! *pgeo* geopotential m2/s2 + ! *pgeoh* geopotential on half levels m2/s2 + ! *paph* provisional pressure on half levels pa + ! *ptu* temperature in updrafts k + ! *pqu* spec. humidity in updrafts kg/kg + ! *plu* liquid water content in updrafts kg/kg + ! *puu* u-velocity in updrafts m/s + ! *pvu* v-velocity in updrafts m/s + ! *pmfub* massflux in updrafts at cloud base kg/(m2*s) -! updated parameters (real): + ! updated parameters (real): -! *prfl* precipitation rate kg/(m2*s) + ! *prfl* precipitation rate kg/(m2*s) -! output parameters (real): + ! output parameters (real): -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + ! *ptd* temperature in downdrafts k + ! *pqd* spec. humidity in downdrafts kg/kg + ! *pud* u-velocity in downdrafts m/s + ! *pvd* v-velocity in downdrafts m/s + ! *pmfd* massflux in downdrafts kg/(m2*s) + ! *pmfds* flux of dry static energy in downdrafts j/(m2*s) + ! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) + ! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) -! output parameters (integer): + ! output parameters (integer): -! *kdtop* top level of downdrafts + ! *kdtop* top level of downdrafts -! output parameters (logical): + ! output parameters (logical): -! *lddraf* .true. if downdrafts exist + ! *lddraf* .true. if downdrafts exist -! externals -! --------- -! *cuadjtq* for calculating wet bulb t and q at lfs -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pten(klon,klev), pqsen(klon,klev), & - & pgeo(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1),& - & ptu(klon,klev), pqu(klon,klev), & - & puu(klon,klev), pvu(klon,klev), & - & plu(klon,klev), & - & pmfub(klon), prfl(klon) + ! externals + ! --------- + ! *cuadjtq* for calculating wet bulb t and q at lfs + !---------------------------------------------------------------------- + implicit none + + integer klev,klon + real ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pten(klon,klev), pqsen(klon,klev), & + & pgeo(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1),& + & ptu(klon,klev), pqu(klon,klev), & + & puu(klon,klev), pvu(klon,klev), & + & plu(klon,klev), & + & pmfub(klon), prfl(klon) real ptd(klon,klev), pqd(klon,klev), & & pud(klon,klev), pvd(klon,klev), & @@ -3272,55 +3305,67 @@ subroutine cudlfsn & real zhsk,zttest,zqtest,zbuo,zmftop real zqsat,zcor,zqp,zcond0,zcond1 -!$acc data create(ztenwb,zqenwb,zcond,zph,zhsmin,ikhsmin,llo2) -!---------------------------------------------------------------------- + + + + + + + + +!$acc data present(kcbot,kctop,lndj,ldcum,ptenh,pqenh,puen,pven,pten, & +!$acc pqsen,pgeo,pgeoh,paph,ptu,pqu,plu,puu,pvu,pmfub, & +!$acc prfl,ptd,pqd,pud,pvd,pmfd,pmfds,pmfdq,pdmfdp,kdtop,lddraf) & +!$acc create(ztenwb,zqenwb,zcond,zph,zhsmin,ikhsmin,llo2) + !---------------------------------------------------------------------- -! 1. set default values for downdrafts -! --------------------------------- -!$acc parallel vector_length(128) -!$acc loop gang vector - do jl=1,klon - lddraf(jl)=.false. - kdtop(jl)=klev+1 - ikhsmin(jl)=klev+1 - zhsmin(jl)=1.e8 - enddo -!$acc end parallel -!---------------------------------------------------------------------- + ! 1. set default values for downdrafts + ! --------------------------------- + !$acc parallel vector_length(128) + !$acc loop gang vector + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo + !$acc end parallel + !---------------------------------------------------------------------- -! 2. determine level of free sinking: -! downdrafts shall start at model level of minimum -! of saturation moist static energy or below -! respectively + ! 2. determine level of free sinking: + ! downdrafts shall start at model level of minimum + ! of saturation moist static energy or below + ! respectively -! for every point and proceed as follows: + ! for every point and proceed as follows: -! (1) determine level of minimum of hs -! (2) determine wet bulb environmental t and q -! (3) do mixing with cumulus cloud air -! (4) check for negative buoyancy -! (5) if buoyancy>0 repeat (2) to (4) for next -! level below + ! (1) determine level of minimum of hs + ! (2) determine wet bulb environmental t and q + ! (3) do mixing with cumulus cloud air + ! (4) check for negative buoyancy + ! (5) if buoyancy>0 repeat (2) to (4) for next + ! level below -! the assumption is that air of downdrafts is mixture -! of 50% cloud air + 50% environmental air at wet bulb -! temperature (i.e. which became saturated due to -! evaporation of rain and cloud water) -! ---------------------------------------------------- -!$acc parallel vector_length(128) -!$acc loop seq - do jk=3,klev-2 -!$acc loop gang vector private(zhsk) - do jl=1,klon - zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & - & foelhm(pten(jl,jk))*pqsen(jl,jk) + ! the assumption is that air of downdrafts is mixture + ! of 50% cloud air + 50% environmental air at wet bulb + ! temperature (i.e. which became saturated due to + ! evaporation of rain and cloud water) + ! ---------------------------------------------------- + !$acc parallel vector_length(128) + !$acc loop seq + do jk=3,klev-2 + !$acc loop gang vector private(zhsk) + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) if(zhsk .lt. zhsmin(jl)) then zhsmin(jl) = zhsk ikhsmin(jl)= jk end if end do - end do -!$acc end parallel + end do + !$acc end parallel + ike=klev-3 do jk=3,ike @@ -3518,7 +3563,10 @@ subroutine cuddrafn & real zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp real zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk real zqsat,zcor,zqp,zcond0,zcond1 -!$acc data create(zdmfen,zdmfde,zcond,zoentr,zbuoy,zph,llo2,itopde) + +!$acc data present(lddraf,ptenh,pqenh,puen,pven,pgeo,pgeoh,paph,prfl, & +!$acc ptd,pqd,pud,pvd,pmfu,pmfd,pmfds,pmfdq,pdmfdp,pmfdde_rate) & +!$acc create(zdmfen,zdmfde,zcond,zoentr,zbuoy,zph,llo2,itopde) !---------------------------------------------------------------------- ! 1. calculate moist descent for cumulus downdraft by ! (a) calculating entrainment/detrainment rates, @@ -3809,7 +3857,11 @@ subroutine cuflxn & real rhevap(klon) integer idbas(klon) logical llddraf -!$acc data create(rhevap,idbas) +!$acc data present(pten,pqen,pqsen,ptenh,pqenh,paph,pap,pgeoh,lndj,ldcum, & +!$acc kcbot,kctop,kdtop,ktype,lddraf,pmfu,pmfd,pmfus,pmfds, & +!$acc pmfuq,pmfdq,pmful,plude,pdmfup,pdmfdp,pdpmel,plglac, & +!$acc prain,pmfdde_rate,pmflxr,pmflxs) & +!$acc create(rhevap,idbas) !-------------------------------------------------------------------- !* specify constants @@ -4072,7 +4124,11 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & integer jk , ik , jl real zalv , zzp real zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) -!$acc data create(zdtdt,zdqdt,zdp) + +!$acc data present(kctop,kdtop,ldcum,lddraf,paph,pgeoh,pgeo,pten,ptenh,pqen, & +!$acc pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds,pmfuq,pmfdq, & +!$acc pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) & +!$acc create(zdtdt,zdqdt,zdp) !* 1.0 SETUP AND INITIALIZATIONS ! ------------------------- !$acc parallel vector_length(128) @@ -4169,7 +4225,10 @@ subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & real zzp, zdtdt real zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) -!$acc data create(zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv,zdudt,zdvdt,zdp) + +!$acc data present(ktype,kcbot,kctop,ldcum,paph,puen,pven,pmfu,pmfd,puu, & +!$acc pud,pvu,pvd,ptenu,ptenv) & +!$acc create(zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv,zdudt,zdvdt,zdp) ! !$acc parallel vector_length(128) !$acc loop gang vector collapse(2) diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F index 3615296e6c..daaaf1a2f4 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F @@ -179,11 +179,13 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs -!$acc data create(t, qci, qrs, qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ, & -!$acc den1d, qc1d, qi1d, re_qc, re_qi, re_qs) +!$acc data present(th,q,qc,qr,qi,qs,qg,den,pii,p,delz,rain,rainncv,snow, & +!$acc snowncv,sr,refl_10cm,graupel,graupelncv,re_cloud,re_ice, & +!$acc re_snow) & +!$acc create(t,qci,qrs,qv1d,t1d,p1d,qr1d,qs1d,qg1d,dBZ,den1d,qc1d,qi1d,re_qc,re_qi,re_qs) DO j=jts,jte -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) DO k=kts,kte DO i=its,ite @@ -217,7 +219,7 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & ,rainprod2d, evapprod2d & #endif ) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) DO K=kts,kte DO I=its,ite @@ -515,13 +517,13 @@ SUBROUTINE wsm62D(t, q & conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) ! ! -!$acc data create(rh, qs, rslope, rslope2, rslope3, rslopeb, qrs_tmp, falk, & -!$acc fall, work1, fallc, falkc, work1c, work2c, workr, worka, den_tmp, delz_tmp, & -!$acc pigen, pidep, pcond, prevp, psevp, pgevp, psdep, pgdep, praut, psaut, & -!$acc pgaut, piacr, pracw, praci, pracs, psacw, psaci, psacr, pgacw, pgaci, & -!$acc pgacr, pgacs, paacw, psmlt, pgmlt, pseml, pgeml, qsum, xl, cpm, work2, & -!$acc denfac, xni, denqrs1, denqrs2, denqrs3, denqci, n0sfac, delqrs1, delqrs2,& -!$acc delqrs3, delqi, tstepsnow, tstepgraup, mstep, numdt, flgcld, tvec1) +!$acc data present(t,q,qci,qrs,den,p,delz,rain,rainncv,sr,snow,snowncv,graupel,graupelncv) & +!$acc create(rh,qs,rslope,rslope2,rslope3,rslopeb,qrs_tmp,falk,fall,work1,fallc,falkc, & +!$acc work1c,work2c,workr,worka,den_tmp,delz_tmp,pigen,pidep,pcond,prevp,psevp, & +!$acc pgevp,psdep,pgdep,praut,psaut,pgaut,piacr,pracw,praci,pracs,psacw,psaci, & +!$acc psacr,pgacw,pgaci,pgacr,pgacs,paacw,psmlt,pgmlt,pseml,pgeml,qsum,xl,cpm, & +!$acc work2,denfac,xni,denqrs1,denqrs2,denqrs3,denqci,n0sfac,delqrs1,delqrs2, & +!$acc delqrs3,delqi,tstepsnow,tstepgraup,mstep,numdt,flgcld,tvec1) idim = ite-its+1 kdim = kte-kts+1 @@ -529,7 +531,7 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -547,7 +549,7 @@ SUBROUTINE wsm62D(t, q & ! changes during microphysical process calculation ! emanuel(1994) ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -567,7 +569,7 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! initialize the surface rain, snow, graupel ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector do i = its, ite rainncv(i) = 0. @@ -583,18 +585,16 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! compute the minor time steps. ! -!$acc parallel num_gangs(1) num_workers(1) vector_length(1) loops = max(nint(delt/dtcldcr),1) dtcld = delt/loops if(delt.le.dtcldcr) dtcld = delt -!$acc end parallel ! do loop = 1,loops ! !---------------------------------------------------------------- ! initialize the large scale variables ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector do i = its, ite mstep(i) = 1 @@ -607,7 +607,7 @@ SUBROUTINE wsm62D(t, q & ! denfac(i,k) = sqrt(den0/den(i,k)) ! enddo ! enddo -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte !!! CALL VREC( tvec1(its), den(its,k), ite-its+1) @@ -627,7 +627,6 @@ SUBROUTINE wsm62D(t, q & ! Inline expansion for fpvs ! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) ! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -!$acc parallel num_gangs(1) num_workers(1) vector_length(1) hsub = xls hvap = xlv0 cvap = cpv @@ -638,8 +637,7 @@ SUBROUTINE wsm62D(t, q & dldti=cvap-cice xai=-dldti/rv xbi=xai+hsub/(rv*ttp) -!$acc end parallel -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(tr) do k = kts, kte do i = its, ite @@ -667,7 +665,7 @@ SUBROUTINE wsm62D(t, q & ! initialize the variables for microphysical physics ! ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -713,7 +711,7 @@ SUBROUTINE wsm62D(t, q & !------------------------------------------------------------- ! Ni: ice crystal number concentraiton [HDC 5c] !------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(temp) do k = kts, kte do i = its, ite @@ -739,7 +737,7 @@ SUBROUTINE wsm62D(t, q & call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & work1,its,ite,kts,kte) ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kte, kts, -1 do i = its, ite @@ -762,7 +760,7 @@ SUBROUTINE wsm62D(t, q & delqrs1,dtcld,1,1) call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -792,7 +790,7 @@ SUBROUTINE wsm62D(t, q & call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & work1,its,ite,kts,kte) ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(supcol,xlf,coeres) do k = kte, kts, -1 do i = its, ite @@ -838,7 +836,7 @@ SUBROUTINE wsm62D(t, q & !--------------------------------------------------------------- ! Vice [ms-1] : fallout of ice crystal [HDC 5a] !--------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(xmi, diameter) do k = kte, kts, -1 do i = its, ite @@ -855,7 +853,7 @@ SUBROUTINE wsm62D(t, q & ! ! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kte, kts, -1 do i = its, ite @@ -866,7 +864,7 @@ SUBROUTINE wsm62D(t, q & call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & delqi,dtcld,1,0) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -882,7 +880,7 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(fallsum, fallsum_qsi, fallsum_qg) do i = its, ite fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) @@ -922,7 +920,7 @@ SUBROUTINE wsm62D(t, q & ! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] ! (T>T0: I->C) !--------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(supcol, xlf, supcolt, pfrzdtc, & !$acc temp, pfrzdtr) do k = kts, kte @@ -984,7 +982,7 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! update the slope parameters for microphysics computation ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -1002,7 +1000,7 @@ SUBROUTINE wsm62D(t, q & ! (ry88, y93, h85) ! work2: parameter associated with the ventilation effects(y93) ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -1021,7 +1019,7 @@ SUBROUTINE wsm62D(t, q & ! !=============================================================== ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(supsat, satdt, coeres) do k = kts, kte do i = its, ite @@ -1075,7 +1073,7 @@ SUBROUTINE wsm62D(t, q & ! !=============================================================== ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(supcol, supsat, satdt, ifsat, & !$acc temp, eacrs, xmi, diameter, vt2i, vt2r, vt2s, vt2g, vt2ave, acrfac, & !$acc egi, xlf, supice, coeres, xni0, roqi0, qimax, alpha2) @@ -1365,7 +1363,7 @@ SUBROUTINE wsm62D(t, q & ! check mass conservation of generation terms and feedback to the ! large scale ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(delta2, delta3, value, source, & !$acc factor, xlf, xlwork2) do k = kts, kte @@ -1558,7 +1556,6 @@ SUBROUTINE wsm62D(t, q & ! Inline expansion for fpvs ! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) ! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -!$acc parallel num_gangs(1) num_workers(1) vector_length(1) hsub = xls hvap = xlv0 cvap = cpv @@ -1569,8 +1566,7 @@ SUBROUTINE wsm62D(t, q & dldti=cvap-cice xai=-dldti/rv xbi=xai+hsub/(rv*ttp) -!$acc end parallel -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) private(tr) do k = kts, kte do i = its, ite @@ -1597,7 +1593,7 @@ SUBROUTINE wsm62D(t, q & ! if there exists additional water vapor condensated/if ! evaporation of cloud water is not enough to remove subsaturation ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -1617,7 +1613,7 @@ SUBROUTINE wsm62D(t, q & !---------------------------------------------------------------- ! padding for small values ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) do k = kts, kte do i = its, ite @@ -1787,7 +1783,10 @@ SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,hail_opt,allowed_to_read) xam_g = PI*deng/6. xbm_g = 3. xmu_g = 0. -!$acc update device(xam_g, xam_s, xam_r, n0g, pi) +!$acc update device(xam_g,xam_s,xam_r,n0g,pi,rslopermax,rslopesmax,rslopegmax, & +!$acc rsloperbmax,rslopesbmax,rslopegbmax,rsloper2max,rslopes2max, & +!$acc rslopeg2max,rsloper3max,rslopes3max,rslopeg3max,pidn0r,pidn0s, & +!$acc pidn0g,pvtr,pvts,bvtg,pvtg) call radar_init !+---+-----------------------------------------------------------------+ @@ -1822,8 +1821,9 @@ subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 ! -!$acc data create(n0sfac) -!$acc parallel vector_length(32) +!$acc data present(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt) & +!$acc create(n0sfac) +!$acc parallel !$acc loop gang vector collapse(2) private(supcol) do k = kts, kte do i = its, ite @@ -2097,22 +2097,17 @@ SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) real den(km), denfac(km), tk(km) real wi(km+1), zi(km+1), za(km+1) real qn(km), qr(km) -!#ifdef DEBUG -! real tmp(km),tmp1(km),tmp2(km),tmp3(km) -!#endif real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) -!!!$acc data present ( dzl, wwl, rql, precip, denl, denfacl, tkl ) +!$acc data present(denl,denfacl,tkl,dzl,wwl,rql,precip) ! ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang private(den,denfac,tk,allold,wd,decfl,za,zi,qa,qr,qmi,qpi,qn, & !$acc con1,dza,fa1,fa2,wa,was,wi,ww,za, & -!#ifdef DEBUG -!!$acc tmp,tmp1,tmp2,tmp3, & -!#endif !$acc kb, kt, kk, dql, qqd ) i_loop : do i=1,im + !$acc cache (ww, wd, wa, was, den, denfac, tk, wi, zi, za, qn, qr, dza, qa, qmi, qpi) ! ----------------------------------- ! skip for no precipitation for all layers precip(i) = 0.0 @@ -2339,7 +2334,7 @@ SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) end if enddo i_loop !$acc end parallel -!!$acc end data +!$acc end data END SUBROUTINE nislfv_rain_plm !------------------------------------------------------------------- @@ -2386,13 +2381,15 @@ SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, pr real X real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) !!$acc enter data create ( precip,precip1,precip2,dz,qq,qq2,wd,ww,wi,zi,den,denfac,tk) +!$acc data present(denl,denfacl,tkl,dzl,wwl,rql,rql2,precip1,precip2) ! ! -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang private(den,denfac,tk,allold,wd,wi,ww,zi, X, & -!$acc wi,fa1,fa2,ww,wa,was,za,dza,con1,qa,qr,qa2,qr2, & -!$acc qmi,qpi,kb,kt) +!$acc fa1,fa2,ww,wa,wa2,was,za,dza,con1,qa,qr,qn,qa2,qr2, & +!$acc qmi,qpi,kb,kt,zsum,qsum) i_loop : do i=1,im + !$acc cache(ww, wd, wa, wa2, was, den, denfac, tk, wi, zi, za, qn, qr, qr2, dza, qa, qa2, qmi, qpi) ! ----------------------------------- precip = 0.0 precip1(i) = 0.0 @@ -2569,7 +2566,7 @@ SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, pr qn = 0.0 kb=1 kt=1 - !$acc loop seq private(kk,tl,tl2,th,th2,qqd,qqh,qql,qn,zsum,qsum,dqh) + !$acc loop seq private(kk,tl,tl2,th,th2,qqd,qqh,qql,zsum,qsum,dqh) intp : do k=1,km ! find kb and kt if( zi(k).lt.za(km+1) ) then @@ -2658,6 +2655,7 @@ SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, pr enddo i_loop !$acc end parallel ! +!$acc end data END SUBROUTINE nislfv_rain_plm6 !+---+-----------------------------------------------------------------+ @@ -2973,7 +2971,9 @@ subroutine refl10cm_wsm6_1(qv1d, qr1d, qs1d, qg1d, & ! !$acc ze_rain, ze_snow, ze_graupel) !+---+ -!$acc parallel vector_length(32) +!$acc data present(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ) + +!$acc parallel !$acc loop gang private(k, temp, qv, pres, rho, rr, N0_r, ilamr, L_qr, & !$acc rs, N0_s, ilams, L_qs, rg, N0_g, ilamg, L_qg, melti, k_0, & !$acc ze_rain, ze_snow, ze_graupel) @@ -3124,8 +3124,7 @@ subroutine refl10cm_wsm6_1(qv1d, qr1d, qs1d, qg1d, & enddo enddo !$acc end parallel - -! !$acc end data +!$acc end data end subroutine refl10cm_wsm6_1 END MODULE module_mp_wsm6 diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F index 00508a4e1e..9efcfafac3 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F @@ -9,7 +9,8 @@ MODULE module_sf_noah_seaice #define FATAL_ERROR(M) call wrf_error_fatal( M ) #endif use module_sf_noahlsm, only : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, & - & HSTEP, HSTEP_gpu + & HSTEP, HSTEP_gpu, HSTEP_gpu_seaice + use mpas_timer, only : mpas_timer_start, mpas_timer_stop PUBLIC SFLX_SEAICE PUBLIC SFLX_SEAICE_gpu @@ -732,7 +733,6 @@ SUBROUTINE SFLX_SEAICE_gpu (ims,ime,its,ite,XICE,XICE_THRESHOLD, & !$acc FLX2,FLX3,SNOMLT,RUNOFF1,Q1) & !$acc create(SNDENS,SNCOND,SN_NEW,DF1,DSOIL,DTOT,FRZGRA,SNOWNG, & !$acc FRCSNO,FRCSOI,DF1A,T2V,T24,RCH,RR,ZSOIL) - ! ---------------------------------------------------------------------- ! INITIALIZATION ! ---------------------------------------------------------------------- @@ -743,7 +743,7 @@ SUBROUTINE SFLX_SEAICE_gpu (ims,ime,its,ite,XICE,XICE_THRESHOLD, & ! ---------------------------------------------------------------------- ! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO METERS ! ---------------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO I = ITS,ITE IF ( XICE(I) >= XICE_THRESHOLD ) THEN @@ -1013,47 +1013,71 @@ SUBROUTINE SFLX_SEAICE_gpu (ims,ime,its,ite,XICE,XICE_THRESHOLD, & ! the results. So I'm hard-coding the PENMAN ! value here, but perhaps this should go back ! into PENMAN for now. -!!! ENDIF -!!! ENDDO -!!!!$acc end parallel + ENDIF + ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND ! OTHER PARTIAL PRODUCTS AND SUMS FOR LATER CALCULATIONS. ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!! DO I = ITS,ITE -!!! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN CALL PENMAN_gpu (SFCTMP(I),SFCPRS(I),CH(I),TH2(I),PRCP(I),FDOWN(I),T24(I),SSOIL(I), & Q2(I),Q2SAT(I),ETP(I),RCH(I),RR(I),SNOWNG(I),FRZGRA(I), & DQSDT2(I),FLX2(I),EMISSI(I),T1(I)) -!!! ENDIF -!!! ENDDO -!!!!$acc end parallel + ENDIF + ENDDO +!$acc end parallel -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!! DO I = ITS,ITE -!!! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!NV!!$acc parallel vector_length(32) +!NV!!$acc loop gang vector +!NV! DO I = ITS,ITE +!NV! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!NV! ESNOW(I) = 0.0 +!NV! CALL SNOPAC_gpu (ETP(I),ETA(I),PRCP(I),SNOWNG(I), & +!NV! NSOIL,DT,DF1(I), & +!NV! Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & +!NV! SFCPRS(I),RCH(I),RR(I),SNCOVR(I),SNEQV(I),SNDENS(I), & +!NV! SNOWH(I),ZSOIL(1:NSOIL,I),TBOT, & +!NV! SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I), & +!NV! SEAICE_ALBEDO_OPT,XICE,XICE_THRESHOLD,ITS,ITE) +!NV!! ETA_KINEMATIC(I) = ESNOW(I) +!NV! ETA_KINEMATIC(I) = ETP(I) +!NV! ENDIF +!NV! ENDDO +!NV!!$acc end parallel + +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN ESNOW(I) = 0.0 - CALL SNOPAC_gpu (ETP(I),ETA(I),PRCP(I),SNOWNG(I), & - NSOIL,DT,DF1(I), & - Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & - SFCPRS(I),RCH(I),RR(I),SNCOVR(I),SNEQV(I),SNDENS(I), & - SNOWH(I),ZSOIL(1:NSOIL,I),TBOT, & - SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I), & - SEAICE_ALBEDO_OPT) -! ETA_KINEMATIC(I) = ESNOW(I) + ENDIF + ENDDO +!$acc end parallel + CALL SNOPAC_gpu1 (ETP,ETA,PRCP,SNOWNG, & + NSOIL,DT,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + SFCPRS,RCH,RR,SNCOVR,SNEQV,SNDENS, & + SNOWH,ZSOIL,TBOT, & + SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB, & + SEAICE_ALBEDO_OPT,XICE,XICE_THRESHOLD,ITS,ITE) +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN ETA_KINEMATIC(I) = ETP(I) -!!! ENDIF -!!! ENDDO -!!!!$acc end parallel + ENDIF + ENDDO +!$acc end parallel -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!! DO I = ITS,ITE -!!! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN IF ( SEAICE_SNOWDEPTH_OPT == 0 ) THEN ! @@ -1656,6 +1680,64 @@ SUBROUTINE SHFLX_gpu (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) ! ---------------------------------------------------------------------- END SUBROUTINE SHFLX_gpu + +!NV! (STC(1:NSOIL,I),NSOIL,DT,YY(I),ZZ1(I),ZSOIL(1:NSOIL,I),TBOT,DF1(I)) + SUBROUTINE SHFLX_gpu1 (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1,XICE,XICE_THRESHOLD,ITS,ITE) +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL,its,ite + REAL, INTENT(IN) :: DT,TBOT,XICE_THRESHOLD + REAL, DIMENSION(its:ite), INTENT(IN) :: YY,ZZ1,DF1,XICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL,its:ite) :: AI, BI, CI, STCF,RHSTS + INTEGER :: I,K + REAL, PARAMETER :: T0 = 273.15 + +!$acc data present(STC,YY,ZZ1,DF1,ZSOIL) create(AI, BI, CI, STCF,RHSTS) + +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN +! ---------------------------------------------------------------------- +! HRTICE ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + CALL HRTICE_gpu (RHSTS(1:NSOIL,I),STC(1:NSOIL,I),TBOT,NSOIL,ZSOIL(1:NSOIL,I),YY(I),ZZ1(I),DF1(I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) + ENDIF + ENDDO +!$acc end parallel + +!NV!!$acc parallel +!NV!!$acc loop gang vector +!NV! DO I = ITS,ITE +!NV! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!NV! CALL HSTEP_gpu (STCF(1:NSOIL,I),STC(1:NSOIL,I),RHSTS(1:NSOIL,I),DT,NSOIL,AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) +!NV! ENDIF +!NV! ENDDO +!NV!!$acc end parallel + CALL HSTEP_gpu_seaice (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI,XICE,XICE_THRESHOLD,ITS,ITE) + +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN + DO K = 1,NSOIL + STC (K,I) = STCF (K,I) + END DO + ENDIF + ENDDO +!$acc end parallel + +!$acc end data + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX_gpu1 ! ---------------------------------------------------------------------- SUBROUTINE SNOPAC (ETP,ETA,PRCP,SNOWNG, & @@ -2192,6 +2274,311 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,SNOWNG, & END SUBROUTINE SNOPAC_gpu ! ---------------------------------------------------------------------- +!NV!SNOPAC_gpu (ETP(I),ETA(I),PRCP(I),SNOWNG(I), & +!NV! NSOIL,DT,DF1(I), & +!NV! Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & +!NV! SFCPRS(I),RCH(I),RR(I),SNCOVR(I),SNEQV(I),SNDENS(I), & +!NV! SNOWH(I),ZSOIL(1:NSOIL,I),TBOT, & +!NV! SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I), & +!NV! SEAICE_ALBEDO_OPT) + SUBROUTINE SNOPAC_gpu1 (ETP,ETA,PRCP,SNOWNG, & + NSOIL,DT,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + SFCPRS,RCH,RR,SNCOVR,ESD,SNDENS, & + SNOWH,ZSOIL,TBOT, & + SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI, & + RIBB, SEAICE_ALBEDO_OPT,XICE,XICE_THRESHOLD,ITS,ITE) +! ---------------------------------------------------------------------- +! SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL,ITS,ITE + INTEGER :: K,I + LOGICAL, INTENT(IN), DIMENSION(its:ite) :: SNOWNG + REAL, INTENT(IN) :: DT, & + & TBOT,XICE_THRESHOLD + REAL, INTENT(IN), DIMENSION(its:ite) :: PRCP, DF1, Q2, SFCTMP, T24, & + TH2,FDOWN,SFCPRS,RCH,RR,EMISSI,XICE + REAL, INTENT(INOUT), DIMENSION(its:ite) :: ESD,FLX2,SNOWH,SNCOVR, & + & SNDENS, RIBB, ETP + REAL, INTENT(INOUT), DIMENSION(its:ite) :: T1 + REAL, INTENT(OUT), DIMENSION(its:ite) :: DEW,ESNOW, & + & FLX1,FLX3,SNOMLT + REAL, INTENT(OUT), DIMENSION(its:ite) :: SSOIL + REAL, DIMENSION(1:NSOIL,its:ite),INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: STC + REAL :: DENOM,DSOIL,DTOT, & + & ESNOW1, ESNOW2, ETA1,ETP1,ETP2, & + & ETANRG, EX, SEH, & + & SNCOND,T12, T12A, & + & T12B, T14 + REAL, DIMENSION(its:ite) :: YY,ZZ1 + REAL, DIMENSION(its:ite) :: ETA + INTEGER, INTENT(IN) :: SEAICE_ALBEDO_OPT + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + LSUBS = 2.83E+6, SNOEXP = 2.0 + +!$acc data present(SNOWNG,PRCP,DF1,Q2,SFCTMP,T24,TH2,FDOWN,SFCPRS,RCH,RR,EMISSI, & +!$acc XICE,ESD,FLX2,SNOWH,SNCOVR,SNDENS,RIBB,ETP,T1,DEW,ESNOW,FLX1, & +!$acc FLX3,SNOMLT,SSOIL,ZSOIL,STC,ETA) & +!$acc create(YY,ZZ1) + +!$acc parallel private(DENOM,DSOIL,DTOT,ESNOW1,ESNOW2) +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN +! ---------------------------------------------------------------------- +! SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE POTENTIAL RATE. +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + DEW(I) = 0. + ESNOW(I) = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + IF (ETP(I) <= 0.0) THEN + IF ( ( RIBB(I) >= 0.1 ) .AND. ( FDOWN(I) > 150.0 ) ) THEN + ETP(I)=(MIN(ETP(I)*(1.0-RIBB(I)),0.)*SNCOVR(I)/0.980 + ETP(I)*(0.980-SNCOVR(I)))/0.980 + ENDIF + ETP1 = ETP(I) * 0.001 + DEW(I) = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP(I)*((1.-SNCOVR(I))*LSUBC + SNCOVR(I)*LSUBS) + ELSE + ETP1 = ETP(I) * 0.001 + ESNOW(I) = ETP(I) + ESNOW1 = ESNOW(I)*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW(I)*LSUBS + ESNOW(I) = ETP(I)*SNCOVR(I) + ESNOW1 = ESNOW(I)*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW(I)*LSUBS + END IF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1(I) = 0.0 + IF (SNOWNG(I)) THEN + FLX1(I) = CPICE * PRCP(I) * (T1(I)- SFCTMP(I)) + ELSE + IF (PRCP(I) > 0.0) FLX1(I) = CPH2O * PRCP(I) * (T1(I)- SFCTMP(I)) +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + END IF + DSOIL = - (0.5 * ZSOIL (1,I)) + DTOT = SNOWH(I) + DSOIL + DENOM = 1.0+ DF1(I) / (DTOT * RR(I) * RCH(I)) +! surface emissivity weighted by snow cover fraction +! T12A = ( (FDOWN - FLX1 - FLX2 - & +! & ((SNCOVR*EMISSI_S)+EMISSI*(1.0-SNCOVR))*SIGMA *T24)/RCH & +! & + TH2 - SFCTMP - ETANRG/RCH ) / RR + T12A = ( (FDOWN(I) - FLX1(I) - FLX2(I) - EMISSI(I) * SIGMA * T24(I))/ RCH(I) & + + TH2(I) - SFCTMP(I) - ETANRG / RCH(I) ) / RR(I) + + T12B = DF1(I) * STC (1,I) / (DTOT * RR(I) * RCH(I)) + +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- + T12 = (SFCTMP(I) + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN + T1(I) = T12 + SSOIL(I) = DF1(I) * (T1(I)- STC (1,I)) / DTOT +! ESD = MAX (0.0, ESD- ETP2) + ESD(I) = MAX(0.0, ESD(I)-ESNOW2) + FLX3(I) = 0.0 + EX = 0.0 + + SNOMLT(I) = 0.0 +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- + ELSE + T1(I) = TFREEZ + SSOIL(I) = DF1(I) * (T1(I)- STC (1,I)) / DTOT + +! ---------------------------------------------------------------------- +! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. +! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. +! ---------------------------------------------------------------------- + + IF (ESD(I)-ESNOW2 <= ESDMIN) THEN + ESD(I) = 0.0 + EX = 0.0 + SNOMLT(I) = 0.0 + FLX3(I) = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + ESD(I) = ESD(I)-ESNOW2 + SEH = RCH(I) * (T1(I)- TH2(I)) + T14 = ( T1(I) * T1(I) ) * ( T1(I) * T1(I) ) + FLX3(I) = FDOWN(I) - FLX1(I)- FLX2(I)- EMISSI(I)*SIGMA * T14- SSOIL(I) - SEH - ETANRG + IF (FLX3(I) <= 0.0) FLX3(I) = 0.0 +! ---------------------------------------------------------------------- +! SNOWMELT REDUCTION DEPENDING ON SNOW COVER +! ---------------------------------------------------------------------- + EX = FLX3(I)*0.001/ LSUBF + +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + SNOMLT(I) = EX * DT + IF (ESD(I)- SNOMLT(I) >= ESDMIN) THEN + ESD(I) = ESD(I)- SNOMLT(I) + ELSE + ! + ! SNOWMELT EXCEEDS SNOW DEPTH + ! + EX = ESD(I) / DT + FLX3(I) = EX *1000.0* LSUBF + SNOMLT(I) = ESD(I) + + ESD(I) = 0.0 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! END OF 'T12 .LE. TFREEZ' IF-BLOCK +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! FOR SEA-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW +! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR IN SMFLX (BELOW). +! IF SEAICE (ICE==1) SKIP CALL TO SMFLX, SINCE NO SOIL MEDIUM FOR SEA-ICE +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. +! ---------------------------------------------------------------------- + + ZZ1(I) = 1.0 + YY(I) = STC (1,I) -0.5* SSOIL(I) * ZSOIL (1,I)* ZZ1(I)/ DF1(I) + ENDIF + ENDDO +!$acc end parallel + +!NV!!$acc parallel +!NV!!$acc loop gang vector +!NV! DO I = ITS,ITE +!NV! IF ( XICE(I) >= XICE_THRESHOLD ) THEN +!NV!! ---------------------------------------------------------------------- +!NV!! SHFLX WILL CALC/UPDATE THE ICE TEMPS. +!NV!! ---------------------------------------------------------------------- + +!NV! CALL SHFLX_gpu (STC(1:NSOIL,I),NSOIL,DT,YY(I),ZZ1(I),ZSOIL(1:NSOIL,I),TBOT,DF1(I)) +!NV! ENDIF +!NV! ENDDO +!NV!!$acc end parallel + +CALL SHFLX_gpu1 (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1,XICE,XICE_THRESHOLD,ITS,ITE) + + +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + SELECT CASE ( SEAICE_ALBEDO_OPT ) + + CASE DEFAULT + + IF (ESD(I) .GE. 0.01) THEN + CALL SNOWPACK_gpu (ESD(I),DT,SNOWH(I),SNDENS(I),T1(I),YY(I)) + ELSE + ESD(I) = 0.01 + SNOWH(I) = 0.05 +!KWM???? SNDENS = +!KWM???? SNCOND = + SNCOVR(I) = 1.0 + ENDIF + + CASE ( 1 ) ! Arctic sea-ice albedo from Mills (2011) + + IF ( ESD(I) >= 0.0001 ) THEN + CALL SNOWPACK_gpu (ESD(I),DT,SNOWH(I),SNDENS(I),T1(I),YY(I)) + ELSE + ESD(I) = 0.0001 + SNOWH(I) = 0.0005 + SNCOVR(I) = 0.005 + ENDIF + + END SELECT + ENDIF + ENDDO +!$acc end parallel +!$acc end data +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC_gpu1 +! ---------------------------------------------------------------------- + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) ! ---------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F index 737d9d2513..b6fea41cfb 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F @@ -664,7 +664,7 @@ subroutine seaice_noah_gpu( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THI NSOIL = NUM_SOIL_LAYERS TBOT = 271.36 -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) SEAICE_JLOOP1 : do J = JTS, JTE SEAICE_ILOOP1 : do I = ITS, ITE @@ -683,7 +683,7 @@ subroutine seaice_noah_gpu( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THI ENDDO SEAICE_JLOOP1 !$acc end parallel -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) SEAICE_JLOOP21 : do J = JTS, JTE SEAICE_ILOOP21 : do I = ITS, ITE @@ -966,7 +966,7 @@ subroutine seaice_noah_gpu( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THI & SNOMLT, SNCOVR, & !O & RUNOFF1, Q1, RIBB) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector collapse(2) SEAICE_JLOOP4 : do J = JTS, JTE SEAICE_ILOOP4 : do I = ITS, ITE diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F index 26d9db7c04..aa2f306fe9 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F @@ -2330,7 +2330,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & !$acc SMAV,ALB_RURAL,HCPCT_FASDAS,Q1,SNOMLT,SMCMAX,SMCREF,SMCDRY,SMCWLT, & !$acc ETPND1,ET,NROOT,DUMMY) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO I=its,ite HFX_PHY(I) = 0.0 ! initialize @@ -2369,7 +2369,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & JLOOP : DO J=jts,jte IF(ITIMESTEP.EQ.1)THEN -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO 50 I=its,ite !*** initialize soil conditions for IHOP 31 May case @@ -2413,7 +2413,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ! end of initialization over ocean !----------------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(PSFC,SATFLG,APES,APELM,SFCTH2) ILOOP1 : DO I=its,ite @@ -2489,7 +2489,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & !$acc end parallel !*** -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector ILOOP2 : DO I=its,ite IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block @@ -2510,7 +2510,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & DSOIL = 2 IRIOPTION=IRI_SCHEME -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector ILOOP31 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2551,7 +2551,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDDO ILOOP31 !$acc end parallel -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector ILOOP32 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2645,7 +2645,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ! IF( FASDAS == 1 ) THEN !!!$acc update device(SDA_HFX,RHO,SDA_QFX,QNORM) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(DZQ) ILOOP41 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2692,7 +2692,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, FASDAS, HCPCT_FASDAS & ! fasdas ) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector ILOOP43 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2705,7 +2705,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDDO ILOOP43 !$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector ILOOP51 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2732,7 +2732,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ! IF( FASDAS == 1 ) THEN !!!$acc update device(SDA_HFX,RHO) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(DZQ) ILOOP52 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -2750,7 +2750,6 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & ! ! END FASDAS ! - CALL SFLX_GLACIAL_gpu(ims,ime,its,ite,XLAND,ICE, & I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F @@ -2768,7 +2767,7 @@ SUBROUTINE lsm_gpu(DZ8W,QV3D,P8W3D,T3D,TSK, & & RIBB) !!!$acc update device(RC2,XLAI2) -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector ILOOP6 : DO I=its,ite IF((XLAND(I,J)-1.5).LT.0.)THEN @@ -3349,6 +3348,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 IF ( SIZE(BB ) < SLCATS .OR. & SIZE(DRYSMC) < SLCATS .OR. & + SIZE(HC ) < SLCATS .OR. & SIZE(F11 ) < SLCATS .OR. & SIZE(MAXSMC) < SLCATS .OR. & SIZE(REFSMC) < SLCATS .OR. & @@ -3361,7 +3361,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) ENDIF IF(SLTYPE.EQ.MMINSL)THEN DO LC=1,SLCATS - READ (19,*) IINDEX,BB(LC),DRYSMC(LC),F11(LC),MAXSMC(LC),& + READ (19,*) IINDEX,BB(LC),DRYSMC(LC),HC(LC),F11(LC),MAXSMC(LC),& REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC), & WLTSMC(LC), QTZ(LC) ENDDO @@ -3379,6 +3379,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_dm_bcast_integer ( IINDEX , 1 ) CALL wrf_dm_bcast_real ( BB , NSLTYPE ) CALL wrf_dm_bcast_real ( DRYSMC , NSLTYPE ) + CALL wrf_dm_bcast_real ( HC , NSLTYPE ) CALL wrf_dm_bcast_real ( F11 , NSLTYPE ) CALL wrf_dm_bcast_real ( MAXSMC , NSLTYPE ) CALL wrf_dm_bcast_real ( REFSMC , NSLTYPE ) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index 3861650874..bb0b58327d 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -46,7 +46,7 @@ MODULE module_sf_noahlsm INTEGER :: SLCATS INTEGER, PARAMETER :: NSLTYPE=30 CHARACTER(LEN=256) SLTYPE - REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & + REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,HC,F11, & MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ ! LSM GENERAL PARAMETERS @@ -67,7 +67,7 @@ MODULE module_sf_noahlsm !$acc Z0MINTBL,Z0MAXTBL,ZTOPVTBL,ZBOTVTBL,TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,& !$acc RSMAX_DATA,BARE,NATURAL,LOW_DENSITY_RESIDENTIAL, & !$acc HIGH_DENSITY_RESIDENTIAL,HIGH_INTENSITY_INDUSTRIAL,SLTYPE,SLCATS,BB, & -!$acc DRYSMC,F11,MAXSMC,REFSMC,SATPSI,SATDK,SATDW,WLTSMC,QTZ,SLPCATS, & +!$acc DRYSMC,HC,F11,MAXSMC,REFSMC,SATPSI,SATDK,SATDW,WLTSMC,QTZ,SLPCATS, & !$acc SLOPE_DATA,SBETA_DATA,FXEXP_DATA,CSOIL_DATA,SALP_DATA,REFDK_DATA, & !$acc REFKDT_DATA,FRZK_DATA,ZBOT_DATA,CZIL_DATA,SMLOW_DATA,SMHIGH_DATA,LVCOEF_DATA) @@ -1264,7 +1264,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & !$acc LAIMIN,LAIMAX,ALBEDOMIN,ALBEDOMAX,EMISSMIN,EMISSMAX, & !$acc Z0MIN,Z0MAX,SNEQVTMP) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1300,7 +1300,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1319,7 +1319,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & !$acc end parallel !urban -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1398,7 +1398,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION ! SUBROUTINE) ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1425,7 +1425,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND ! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1450,7 +1450,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES ! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1485,7 +1485,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! ---------------------------------------------------------------------- ! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1548,7 +1548,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF ! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1560,7 +1560,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & !$acc end parallel !urban -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1619,7 +1619,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM ! THE PREVIOUS TIMESTEP. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1674,7 +1674,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ! PENMAN EP SUBROUTINE THAT FOLLOWS ! ---------------------------------------------------------------------- ! FDOWN(I) = SOLDN(I) * (1.0- ALBEDO(I)) + LWDN(I) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1702,7 +1702,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & 'ALBEDO',ALBEDO(I),'SMC',SMC(1:NSOIL,I),'STC',STC(1:NSOIL,I),'SH2O',SH2O(1:NSOIL,I) endif -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -1817,7 +1817,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & !!!ENDDO !!!!$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite SNEQVTMP(I) = SNEQV(I) @@ -1842,7 +1842,7 @@ SUBROUTINE SFLX_gpu (ims,ime,its,ite,XLAND,ICE, & ,QFX_PHY,FASDAS,HCPCT_FASDAS, & its,ite,ETA_KINEMATIC,XLAND,ICE,SNEQVTMP) !fasdas -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -2388,7 +2388,7 @@ SUBROUTINE CANRES_gpu (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, & REAL, PARAMETER :: SLV = 2.501000E6 -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(FF,GX,RR,DELTA,PART) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -2981,7 +2981,7 @@ SUBROUTINE EVAPO_gpu1 (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT,ETPND1 -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(CMC2MS) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -3104,7 +3104,7 @@ SUBROUTINE EVAPO_gpu2 (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT,ETPND1 -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(CMC2MS) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -3831,7 +3831,7 @@ SUBROUTINE HRT_gpu1 (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! END FASDAS ! -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(CSOIL_LOC,ITAVG,HCPCT,DDZ,DTSDZ,SSOIL,DENOM,& !$acc QTOT,SICE,TSURF,TBK,TAVG,TSNSR,DDZ2,DF1K,DF1N,& !$acc DTSDZ2,TBK1) @@ -4112,7 +4112,7 @@ SUBROUTINE HRT_gpu2 (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! END FASDAS ! -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(CSOIL_LOC,ITAVG,HCPCT,DDZ,DTSDZ,SSOIL,DENOM,& !$acc QTOT,SICE,TSURF,TBK,TAVG,TSNSR,DDZ2,DF1K,DF1N,& !$acc DTSDZ2,TBK1) @@ -4453,6 +4453,70 @@ SUBROUTINE HSTEP_gpu (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) END SUBROUTINE HSTEP_gpu ! ---------------------------------------------------------------------- +!NV! (STCF(1:NSOIL,I),STC(1:NSOIL,I),RHSTS(1:NSOIL,I),DT,NSOIL,AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) + SUBROUTINE HSTEP_gpu_seaice (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI,XICE,XICE_THRESHOLD,ITS,ITE) +! ---------------------------------------------------------------------- +! SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, ITS, ITE + INTEGER :: K,I + + REAL, DIMENSION(its:ite), INTENT(IN) :: XICE + REAL, INTENT(IN) :: XICE_THRESHOLD + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN):: STCIN + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT):: STCOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT):: RHSTS + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT):: AI,BI,CI + REAL, DIMENSION(1:NSOIL,its:ite) :: RHSTSIN + REAL, DIMENSION(1:NSOIL,its:ite) :: CIIN + REAL :: DT + +!$acc data present(STCOUT,STCIN,RHSTS,AI,BI,CI,XICE) create(RHSTSIN,CIIN) + +!$acc parallel +!$acc loop gang vector + DO I = ITS,ITE + IF ( XICE(I) >= XICE_THRESHOLD ) THEN +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K,I) = RHSTS (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSIN (K,I) = RHSTS (K,I) + END DO + DO K = 1,NSOIL + CIIN (K,I) = CI (K,I) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIIN(1:NSOIL,I),RHSTSIN(1:NSOIL,I),RHSTS(1:NSOIL,I),NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K,I) = STCIN (K,I) + CI (K,I) + END DO + ENDIF + ENDDO +!$acc end parallel + +!$acc end data +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP_gpu_seaice +! ---------------------------------------------------------------------- + !!! (STCF(1:NSOIL,I),STC(1:NSOIL,I),RHSTS(1:NSOIL,I),DT,NSOIL,AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) SUBROUTINE HSTEP_gpu1 (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI,its,ite,XLAND,ICE,SNEQV) ! ---------------------------------------------------------------------- @@ -4474,7 +4538,7 @@ SUBROUTINE HSTEP_gpu1 (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI,its,ite,XLAND,ICE,SN REAL, DIMENSION(1:NSOIL) :: CIIN REAL :: DT -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(RHSTSIN,CIIN) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -4570,7 +4634,7 @@ SUBROUTINE HSTEP_gpu2 (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI,its,ite,XLAND,ICE,SN REAL, DIMENSION(1:NSOIL) :: CIIN REAL :: DT -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(RHSTSIN,CIIN) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5019,7 +5083,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & !$acc ETA_KINEMATIC,XLAND,ICE,SNEQV) & !$acc create(ET1,EC1,EDIR1,ETT1,ETP1,PRCP1,WETTY,ETA1,DF1,YY,ZZ1) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5098,7 +5162,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ! FASDAS ! -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(EALL_NOW,EFDIR,EFC,EFT) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5182,7 +5246,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & EDIR1,EC1,ET1, & DRIP,SFHEAD1RT,INFXS1RT,its,ite,XLAND,ICE,SNEQV,ETP) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(EALL_NOW,EFDIR,EFC,EFT) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5273,7 +5337,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- ! BASED ON ETP AND E VALUES, DETERMINE BETA ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5309,7 +5373,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5322,7 +5386,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ENDDO !$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(YYNUM) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -5375,7 +5439,7 @@ SUBROUTINE NOPAC_gpu (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & ,HCPCT_FASDAS,its,ite,XLAND,ICE,SNEQV) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -6367,7 +6431,7 @@ SUBROUTINE SHFLX_gpu1 (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & !!!!$acc end parallel CALL HSTEP_gpu1 (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI,its,ite,XLAND,ICE,SNEQV) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -6699,21 +6763,20 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ZSOIL REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT):: SMC,SH2O - REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & - SICE, SH2OA, SH2OFG - REAL :: DUMMY, EXCESS,PCPDRP,RHSCT,TRHSCT - REAL, DIMENSION(its:ite) :: FRZFACT - REAL :: FAC2 - REAL :: FLIMIT + REAL, DIMENSION(1:NSOIL) :: STCF,RHSTS + REAL, DIMENSION(1:NSOIL,its:ite) :: SICE, RHSTT, AI, BI, CI, SH2OFG, SH2OA + REAL :: EXCESS,TRHSCT + REAL, DIMENSION(its:ite) :: DUMMY,RHSCT,PCPDRP + REAL, DIMENSION(its:ite) :: FRZFACT,FAC2,FLIMIT REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT,INFXS1RT +!$acc data create(DUMMY,RHSCT,PCPDRP,SICE,FAC2,RHSTT,FLIMIT,AI,BI,CI,SH2OFG,SH2OA) ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) -!$acc loop gang vector private(DUMMY,RHSCT,TRHSCT,EXCESS,PCPDRP,SICE,FAC2, & -!$acc FLIMIT,RHSTT,AI,BI,CI,SH2OFG,SH2OA,SH2OFG) +!$acc parallel +!$acc loop gang vector private(TRHSCT,EXCESS) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN IF (ICE(I) == 0) THEN @@ -6722,16 +6785,16 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! ---------------------------------------------------------------------- ! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) ! ---------------------------------------------------------------------- - DUMMY = 0. + DUMMY(I) = 0. ! ---------------------------------------------------------------------- ! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING ! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL ! FALL TO THE GRND. ! ---------------------------------------------------------------------- - RHSCT = SHDFAC(I) * PRCP1(I)- EC(I) + RHSCT(I) = SHDFAC(I) * PRCP1(I)- EC(I) DRIP(I) = 0. - TRHSCT = DT * RHSCT + TRHSCT = DT * RHSCT(I) EXCESS = CMC(I) + TRHSCT ! ---------------------------------------------------------------------- @@ -6739,13 +6802,13 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! SOIL ! ---------------------------------------------------------------------- IF (EXCESS > CMCMAX(I)) DRIP(I) = EXCESS - CMCMAX(I) - PCPDRP = (1. - SHDFAC(I)) * PRCP1(I)+ DRIP(I) / DT + PCPDRP(I) = (1. - SHDFAC(I)) * PRCP1(I)+ DRIP(I) / DT ! ---------------------------------------------------------------------- ! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP ! DO K = 1,NSOIL - SICE (K) = SMC (K,I) - SH2O (K,I) + SICE (K,I) = SMC (K,I) - SH2O (K,I) END DO ! ---------------------------------------------------------------------- ! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE @@ -6770,11 +6833,11 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! According to Dr. Ken Mitchell's suggestion, add the second contraint ! to remove numerical instability of runoff and soil moisture ! FLIMIT is a limit value for FAC2 - FAC2=0.0 + FAC2(I)=0.0 DO K=1,NSOIL - FAC2=MAX(FAC2,SH2O(K,I)/SMCMAX(I)) + FAC2(I)=MAX(FAC2(I),SH2O(K,I)/SMCMAX(I)) ENDDO - CALL FAC2MIT_gpu(SMCMAX(I),FLIMIT) + CALL FAC2MIT_gpu(SMCMAX(I),FLIMIT(I)) ! ---------------------------------------------------------------------- ! FROZEN GROUND VERSION: @@ -6785,37 +6848,77 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & #ifdef WRF_HYDRO !DJG NDHMS/WRF-Hydro edit... Add previous ponded water to new precip drip... - PCPDRP = PCPDRP + SFHEAD1RT(I)/1000./DT ! convert SFHEAD1RT to (m/s) + PCPDRP(I) = PCPDRP(I) + SFHEAD1RT(I)/1000./DT ! convert SFHEAD1RT to (m/s) #endif + ENDIF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel - - IF ( ( (PCPDRP * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & - .OR. (FAC2 > FLIMIT) ) THEN - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2OFG,SH2O(1:NSOIL,I),DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) +![NV]!!$acc parallel vector_length(128) +![NV]!!$acc loop gang vector +![NV]!DO I=its,ite +![NV]! IF((XLAND(I)-1.5).LT.0.)THEN +![NV]! IF (ICE(I) == 0) THEN +![NV]! IF (SNEQV(I) == 0.0) THEN +![NV]! IF (ETP(I) > 0.0) THEN +![NV]! IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & +![NV]! .OR. (FAC2(I) > FLIMIT(I)) ) THEN +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) +![NV]! DO K = 1,NSOIL +![NV]! SH2OA (K,I) = (SH2O (K,I) + SH2OFG (K,I)) * 0.5 +![NV]! END DO +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2OA(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) +![NV]! +![NV]! ELSE +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & + ![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) +![NV]!! RUNOF = RUNOFF +![NV]! +![NV]! END IF +![NV]! ENDIF +![NV]! END IF +![NV]! ENDIF +![NV]! ENDIF +![NV]!ENDDO +![NV]!!$acc end parallel + + CALL SRT_gpu1_1 (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu1_1 (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,PCPDRP,its,ite) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) == 0.0) THEN + IF (ETP(I) > 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN DO K = 1,NSOIL - SH2OA (K) = (SH2O (K,I) + SH2OFG (K)) * 0.5 + SH2OA (K,I) = (SH2O (K,I) + SH2OFG (K,I)) * 0.5 END DO - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2OA,NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) - - ELSE - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) -! RUNOF = RUNOFF - END IF ENDIF END IF @@ -6823,6 +6926,23 @@ SUBROUTINE SMFLX_gpu1 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ENDIF ENDDO !$acc end parallel + + CALL SRT_gpu1_1 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu1_1 (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,PCPDRP,its,ite) + + CALL SRT_gpu1_2 (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu1_2 (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,PCPDRP,its,ite) +!$acc end data ! ---------------------------------------------------------------------- END SUBROUTINE SMFLX_gpu1 ! ---------------------------------------------------------------------- @@ -6871,7 +6991,7 @@ SUBROUTINE SMFLX_gpu2 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(DUMMY,RHSCT,TRHSCT,EXCESS,PCPDRP,SICE,FAC2, & !$acc FLIMIT,RHSTT,AI,BI,CI,SH2OFG,SH2OA,SH2OFG) DO I=its,ite @@ -7019,21 +7139,22 @@ SUBROUTINE SMFLX_gpu3 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ZSOIL REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT):: SMC,SH2O - REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & - SICE, SH2OA, SH2OFG - REAL :: DUMMY, EXCESS,PCPDRP,RHSCT,TRHSCT + REAL, DIMENSION(1:NSOIL) :: STCF,RHSTS + REAL, DIMENSION(1:NSOIL,its:ite) :: SICE,RHSTT,AI,BI,CI,SH2OFG,SH2OA + REAL :: EXCESS,TRHSCT + REAL, DIMENSION(its:ite) :: DUMMY, RHSCT,PCPDRP REAL, DIMENSION(its:ite) :: FRZFACT - REAL :: FAC2 - REAL :: FLIMIT + REAL, DIMENSION(its:ite) :: FAC2 + REAL, DIMENSION(its:ite) :: FLIMIT REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT,INFXS1RT +!$acc data create(SICE,RHSTT,AI,BI,CI,SH2OFG,SH2OA,DUMMY, RHSCT,PCPDRP,FRZFACT,FAC2,FLIMIT) ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) -!$acc loop gang vector private(DUMMY,RHSCT,TRHSCT,EXCESS,PCPDRP,SICE,FAC2, & -!$acc FLIMIT,RHSTT,AI,BI,CI,SH2OFG,SH2OA,SH2OFG) +!$acc parallel +!$acc loop gang vector private(TRHSCT,EXCESS) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN IF (ICE(I) == 0) THEN @@ -7041,16 +7162,16 @@ SUBROUTINE SMFLX_gpu3 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! ---------------------------------------------------------------------- ! COMPUTE THE RIGHT HAND SIDE OF THE CANOPY EQN TERM ( RHSCT ) ! ---------------------------------------------------------------------- - DUMMY = 0. + DUMMY(I) = 0. ! ---------------------------------------------------------------------- ! CONVERT RHSCT (A RATE) TO TRHSCT (AN AMOUNT) AND ADD IT TO EXISTING ! CMC. IF RESULTING AMT EXCEEDS MAX CAPACITY, IT BECOMES DRIP AND WILL ! FALL TO THE GRND. ! ---------------------------------------------------------------------- - RHSCT = SHDFAC(I) * PRCP1(I)- EC(I) + RHSCT(I) = SHDFAC(I) * PRCP1(I)- EC(I) DRIP(I) = 0. - TRHSCT = DT * RHSCT + TRHSCT = DT * RHSCT(I) EXCESS = CMC(I) + TRHSCT ! ---------------------------------------------------------------------- @@ -7058,13 +7179,13 @@ SUBROUTINE SMFLX_gpu3 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! SOIL ! ---------------------------------------------------------------------- IF (EXCESS > CMCMAX(I)) DRIP(I) = EXCESS - CMCMAX(I) - PCPDRP = (1. - SHDFAC(I)) * PRCP1(I)+ DRIP(I) / DT + PCPDRP(I) = (1. - SHDFAC(I)) * PRCP1(I)+ DRIP(I) / DT ! ---------------------------------------------------------------------- ! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP ! DO K = 1,NSOIL - SICE (K) = SMC (K,I) - SH2O (K,I) + SICE (K,I) = SMC (K,I) - SH2O (K,I) END DO ! ---------------------------------------------------------------------- ! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE @@ -7089,11 +7210,11 @@ SUBROUTINE SMFLX_gpu3 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! According to Dr. Ken Mitchell's suggestion, add the second contraint ! to remove numerical instability of runoff and soil moisture ! FLIMIT is a limit value for FAC2 - FAC2=0.0 + FAC2(I)=0.0 DO K=1,NSOIL - FAC2=MAX(FAC2,SH2O(K,I)/SMCMAX(I)) + FAC2(I)=MAX(FAC2(I),SH2O(K,I)/SMCMAX(I)) ENDDO - CALL FAC2MIT_gpu(SMCMAX(I),FLIMIT) + CALL FAC2MIT_gpu(SMCMAX(I),FLIMIT(I)) ! ---------------------------------------------------------------------- ! FROZEN GROUND VERSION: @@ -7104,43 +7225,96 @@ SUBROUTINE SMFLX_gpu3 (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & #ifdef WRF_HYDRO !DJG NDHMS/WRF-Hydro edit... Add previous ponded water to new precip drip... - PCPDRP = PCPDRP + SFHEAD1RT(I)/1000./DT ! convert SFHEAD1RT to (m/s) + PCPDRP(I) = PCPDRP(I) + SFHEAD1RT(I)/1000./DT ! convert SFHEAD1RT to (m/s) #endif + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel - - IF ( ( (PCPDRP * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & - .OR. (FAC2 > FLIMIT) ) THEN - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2OFG,SH2O(1:NSOIL,I),DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) +![NV]!!$acc parallel vector_length(128) +![NV]!!$acc loop gang vector +![NV]!DO I=its,ite +![NV]! IF((XLAND(I)-1.5).LT.0.)THEN +![NV]! IF (ICE(I) == 0) THEN +![NV]! IF (SNEQV(I) /= 0.0) THEN +![NV]! IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & +![NV]! .OR. (FAC2(I) > FLIMIT(I)) ) THEN +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) +![NV]! DO K = 1,NSOIL +![NV]! SH2OA (K,I) = (SH2O (K,I) + SH2OFG (K,I)) * 0.5 +![NV]! END DO +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2OA(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) + +![NV]! ELSE +![NV]! CALL SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) +![NV]! CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) +![NV]!! RUNOF = RUNOFF +![NV]! +![NV]! END IF +![NV]! END IF +![NV]! ENDIF +![NV]! ENDIF +![NV]!ENDDO + + CALL SRT_gpu3_1 (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu3_1 (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,PCPDRP,its,ite) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) /= 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN DO K = 1,NSOIL - SH2OA (K) = (SH2O (K,I) + SH2OFG (K)) * 0.5 + SH2OA (K,I) = (SH2O (K,I) + SH2OFG (K,I)) * 0.5 END DO - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2OA,NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) - - ELSE - CALL SRT_gpu (RHSTT,EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP,ZSOIL(1:NSOIL,I), & - DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & - RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE,AI,BI,CI, & - SFHEAD1RT(I),INFXS1RT(I)) - CALL SSTEP_gpu (SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),CMC(I),RHSTT,RHSCT,DT,NSOIL,SMCMAX(I), & - CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE,AI,BI,CI,INFXS1RT(I)) -! RUNOF = RUNOFF - END IF END IF ENDIF ENDIF ENDDO !$acc end parallel + + CALL SRT_gpu3_1 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu3_1 (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,PCPDRP,its,ite) + + CALL SRT_gpu3_2 (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & + DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,its,ite) + + CALL SSTEP_gpu3_2 (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,PCPDRP,its,ite) + +!$acc end data ! ---------------------------------------------------------------------- END SUBROUTINE SMFLX_gpu3 ! ---------------------------------------------------------------------- @@ -8056,7 +8230,7 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & !$acc create(EDIR1,EC1,ET1,ETT1,ETNS1,ESNOW1,ESNOW2,PRCP1,ETP1, & !$acc ETANRG,SSOIL1,T11,YY,ZZ1) -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(ETP1N) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -8162,7 +8336,7 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, & FXEXP,SFHEAD1RT,ETPND1,its,ite,XLAND,ICE,SNEQV,ETP,SNCOVR) ! ---------------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(DENOM,DSOIL,DTOT, & !$acc ETP3, EX, & !$acc SEH, & @@ -8419,7 +8593,7 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE ! SKIN TEMP VALUE AS REVISED BY SHFLX. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -8465,7 +8639,7 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS ! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. ! ---------------------------------------------------------------------- -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -8481,7 +8655,7 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ENDDO !$acc end parallel -!$acc parallel vector_length(128) +!$acc parallel !$acc loop gang vector private(SNCOND) DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -9575,84 +9749,1782 @@ SUBROUTINE SRT_gpu (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & END SUBROUTINE SRT_gpu ! ---------------------------------------------------------------------- - SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & - NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & - AI,BI,CI, INFXS1RT) +![NV]! SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) + SUBROUTINE SRT_gpu1_1 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,its,ite) ! ---------------------------------------------------------------------- -! SUBROUTINE SSTEP +! SUBROUTINE SRT ! ---------------------------------------------------------------------- -! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE -! CONTENT VALUES. +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NSOIL - INTEGER :: I, K, KK11 + INTEGER, INTENT(IN) :: NSOIL,its,ite + INTEGER :: IALP1, IOHINF, I, J, JJ, K, KS -!!DJG NDHMS/WRF-Hydro edit... - REAL, INTENT(INOUT) :: INFXS1RT - REAL :: AVAIL +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,CHCKSM + REAL, DIMENSION(its:ite), INTENT(IN) :: XLAND,SNEQV,ETP,FAC2,FLIMIT + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE - REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX - REAL, INTENT(OUT) :: RUNOFF3 - REAL, INTENT(INOUT) :: CMC - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI - REAL, DIMENSION(1:NSOIL) :: RHSTTin - REAL, DIMENSION(1:NSOIL) :: CIin - REAL :: DDZ, RHSCT, STOT, WPLUS + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: EDIR, PCPDRP, DWSAT, DKSAT, SMCMAX, & + BEXP, SMCWLT, SLOPE, KDT, FRZX + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET, SH2O, SH2OA, ZSOIL, SICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +!$acc parallel +!$acc loop gang vector private(DMAX,ACRT, DD, DDT, DDZ, DDZ2, DENOM,DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & +!$acc FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM,PX, SICEMAX,SLOPX, SMCAV, SSTT, & +!$acc SUM, VAL, WCND, WCND2, WDF, WDF2,IALP1, IOHINF,SFCWATR,CHCKSM) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) == 0.0) THEN + IF (ETP(I) > 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN ! ---------------------------------------------------------------------- -! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE -! TRI-DIAGONAL MATRIX ROUTINE. -! ---------------------------------------------------------------------- - DO K = 1,NSOIL - RHSTT (K) = RHSTT (K) * DT - AI (K) = AI (K) * DT - BI (K) = 1. + BI (K) * DT - CI (K) = CI (K) * DT - END DO +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS,I) > SICEMAX) SICEMAX = SICE (KS,I) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP(I) + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1(I) = 0.0 + INFXS1RT(I) = 0.0 +#else + PDDUM = PCPDRP(I) + RUNOFF1(I) = 0.0 +#endif + + + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP(I) /= 0.0) THEN +#endif + DT1 = DT /86400. + SMCAV = SMCMAX(I) - SMCWLT(I) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1,I)* SMCAV + + DICE = - ZSOIL (1,I) * SICE (1,I) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1,I) + SICE (1,I) - SMCWLT(I))/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1,I) - ZSOIL (KS,I) ) * SICE (KS,I) + DMAX (KS) = (ZSOIL (KS -1,I) - ZSOIL (KS,I))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS,I) + SICE (KS,I) & + - SMCWLT(I))/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT(I) * DT1)) + DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else + PX = PCPDRP(I) * DT +#endif + IF (PX < 0.0) PX = 0.0 + + + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX(I) / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1(I) = SFCWATR - INFMAX +#else + IF (PCPDRP(I) > INFMAX) THEN + RUNOFF1(I) = PCPDRP(I) - INFMAX +#endif + INFXS1RT(I) = RUNOFF1(I)*DT*1000. + PDDUM = INFMAX + END IF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2,I) ) + AI (1,I) = 0.0 + BI (1,I) = WDF * DDZ / ( - ZSOIL (1,I) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1,I) = - BI (1,I) + DSMDZ = ( SH2O (1,I) - SH2O (2,I) ) / ( - .5 * ZSOIL (2,I) ) + RHSTT (1,I) = (WDF * DSMDZ + WCND- PDDUM + EDIR(I) + ET (1,I))/ ZSOIL (1,I) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR(I) + ET (1,I) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1,I) - ZSOIL (K,I)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K,I) + CALL WDFCND_gpu (WDF2,WCND2,MXSMC2,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1,I) - ZSOIL (K +1,I)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K,I) - SH2O (K +1,I)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K,I) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE(I) + CALL WDFCND_gpu (WDF2,WCND2,SH2OA (NSOIL,I),SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K,I) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K,I) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K,I) = NUMER / ( - DENOM2) + AI (K,I) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K,I) = - ( AI (K,I) + CI (K,I) ) + IF (K .eq. NSOIL) THEN + RUNOFF2(I) = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END IF + ENDIF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + END SUBROUTINE SRT_gpu1_1 + +![NV]! SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) + SUBROUTINE SRT_gpu1_2 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL,its,ite + INTEGER :: IALP1, IOHINF, I, J, JJ, K, KS + +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,CHCKSM + REAL, DIMENSION(its:ite), INTENT(IN) :: XLAND,SNEQV,ETP,FAC2,FLIMIT + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: EDIR, PCPDRP, DWSAT, DKSAT, SMCMAX, & + BEXP, SMCWLT, SLOPE, KDT, FRZX + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET, SH2O, SH2OA, ZSOIL, SICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +!$acc parallel +!$acc loop gang vector private(DMAX,ACRT, DD, DDT, DDZ, DDZ2, DENOM,DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & +!$acc FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM,PX, SICEMAX,SLOPX, SMCAV, SSTT, & +!$acc SUM, VAL, WCND, WCND2, WDF, WDF2,IALP1, IOHINF,SFCWATR,CHCKSM) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) == 0.0) THEN + IF (ETP(I) > 0.0) THEN + IF ( ( (PCPDRP(I) * DT) <= (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .AND. (FAC2(I) <= FLIMIT(I)) ) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS,I) > SICEMAX) SICEMAX = SICE (KS,I) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP(I) + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1(I) = 0.0 + INFXS1RT(I) = 0.0 +#else + PDDUM = PCPDRP(I) + RUNOFF1(I) = 0.0 +#endif + + + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP(I) /= 0.0) THEN +#endif + DT1 = DT /86400. + SMCAV = SMCMAX(I) - SMCWLT(I) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1,I)* SMCAV + + DICE = - ZSOIL (1,I) * SICE (1,I) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1,I) + SICE (1,I) - SMCWLT(I))/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1,I) - ZSOIL (KS,I) ) * SICE (KS,I) + DMAX (KS) = (ZSOIL (KS -1,I) - ZSOIL (KS,I))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS,I) + SICE (KS,I) & + - SMCWLT(I))/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT(I) * DT1)) + DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else + PX = PCPDRP(I) * DT +#endif + IF (PX < 0.0) PX = 0.0 + + + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX(I) / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1(I) = SFCWATR - INFMAX +#else + IF (PCPDRP(I) > INFMAX) THEN + RUNOFF1(I) = PCPDRP(I) - INFMAX +#endif + INFXS1RT(I) = RUNOFF1(I)*DT*1000. + PDDUM = INFMAX + END IF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2,I) ) + AI (1,I) = 0.0 + BI (1,I) = WDF * DDZ / ( - ZSOIL (1,I) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1,I) = - BI (1,I) + DSMDZ = ( SH2O (1,I) - SH2O (2,I) ) / ( - .5 * ZSOIL (2,I) ) + RHSTT (1,I) = (WDF * DSMDZ + WCND- PDDUM + EDIR(I) + ET (1,I))/ ZSOIL (1,I) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR(I) + ET (1,I) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1,I) - ZSOIL (K,I)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K,I) + CALL WDFCND_gpu (WDF2,WCND2,MXSMC2,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1,I) - ZSOIL (K +1,I)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K,I) - SH2O (K +1,I)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K,I) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE(I) + CALL WDFCND_gpu (WDF2,WCND2,SH2OA (NSOIL,I),SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K,I) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K,I) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K,I) = NUMER / ( - DENOM2) + AI (K,I) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K,I) = - ( AI (K,I) + CI (K,I) ) + IF (K .eq. NSOIL) THEN + RUNOFF2(I) = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END IF + ENDIF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + END SUBROUTINE SRT_gpu1_2 + +![NV]! SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) + SUBROUTINE SRT_gpu3_1 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL,its,ite + INTEGER :: IALP1, IOHINF, I, J, JJ, K, KS + +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,CHCKSM + REAL, DIMENSION(its:ite), INTENT(IN) :: XLAND,SNEQV,FAC2,FLIMIT + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: EDIR, PCPDRP, DWSAT, DKSAT, SMCMAX, & + BEXP, SMCWLT, SLOPE, KDT, FRZX + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET, SH2O, SH2OA, ZSOIL, SICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +!$acc parallel +!$acc loop gang vector private(DMAX,ACRT, DD, DDT, DDZ, DDZ2, DENOM,DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & +!$acc FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM,PX, SICEMAX,SLOPX, SMCAV, SSTT, & +!$acc SUM, VAL, WCND, WCND2, WDF, WDF2,IALP1, IOHINF,SFCWATR,CHCKSM) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) /= 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS,I) > SICEMAX) SICEMAX = SICE (KS,I) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP(I) + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1(I) = 0.0 + INFXS1RT(I) = 0.0 +#else + PDDUM = PCPDRP(I) + RUNOFF1(I) = 0.0 +#endif + + + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP(I) /= 0.0) THEN +#endif + DT1 = DT /86400. + SMCAV = SMCMAX(I) - SMCWLT(I) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1,I)* SMCAV + + DICE = - ZSOIL (1,I) * SICE (1,I) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1,I) + SICE (1,I) - SMCWLT(I))/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1,I) - ZSOIL (KS,I) ) * SICE (KS,I) + DMAX (KS) = (ZSOIL (KS -1,I) - ZSOIL (KS,I))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS,I) + SICE (KS,I) & + - SMCWLT(I))/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT(I) * DT1)) + DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else + PX = PCPDRP(I) * DT +#endif + IF (PX < 0.0) PX = 0.0 + + + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX(I) / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1(I) = SFCWATR - INFMAX +#else + IF (PCPDRP(I) > INFMAX) THEN + RUNOFF1(I) = PCPDRP(I) - INFMAX +#endif + INFXS1RT(I) = RUNOFF1(I)*DT*1000. + PDDUM = INFMAX + END IF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2,I) ) + AI (1,I) = 0.0 + BI (1,I) = WDF * DDZ / ( - ZSOIL (1,I) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1,I) = - BI (1,I) + DSMDZ = ( SH2O (1,I) - SH2O (2,I) ) / ( - .5 * ZSOIL (2,I) ) + RHSTT (1,I) = (WDF * DSMDZ + WCND- PDDUM + EDIR(I) + ET (1,I))/ ZSOIL (1,I) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR(I) + ET (1,I) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1,I) - ZSOIL (K,I)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K,I) + CALL WDFCND_gpu (WDF2,WCND2,MXSMC2,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1,I) - ZSOIL (K +1,I)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K,I) - SH2O (K +1,I)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K,I) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE(I) + CALL WDFCND_gpu (WDF2,WCND2,SH2OA (NSOIL,I),SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K,I) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K,I) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K,I) = NUMER / ( - DENOM2) + AI (K,I) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K,I) = - ( AI (K,I) + CI (K,I) ) + IF (K .eq. NSOIL) THEN + RUNOFF2(I) = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END IF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + END SUBROUTINE SRT_gpu3_1 + +![NV]! SRT_gpu (RHSTT(1:NSOIL,I),EDIR(I),ET(1:NSOIL,I),SH2O(1:NSOIL,I),SH2O(1:NSOIL,I),NSOIL,PCPDRP(I),ZSOIL(1:NSOIL,I), & +![NV]! DWSAT(I),DKSAT(I),SMCMAX(I),BEXP(I),RUNOFF1(I), & +![NV]! RUNOFF2(I),DT,SMCWLT(I),SLOPE(I),KDT(I),FRZFACT(I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I), & +![NV]! SFHEAD1RT(I),INFXS1RT(I)) + SUBROUTINE SRT_gpu3_2 (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & + ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL,its,ite + INTEGER :: IALP1, IOHINF, I, J, JJ, K, KS + +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, DIMENSION(its:ite), INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,CHCKSM + REAL, DIMENSION(its:ite), INTENT(IN) :: XLAND,SNEQV,FAC2,FLIMIT + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: EDIR, PCPDRP, DWSAT, DKSAT, SMCMAX, & + BEXP, SMCWLT, SLOPE, KDT, FRZX + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ET, SH2O, SH2OA, ZSOIL, SICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DMAX + REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & + FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX, SICEMAX,SLOPX, SMCAV, SSTT, & + SUM, VAL, WCND, WCND2, WDF, WDF2 + INTEGER, PARAMETER :: CVFRZ = 3 + +!$acc parallel +!$acc loop gang vector private(DMAX,ACRT, DD, DDT, DDZ, DDZ2, DENOM,DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & +!$acc FCR,INFMAX,MXSMC,MXSMC2,NUMER,PDDUM,PX, SICEMAX,SLOPX, SMCAV, SSTT, & +!$acc SUM, VAL, WCND, WCND2, WDF, WDF2,IALP1, IOHINF,SFCWATR,CHCKSM) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) /= 0.0) THEN + IF ( ( (PCPDRP(I) * DT) <= (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .AND. (FAC2(I) <= FLIMIT(I)) ) THEN + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REFERENCE FROZEN GROUND PARAMETER, CVFRZ, IS A SHAPE PARAMETER OF +! AREAL DISTRIBUTION FUNCTION OF SOIL ICE CONTENT WHICH EQUALS 1/CV. +! CV IS A COEFFICIENT OF SPATIAL VARIATION OF SOIL ICE CONTENT. BASED +! ON FIELD DATA CV DEPENDS ON AREAL MEAN OF FROZEN DEPTH, AND IT CLOSE +! TO CONSTANT = 0.6 IF AREAL MEAN FROZEN DEPTH IS ABOVE 20 CM. THAT IS +! WHY PARAMETER CVFRZ = 3 (INT{1/0.6*0.6}). +! CURRENT LOGIC DOESN'T ALLOW CVFRZ BE BIGGER THAN 3 +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! LET SICEMAX BE THE GREATEST, IF ANY, FROZEN WATER CONTENT WITHIN SOIL +! LAYERS. +! ---------------------------------------------------------------------- + IOHINF = 1 + SICEMAX = 0.0 + DO KS = 1,NSOIL + IF (SICE (KS,I) > SICEMAX) SICEMAX = SICE (KS,I) +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF +! ---------------------------------------------------------------------- + END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP(I) + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1(I) = 0.0 + INFXS1RT(I) = 0.0 +#else + PDDUM = PCPDRP(I) + RUNOFF1(I) = 0.0 +#endif + + + +! ---------------------------------------------------------------------- +! MODIFIED BY Q. DUAN, 5/16/94 +! ---------------------------------------------------------------------- +! IF (IOHINF == 1) THEN + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP(I) /= 0.0) THEN +#endif + DT1 = DT /86400. + SMCAV = SMCMAX(I) - SMCWLT(I) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DMAX (1)= - ZSOIL (1,I)* SMCAV + + DICE = - ZSOIL (1,I) * SICE (1,I) + DMAX (1)= DMAX (1)* (1.0- (SH2OA (1,I) + SICE (1,I) - SMCWLT(I))/ & + SMCAV) + + DD = DMAX (1) + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! ---------------------------------------------------------------------- + DO KS = 2,NSOIL + + DICE = DICE+ ( ZSOIL (KS -1,I) - ZSOIL (KS,I) ) * SICE (KS,I) + DMAX (KS) = (ZSOIL (KS -1,I) - ZSOIL (KS,I))* SMCAV + DMAX (KS) = DMAX (KS)* (1.0- (SH2OA (KS,I) + SICE (KS,I) & + - SMCWLT(I))/ SMCAV) + DD = DD+ DMAX (KS) +! ---------------------------------------------------------------------- +! VAL = (1.-EXP(-KDT*SQRT(DT1))) +! IN BELOW, REMOVE THE SQRT IN ABOVE +! ---------------------------------------------------------------------- + END DO + VAL = (1. - EXP ( - KDT(I) * DT1)) + DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else + PX = PCPDRP(I) * DT +#endif + IF (PX < 0.0) PX = 0.0 + + + +! ---------------------------------------------------------------------- +! FROZEN GROUND VERSION: +! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS +! ---------------------------------------------------------------------- + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * FRZX(I) / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** ( CVFRZ - J)) / FLOAT (K) + END DO + FCR = 1. - EXP ( - ACRT) * SUM + END IF + +! ---------------------------------------------------------------------- +! CORRECTION OF INFILTRATION LIMITATION: +! IF INFMAX .LE. HYDROLIC CONDUCTIVITY ASSIGN INFMAX THE VALUE OF +! HYDROLIC CONDUCTIVITY +! ---------------------------------------------------------------------- +! MXSMC = MAX ( SH2OA(1), SH2OA(2) ) + INFMAX = INFMAX * FCR + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + INFMAX = MAX (INFMAX,WCND) + + INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1(I) = SFCWATR - INFMAX +#else + IF (PCPDRP(I) > INFMAX) THEN + RUNOFF1(I) = PCPDRP(I) - INFMAX +#endif + INFXS1RT(I) = RUNOFF1(I)*DT*1000. + PDDUM = INFMAX + END IF + +! ---------------------------------------------------------------------- +! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE +! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC = MAX(SH2OA(1), SH2OA(2))' +! ---------------------------------------------------------------------- + END IF + + MXSMC = SH2OA (1,I) + CALL WDFCND_gpu (WDF,WCND,MXSMC,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1. / ( - .5 * ZSOIL (2,I) ) + AI (1,I) = 0.0 + BI (1,I) = WDF * DDZ / ( - ZSOIL (1,I) ) + +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THE TOP LAYER AFTER CALC'NG THE VERTICAL SOIL MOISTURE +! GRADIENT BTWN THE TOP AND NEXT TO TOP LAYERS. +! ---------------------------------------------------------------------- + CI (1,I) = - BI (1,I) + DSMDZ = ( SH2O (1,I) - SH2O (2,I) ) / ( - .5 * ZSOIL (2,I) ) + RHSTT (1,I) = (WDF * DSMDZ + WCND- PDDUM + EDIR(I) + ET (1,I))/ ZSOIL (1,I) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + SSTT = WDF * DSMDZ + WCND+ EDIR(I) + ET (1,I) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL + DENOM2 = (ZSOIL (K -1,I) - ZSOIL (K,I)) + IF (K /= NSOIL) THEN + +! ---------------------------------------------------------------------- +! AGAIN, TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN +! LINE BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: +! 'MXSMC2 = MAX (SH2OA(K), SH2OA(K+1))' +! ---------------------------------------------------------------------- + SLOPX = 1. + + MXSMC2 = SH2OA (K,I) + CALL WDFCND_gpu (WDF2,WCND2,MXSMC2,SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) +! ----------------------------------------------------------------------- +! CALC SOME PARTIAL PRODUCTS FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + DENOM = (ZSOIL (K -1,I) - ZSOIL (K +1,I)) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT +! ---------------------------------------------------------------------- + DSMDZ2 = (SH2O (K,I) - SH2O (K +1,I)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K,I) = - WDF2 * DDZ2 / DENOM2 + + ELSE +! ---------------------------------------------------------------------- +! SLOPE OF BOTTOM LAYER IS INTRODUCED +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! RETRIEVE THE SOIL WATER DIFFUSIVITY AND HYDRAULIC CONDUCTIVITY FOR +! THIS LAYER +! ---------------------------------------------------------------------- + SLOPX = SLOPE(I) + CALL WDFCND_gpu (WDF2,WCND2,SH2OA (NSOIL,I),SMCMAX(I),BEXP(I),DKSAT(I),DWSAT(I), & + SICEMAX) + +! ---------------------------------------------------------------------- +! CALC A PARTIAL PRODUCT FOR LATER USE IN CALC'NG RHSTT +! ---------------------------------------------------------------------- + +! ---------------------------------------------------------------------- +! SET MATRIX COEF CI TO ZERO +! ---------------------------------------------------------------------- + DSMDZ2 = 0.0 + CI (K,I) = 0.0 +! ---------------------------------------------------------------------- +! CALC RHSTT FOR THIS LAYER AFTER CALC'NG ITS NUMERATOR +! ---------------------------------------------------------------------- + END IF + NUMER = (WDF2 * DSMDZ2) + SLOPX * WCND2- (WDF * DSMDZ) & + - WCND+ ET (K,I) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER +! ---------------------------------------------------------------------- + RHSTT (K,I) = NUMER / ( - DENOM2) + AI (K,I) = - WDF * DDZ / DENOM2 + +! ---------------------------------------------------------------------- +! RESET VALUES OF WDF, WCND, DSMDZ, AND DDZ FOR LOOP TO NEXT LYR +! RUNOFF2: SUB-SURFACE OR BASEFLOW RUNOFF +! ---------------------------------------------------------------------- + BI (K,I) = - ( AI (K,I) + CI (K,I) ) + IF (K .eq. NSOIL) THEN + RUNOFF2(I) = SLOPX * WCND2 + END IF + IF (K .ne. NSOIL) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END IF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + END SUBROUTINE SRT_gpu3_2 + + SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DDZ, RHSCT, STOT, WPLUS + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTin (K) = RHSTT (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ + STOT = SH2OOUT (K) + SICE (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1) + ELSE + DDZ = ZSOIL(K-2)-ZSOIL(K-1) + END IF + + AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1) = SMC(K-1) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1) = SMCMAX + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT = INFXS1RT + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMC + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE SSTEP_gpu (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT) +!$acc routine seq + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: DDZ, RHSCT, STOT, WPLUS + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTIN (K) = RHSTT (K) + END DO + DO K = 1,NSOIL + CIIN (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12_gpu (CI,AI,BI,CIIN,RHSTTIN,RHSTT,NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ + STOT = SH2OOUT (K) + SICE (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1) + ELSE + DDZ = ZSOIL(K-2)-ZSOIL(K-1) + END IF + + AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1) = SMC(K-1) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1) = SMCMAX + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT = INFXS1RT + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMC + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP_gpu +! ---------------------------------------------------------------------- + +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) + SUBROUTINE SSTEP_gpu1_1 (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,PCPDRP,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, its,ite + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, DIMENSION(its:ite), INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: SMCMAX, CMCMAX,XLAND,SNEQV,ETP,FAC2,FLIMIT,PCPDRP + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF3 + REAL, DIMENSION(its:ite), INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: DDZ, STOT, WPLUS + REAL, DIMENSION(its:ite) :: RHSCT + +!$acc parallel +!$acc loop gang vector private(KK11,I,K,AVAIL,RHSTTIN,CIIN,DDZ, STOT, WPLUS) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) == 0.0) THEN + IF (ETP(I) > 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K,I) = RHSTT (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTIN (K) = RHSTT (K,I) + END DO + DO K = 1,NSOIL + CIIN (K) = CI (K,I) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIIN,RHSTTIN,RHSTT(1:NSOIL,I),NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3(I) = 0. + + DDZ = - ZSOIL (1,I) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1,I) - ZSOIL (K,I) + SH2OOUT (K,I) = SH2OIN (K,I) + CI (K,I) + WPLUS / DDZ + STOT = SH2OOUT (K,I) + SICE (K,I) + IF (STOT > SMCMAX(I)) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1,I) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K,I) + ZSOIL (KK11,I) + END IF + WPLUS = (STOT - SMCMAX(I)) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K,I) = MAX ( MIN (STOT,SMCMAX(I)),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) + END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1,I) + ELSE + DDZ = ZSOIL(K-2,I)-ZSOIL(K-1,I) + END IF + + AVAIL = (SMCMAX(I) - SMC(K-1,I)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1,I) = SMC(K-1,I) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1,I) = SMCMAX(I) + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT(I) = INFXS1RT(I) + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3(I) = WPLUS + CMC(I) = CMC(I) + DT * RHSCT(I) + IF (CMC(I) < 1.E-20) CMC(I) = 0.0 + CMC(I) = MIN (CMC(I),CMCMAX(I)) + +! ---------------------------------------------------------------------- + END IF + ENDIF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + + END SUBROUTINE SSTEP_gpu1_1 + +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) + SUBROUTINE SSTEP_gpu1_2 (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT,XLAND,ICE,SNEQV,ETP,FAC2,FLIMIT,PCPDRP,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, its,ite + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, DIMENSION(its:ite), INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: SMCMAX, CMCMAX,XLAND,SNEQV,ETP,FAC2,FLIMIT,PCPDRP + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF3 + REAL, DIMENSION(its:ite), INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: DDZ, STOT, WPLUS + REAL, DIMENSION(its:ite) :: RHSCT + +!$acc parallel +!$acc loop gang vector private(KK11,I,K,AVAIL,RHSTTIN,CIIN,DDZ, STOT, WPLUS) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) == 0.0) THEN + IF (ETP(I) > 0.0) THEN + IF ( ( (PCPDRP(I) * DT) <= (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .AND. (FAC2(I) <= FLIMIT(I)) ) THEN +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K,I) = RHSTT (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT + END DO ! ---------------------------------------------------------------------- ! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 ! ---------------------------------------------------------------------- DO K = 1,NSOIL - RHSTTin (K) = RHSTT (K) + RHSTTIN (K) = RHSTT (K,I) END DO DO K = 1,NSOIL - CIin (K) = CI (K) + CIIN (K) = CI (K,I) END DO ! ---------------------------------------------------------------------- ! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX ! ---------------------------------------------------------------------- - CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL) + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIIN,RHSTTIN,RHSTT(1:NSOIL,I),NSOIL) ! ---------------------------------------------------------------------- ! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A ! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. ! RUNOFF3: RUNOFF WITHIN SOIL LAYERS ! ---------------------------------------------------------------------- WPLUS = 0.0 - RUNOFF3 = 0. + RUNOFF3(I) = 0. - DDZ = - ZSOIL (1) + DDZ = - ZSOIL (1,I) DO K = 1,NSOIL - IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) - SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ - STOT = SH2OOUT (K) + SICE (K) - IF (STOT > SMCMAX) THEN + IF (K /= 1) DDZ = ZSOIL (K - 1,I) - ZSOIL (K,I) + SH2OOUT (K,I) = SH2OIN (K,I) + CI (K,I) + WPLUS / DDZ + STOT = SH2OOUT (K,I) + SICE (K,I) + IF (STOT > SMCMAX(I)) THEN IF (K .eq. 1) THEN - DDZ = - ZSOIL (1) + DDZ = - ZSOIL (1,I) ELSE KK11 = K - 1 - DDZ = - ZSOIL (K) + ZSOIL (KK11) + DDZ = - ZSOIL (K,I) + ZSOIL (KK11,I) END IF - WPLUS = (STOT - SMCMAX) * DDZ + WPLUS = (STOT - SMCMAX(I)) * DDZ ELSE WPLUS = 0. END IF - SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) - SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + SMC (K,I) = MAX ( MIN (STOT,SMCMAX(I)),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) END DO #ifdef WRF_HYDRO !DJG NDHMS/WRF-Hydro edit... @@ -9662,29 +11534,29 @@ SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & DO K=NSOIL,2,-1 IF (K .eq. 2) THEN !Assign soil depths - DDZ = -ZSOIL(1) + DDZ = -ZSOIL(1,I) ELSE - DDZ = ZSOIL(K-2)-ZSOIL(K-1) + DDZ = ZSOIL(K-2,I)-ZSOIL(K-1,I) END IF - AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + AVAIL = (SMCMAX(I) - SMC(K-1,I)) * DDZ !Det. Avail. Stor. ! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX IF (WPLUS <= AVAIL) THEN - SMC(K-1) = SMC(K-1) + WPLUS/DDZ + SMC(K-1,I) = SMC(K-1,I) + WPLUS/DDZ WPLUS = 0. ELSE - SMC(K-1) = SMCMAX + SMC(K-1,I) = SMCMAX(I) WPLUS = WPLUS - AVAIL IF (K-1 .eq. 1) THEN - INFXS1RT = INFXS1RT + WPLUS*1000 + INFXS1RT(I) = INFXS1RT(I) + WPLUS*1000 WPLUS = 0. END IF END IF ! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) - SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) END DO END IF @@ -9696,19 +11568,27 @@ SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & ! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO ! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. ! ---------------------------------------------------------------------- - RUNOFF3 = WPLUS - CMC = CMC + DT * RHSCT - IF (CMC < 1.E-20) CMC = 0.0 - CMC = MIN (CMC,CMCMAX) + RUNOFF3(I) = WPLUS + CMC(I) = CMC(I) + DT * RHSCT(I) + IF (CMC(I) < 1.E-20) CMC(I) = 0.0 + CMC(I) = MIN (CMC(I),CMCMAX(I)) ! ---------------------------------------------------------------------- - END SUBROUTINE SSTEP -! ---------------------------------------------------------------------- + END IF + ENDIF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel - SUBROUTINE SSTEP_gpu (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + END SUBROUTINE SSTEP_gpu1_2 + +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) + SUBROUTINE SSTEP_gpu3_1 (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & - AI,BI,CI, INFXS1RT) -!$acc routine seq + AI,BI,CI, INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,PCPDRP,its,ite) ! ---------------------------------------------------------------------- ! SUBROUTINE SSTEP @@ -9717,73 +11597,84 @@ SUBROUTINE SSTEP_gpu (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & ! CONTENT VALUES. ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NSOIL + INTEGER, INTENT(IN) :: NSOIL, its,ite INTEGER :: I, K, KK11 !!DJG NDHMS/WRF-Hydro edit... - REAL, INTENT(INOUT) :: INFXS1RT + REAL, DIMENSION(its:ite), INTENT(INOUT) :: INFXS1RT REAL :: AVAIL - REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX - REAL, INTENT(OUT) :: RUNOFF3 - REAL, INTENT(INOUT) :: CMC - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: SMCMAX, CMCMAX,XLAND,SNEQV,FAC2,FLIMIT,PCPDRP + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF3 + REAL, DIMENSION(its:ite), INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: AI, BI, CI REAL, DIMENSION(1:NSOIL) :: RHSTTIN REAL, DIMENSION(1:NSOIL) :: CIIN - REAL :: DDZ, RHSCT, STOT, WPLUS + REAL :: DDZ, STOT, WPLUS + REAL, DIMENSION(its:ite) :: RHSCT +!$acc parallel vector_length(128) +!$acc loop gang vector private(KK11,I,K,AVAIL,RHSTTIN,CIIN,DDZ, STOT, WPLUS) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) /= 0.0) THEN + IF ( ( (PCPDRP(I) * DT) > (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .OR. (FAC2(I) > FLIMIT(I)) ) THEN ! ---------------------------------------------------------------------- ! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE ! TRI-DIAGONAL MATRIX ROUTINE. ! ---------------------------------------------------------------------- DO K = 1,NSOIL - RHSTT (K) = RHSTT (K) * DT - AI (K) = AI (K) * DT - BI (K) = 1. + BI (K) * DT - CI (K) = CI (K) * DT + RHSTT (K,I) = RHSTT (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT END DO ! ---------------------------------------------------------------------- ! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 ! ---------------------------------------------------------------------- DO K = 1,NSOIL - RHSTTIN (K) = RHSTT (K) + RHSTTIN (K) = RHSTT (K,I) END DO DO K = 1,NSOIL - CIIN (K) = CI (K) + CIIN (K) = CI (K,I) END DO ! ---------------------------------------------------------------------- ! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX ! ---------------------------------------------------------------------- - CALL ROSR12_gpu (CI,AI,BI,CIIN,RHSTTIN,RHSTT,NSOIL) + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIIN,RHSTTIN,RHSTT(1:NSOIL,I),NSOIL) ! ---------------------------------------------------------------------- ! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A ! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. ! RUNOFF3: RUNOFF WITHIN SOIL LAYERS ! ---------------------------------------------------------------------- WPLUS = 0.0 - RUNOFF3 = 0. + RUNOFF3(I) = 0. - DDZ = - ZSOIL (1) + DDZ = - ZSOIL (1,I) DO K = 1,NSOIL - IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) - SH2OOUT (K) = SH2OIN (K) + CI (K) + WPLUS / DDZ - STOT = SH2OOUT (K) + SICE (K) - IF (STOT > SMCMAX) THEN + IF (K /= 1) DDZ = ZSOIL (K - 1,I) - ZSOIL (K,I) + SH2OOUT (K,I) = SH2OIN (K,I) + CI (K,I) + WPLUS / DDZ + STOT = SH2OOUT (K,I) + SICE (K,I) + IF (STOT > SMCMAX(I)) THEN IF (K .eq. 1) THEN - DDZ = - ZSOIL (1) + DDZ = - ZSOIL (1,I) ELSE KK11 = K - 1 - DDZ = - ZSOIL (K) + ZSOIL (KK11) + DDZ = - ZSOIL (K,I) + ZSOIL (KK11,I) END IF - WPLUS = (STOT - SMCMAX) * DDZ + WPLUS = (STOT - SMCMAX(I)) * DDZ ELSE WPLUS = 0. END IF - SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) - SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + SMC (K,I) = MAX ( MIN (STOT,SMCMAX(I)),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) END DO #ifdef WRF_HYDRO !DJG NDHMS/WRF-Hydro edit... @@ -9793,29 +11684,29 @@ SUBROUTINE SSTEP_gpu (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & DO K=NSOIL,2,-1 IF (K .eq. 2) THEN !Assign soil depths - DDZ = -ZSOIL(1) + DDZ = -ZSOIL(1,I) ELSE - DDZ = ZSOIL(K-2)-ZSOIL(K-1) + DDZ = ZSOIL(K-2,I)-ZSOIL(K-1,I) END IF - AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + AVAIL = (SMCMAX(I) - SMC(K-1,I)) * DDZ !Det. Avail. Stor. ! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX IF (WPLUS <= AVAIL) THEN - SMC(K-1) = SMC(K-1) + WPLUS/DDZ + SMC(K-1,I) = SMC(K-1,I) + WPLUS/DDZ WPLUS = 0. ELSE - SMC(K-1) = SMCMAX + SMC(K-1,I) = SMCMAX(I) WPLUS = WPLUS - AVAIL IF (K-1 .eq. 1) THEN - INFXS1RT = INFXS1RT + WPLUS*1000 + INFXS1RT(I) = INFXS1RT(I) + WPLUS*1000 WPLUS = 0. END IF END IF ! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) - SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) END DO END IF @@ -9827,14 +11718,170 @@ SUBROUTINE SSTEP_gpu (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & ! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO ! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. ! ---------------------------------------------------------------------- - RUNOFF3 = WPLUS - CMC = CMC + DT * RHSCT - IF (CMC < 1.E-20) CMC = 0.0 - CMC = MIN (CMC,CMCMAX) + RUNOFF3(I) = WPLUS + CMC(I) = CMC(I) + DT * RHSCT(I) + IF (CMC(I) < 1.E-20) CMC(I) = 0.0 + CMC(I) = MIN (CMC(I),CMCMAX(I)) ! ---------------------------------------------------------------------- - END SUBROUTINE SSTEP_gpu + END IF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + + END SUBROUTINE SSTEP_gpu3_1 + +![NV]! CALL SSTEP_gpu (SH2OFG(1:NSOIL,I),SH2O(1:NSOIL,I),DUMMY(I),RHSTT(1:NSOIL,I),RHSCT(I),DT,NSOIL,SMCMAX(I), & +![NV]! CMCMAX(I),RUNOFF3(I),ZSOIL(1:NSOIL,I),SMC(1:NSOIL,I),SICE(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I),INFXS1RT(I)) + SUBROUTINE SSTEP_gpu3_2 (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & + AI,BI,CI, INFXS1RT,XLAND,ICE,SNEQV,FAC2,FLIMIT,PCPDRP,its,ite) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL, its,ite + INTEGER :: I, K, KK11 + +!!DJG NDHMS/WRF-Hydro edit... + REAL, DIMENSION(its:ite), INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: SMCMAX, CMCMAX,XLAND,SNEQV,FAC2,FLIMIT,PCPDRP + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(its:ite), INTENT(OUT) :: RUNOFF3 + REAL, DIMENSION(its:ite), INTENT(INOUT) :: CMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: SH2OIN, SICE, ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: RHSTT, SMC + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: DDZ, STOT, WPLUS + REAL, DIMENSION(its:ite) :: RHSCT + +!$acc parallel +!$acc loop gang vector private(KK11,I,K,AVAIL,RHSTTIN,CIIN,DDZ, STOT, WPLUS) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == 0) THEN + IF (SNEQV(I) /= 0.0) THEN + IF ( ( (PCPDRP(I) * DT) <= (0.0001*1000.0* (- ZSOIL (1,I))* SMCMAX(I)) ) & + .AND. (FAC2(I) <= FLIMIT(I)) ) THEN +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTT (K,I) = RHSTT (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTTIN (K) = RHSTT (K,I) + END DO + DO K = 1,NSOIL + CIIN (K) = CI (K,I) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIIN,RHSTTIN,RHSTT(1:NSOIL,I),NSOIL) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3(I) = 0. + + DDZ = - ZSOIL (1,I) + DO K = 1,NSOIL + IF (K /= 1) DDZ = ZSOIL (K - 1,I) - ZSOIL (K,I) + SH2OOUT (K,I) = SH2OIN (K,I) + CI (K,I) + WPLUS / DDZ + STOT = SH2OOUT (K,I) + SICE (K,I) + IF (STOT > SMCMAX(I)) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1,I) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K,I) + ZSOIL (KK11,I) + END IF + WPLUS = (STOT - SMCMAX(I)) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K,I) = MAX ( MIN (STOT,SMCMAX(I)),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) + END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1,I) + ELSE + DDZ = ZSOIL(K-2,I)-ZSOIL(K-1,I) + END IF + + AVAIL = (SMCMAX(I) - SMC(K-1,I)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1,I) = SMC(K-1,I) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1,I) = SMCMAX(I) + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT(I) = INFXS1RT(I) + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K,I) = MAX ( (SMC (K,I) - SICE (K,I)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3(I) = WPLUS + CMC(I) = CMC(I) + DT * RHSCT(I) + IF (CMC(I) < 1.E-20) CMC(I) = 0.0 + CMC(I) = MIN (CMC(I),CMCMAX(I)) + ! ---------------------------------------------------------------------- + END IF + END IF + ENDIF + ENDIF +ENDDO +!$acc end parallel + + END SUBROUTINE SSTEP_gpu3_2 + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F index 80b0cc3b17..2b6da936ed 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F @@ -11,6 +11,7 @@ MODULE module_sf_noahlsm_glacial_only USE module_sf_noahlsm, ONLY : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, ROSR12, ROSR12_gpu USE module_sf_noahlsm, ONLY : LVCOEF_DATA + use mpas_timer, only : mpas_timer_start, mpas_timer_stop PRIVATE :: ALCALC PRIVATE :: CSNOW @@ -607,7 +608,7 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & !$acc T2V,RHO,RCH,T24,RR,ZSOIL,FRZGRA,SNOWNG) ! ---------------------------------------------------------------------- -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO I=its,ite IF((XLAND(I)-1.5).LT.0.)THEN @@ -634,32 +635,32 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & IF(SNDENS(I) > 1.0) THEN !!! FATAL_ERROR( 'Physical snow depth is less than snow water equiv.' ) ENDIF -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel - -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN + ENDIF + ENDIF +ENDDO +!$acc end parallel + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN CALL CSNOW_gpu (SNCOND(I),SNDENS(I)) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. ! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! ! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND ! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN SNOWNG(I) = .FALSE. FRZGRA(I) = .FALSE. IF (PRCP(I) > 0.0) THEN @@ -673,10 +674,10 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & IF (T1(I) <= TFREEZ) FRZGRA(I) = .TRUE. END IF END IF -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP ! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD @@ -684,11 +685,11 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & ! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES ! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN IF ( (SNOWNG(I)) .OR. (FRZGRA(I)) ) THEN SN_NEW(I) = PRCP(I) * DT * 0.001 SNEQV(I) = SNEQV(I) + SN_NEW(I) @@ -727,34 +728,34 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & ! and SNEQV is at least 0.1 (as set above) ! ---------------------------------------------------------------------- SNCOVR(I) = 1.0 -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN CALL ALCALC_gpu (ALB(I),SNOALB(I),EMBRD(I),T1(I),ALBEDO(I),EMISSI(I), & & DT,SNOWNG(I),SNOTIME1(I)) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! THERMAL CONDUCTIVITY ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN DF1(I) = SNCOND(I) DSOIL(I) = - (0.5 * ZSOIL (1,I)) @@ -778,35 +779,35 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & DTOT(I) = 2.*DSOIL(I) ENDIF SSOIL(I) = DF1(I) * ( T1(I) - STC(1,I) ) / DTOT(I) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM ! THE PREVIOUS TIMESTEP. ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN CALL SNOWZ0_gpu (Z0(I),Z0BRD(I),SNOWH(I)) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel + ENDIF + ENDIF +ENDDO +!$acc end parallel ! ---------------------------------------------------------------------- ! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN ! PENMAN EP SUBROUTINE THAT FOLLOWS ! ---------------------------------------------------------------------- -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN FDOWN(I) = SOLNET(I) + LWDN(I) ! ---------------------------------------------------------------------- @@ -829,30 +830,35 @@ SUBROUTINE SFLX_GLACIAL_gpu (ims,ime,its,ite,XLAND,ICE, & CALL PENMAN_gpu (SFCTMP(I),SFCPRS(I),CH(I),TH2(I),PRCP(I),FDOWN(I),T24(I),SSOIL(I), & & Q2(I),Q2SAT(I),ETP(I),RCH(I),RR(I),SNOWNG(I),FRZGRA(I), & & DQSDT2(I),FLX2(I),EMISSI(I),T1(I)) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel - -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN - CALL SNOPAC_gpu (ETP(I),ETA(I),PRCP(I),PRCPF(I),SNOWNG(I),NSOIL,DT,DF1(I), & - & Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & - & SFCPRS(I),RCH(I),RR(I),SNEQV(I),SNDENS(I),SNOWH(I),ZSOIL(1:NSOIL,I),TBOT(I), & - & SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I)) -!!! ENDIF -!!! ENDIF -!!!ENDDO -!!!!$acc end parallel - -!!!!$acc parallel vector_length(32) -!!!!$acc loop gang vector -!!!DO I=its,ite -!!! IF((XLAND(I)-1.5).LT.0.)THEN -!!! IF (ICE(I) == -1) THEN + ENDIF + ENDIF +ENDDO +!$acc end parallel + +!NV!!$acc parallel +!NV!!$acc loop gang vector +!NV!DO I=its,ite +!NV! IF((XLAND(I)-1.5).LT.0.)THEN +!NV! IF (ICE(I) == -1) THEN +!NV! CALL SNOPAC_gpu (ETP(I),ETA(I),PRCP(I),PRCPF(I),SNOWNG(I),NSOIL,DT,DF1(I), & +!NV! & Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & +!NV! & SFCPRS(I),RCH(I),RR(I),SNEQV(I),SNDENS(I),SNOWH(I),ZSOIL(1:NSOIL,I),TBOT(I), & +!NV! & SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I)) +!NV! ENDIF +!NV! ENDIF +!NV!ENDDO +!NV!!$acc end parallel + + CALL SNOPAC_gpu1 (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB,XLAND,ICE,its,ite) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN ! ETA_KINEMATIC = ESNOW ETA_KINEMATIC(I) = ETP(I) @@ -1595,6 +1601,85 @@ SUBROUTINE HSTEP_gpu (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) END SUBROUTINE HSTEP_gpu ! ---------------------------------------------------------------------- +!NV! (STCF(1:NSOIL,I),STC(1:NSOIL,I),RHSTS(1:NSOIL,I),DT,NSOIL,AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) + SUBROUTINE HSTEP_gpu1 (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI,XLAND,ICE,its,ite) +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL,its,ite + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: STCIN + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(OUT) :: STCOUT + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: RHSTS + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: AI,BI,CI + REAL, DIMENSION(its:ite), INTENT(IN) :: XLAND + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(1:NSOIL,its:ite) :: RHSTSin + REAL, DIMENSION(1:NSOIL,its:ite) :: CIin + REAL :: DT + INTEGER :: K,I + +!$acc data present(STCOUT,STCIN,RHSTS,AI,BI,CI,XLAND,ICE) create(RHSTSin,CIin) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K,I) = RHSTS (K,I) * DT + AI (K,I) = AI (K,I) * DT + BI (K,I) = 1. + BI (K,I) * DT + CI (K,I) = CI (K,I) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K,I) = RHSTS (K,I) + END DO + DO K = 1,NSOIL + CIin (K,I) = CI (K,I) + END DO + ENDIF + ENDIF +ENDDO +!$acc end parallel +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN + CALL ROSR12_gpu (CI(1:NSOIL,I),AI(1:NSOIL,I),BI(1:NSOIL,I),CIin(1:NSOIL,I),RHSTSin(1:NSOIL,I),RHSTS(1:NSOIL,I),NSOIL) + ENDIF + ENDIF +ENDDO +!$acc end parallel +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN + DO K = 1,NSOIL + STCOUT (K,I) = STCIN (K,I) + CI (K,I) + END DO + ENDIF + ENDIF +ENDDO +!$acc end parallel +! ---------------------------------------------------------------------- +!$acc end data + END SUBROUTINE HSTEP_gpu1 + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & & DQSDT2,FLX2,EMISSI,T1) @@ -1793,6 +1878,71 @@ SUBROUTINE SHFLX_gpu (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) END SUBROUTINE SHFLX_gpu ! ---------------------------------------------------------------------- +!NV! (STC(1:NSOIL,I),NSOIL,DT,YY(I),ZZ1(I),ZSOIL(1:NSOIL,I),TBOT(I),DF1(I)) + SUBROUTINE SHFLX_gpu1 (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1,XLAND,ICE,its,ite) +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL,its,ite + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: YY,ZZ1,TBOT,DF1,XLAND + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: STC + + REAL, DIMENSION(1:NSOIL,its:ite) :: AI, BI, CI, STCF,RHSTS + INTEGER :: I,K + REAL, PARAMETER :: T0 = 273.15 + +!$acc data present(YY,ZZ1,TBOT,DF1,XLAND,ICE,ZSOIL,STC) create(AI,BI,CI,STCF,RHSTS) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + CALL HRTICE_gpu (RHSTS(1:NSOIL,I),STC(1:NSOIL,I),TBOT(I), NSOIL,ZSOIL(1:NSOIL,I),YY(I),ZZ1(I),DF1(I),AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) + ENDIF + ENDIF +ENDDO +!$acc end parallel + +!NV!!$acc parallel +!NV!!$acc loop gang vector +!NV!DO I=its,ite +!NV! IF((XLAND(I)-1.5).LT.0.)THEN +!NV! IF (ICE(I) == -1) THEN +!NV! CALL HSTEP_gpu (STCF(1:NSOIL,I),STC(1:NSOIL,I),RHSTS(1:NSOIL,I),DT,NSOIL,AI(1:NSOIL,I),BI(1:NSOIL,I),CI(1:NSOIL,I)) +!NV! ENDIF +!NV! ENDIF +!NV!ENDDO +!NV!!$acc end parallel + + CALL HSTEP_gpu1 (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI,XLAND,ICE,its,ite) + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN + DO K = 1,NSOIL + STC (K,I) = STCF (K,I) + END DO + ENDIF + ENDIF +ENDDO +!$acc end parallel +! ---------------------------------------------------------------------- +!$acc end data + END SUBROUTINE SHFLX_gpu1 + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & @@ -2233,6 +2383,269 @@ SUBROUTINE SNOPAC_gpu (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & END SUBROUTINE SNOPAC_gpu ! ---------------------------------------------------------------------- +!NV! (ETP(I),ETA(I),PRCP(I),PRCPF(I),SNOWNG(I),NSOIL,DT,DF1(I), & +!NV! & Q2(I),T1(I),SFCTMP(I),T24(I),TH2(I),FDOWN(I),SSOIL(I),STC(1:NSOIL,I), & +!NV! & SFCPRS(I),RCH(I),RR(I),SNEQV(I),SNDENS(I),SNOWH(I),ZSOIL(1:NSOIL,I),TBOT(I), & +!NV! & SNOMLT(I),DEW(I),FLX1(I),FLX2(I),FLX3(I),ESNOW(I),EMISSI(I),RIBB(I)) + SUBROUTINE SNOPAC_gpu1 (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB,XLAND,ICE,its,ite) +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL,its,ite + LOGICAL, DIMENSION(its:ite), INTENT(IN) :: SNOWNG + REAL, INTENT(IN) :: DT + REAL, DIMENSION(its:ite), INTENT(IN) :: PRCP,DF1,Q2,SFCTMP,T24,TH2,FDOWN, & + SFCPRS,RCH,RR,TBOT,EMISSI,XLAND + INTEGER, DIMENSION(its:ite), INTENT(IN) :: ICE + REAL, DIMENSION(its:ite), INTENT(INOUT) :: SNEQV,FLX2,PRCPF,SNOWH,SNDENS,T1,RIBB,ETP + REAL, DIMENSION(its:ite), INTENT(OUT) :: DEW,ESNOW,FLX1,FLX3,SNOMLT + REAL, DIMENSION(its:ite), INTENT(OUT) :: SSOIL + REAL, DIMENSION(1:NSOIL,its:ite),INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL,its:ite), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: ET1 + INTEGER :: K,I + REAL :: DENOM,DSOIL,DTOT,ESDFLX, & + & ESNOW1,ESNOW2,ETA1,ETP1,ETP2, & + & ETP3,ETANRG,EX, & + & FRCSNO,FRCSOI,PRCP1,QSAT,RSNOW,SEH, & + & SNCOND,T12,T12A,T12B,T14 + REAL, DIMENSION(its:ite) :: ETA,YY,ZZ1 + + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + & LSUBS = 2.83E+6, TFREEZ = 273.15, & + & SNOEXP = 2.0 + +!$acc data present(SNOWNG,PRCP,DF1,Q2,SFCTMP,T24,TH2,FDOWN,SFCPRS,RCH,RR,TBOT, & +!$acc EMISSI,XLAND,ICE,SNEQV,FLX2,PRCPF,SNOWH,SNDENS,T1,RIBB,ETP, & +!$acc DEW,ESNOW,FLX1,FLX3,SNOMLT,SSOIL,ZSOIL,STC,ETA) & +!$acc create(YY,ZZ1) + +!$acc parallel +!$acc loop gang vector private(DENOM,DSOIL,DTOT,ESNOW1,ESNOW2,ETP1,ETP3, & +!$acc ETANRG,EX,PRCP1,SEH,T12,T12A,T12B,T14) +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN +! ---------------------------------------------------------------------- +! FOR GLACIAL-ICE, SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE +! POTENTIAL RATE. +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESDFLX [KG M-2 S-1] .le. ESNOW +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + SNOMLT(I) = 0.0 + DEW(I) = 0. + ESNOW(I) = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- + PRCP1 = PRCPF(I) *0.001 +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + IF (ETP(I) <= 0.0) THEN + IF ( ( RIBB(I) >= 0.1 ) .AND. ( FDOWN(I) > 150.0 ) ) THEN + ETP(I)=(MIN(ETP(I)*(1.0-RIBB(I)),0.)/0.980 + ETP(I)*(0.980-1.0))/0.980 + ENDIF + ETP1 = ETP(I) * 0.001 + DEW(I) = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP(I)*LSUBS + ELSE + ETP1 = ETP(I) * 0.001 + ESNOW(I) = ETP(I) + ESNOW1 = ESNOW(I)*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW(I)*LSUBS + END IF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1(I) = 0.0 + IF (SNOWNG(I)) THEN + FLX1(I) = CPICE * PRCP(I) * (T1(I)- SFCTMP(I)) + ELSE + IF (PRCP(I) > 0.0) FLX1(I) = CPH2O * PRCP(I) * (T1(I)- SFCTMP(I)) + END IF +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + DSOIL = - (0.5 * ZSOIL (1,I)) + DTOT = SNOWH(I) + DSOIL + DENOM = 1.0+ DF1(I) / (DTOT * RR(I) * RCH(I)) + T12A = ( (FDOWN(I) - FLX1(I)- FLX2(I)- EMISSI(I) * SIGMA * T24(I))/ RCH(I) & + + TH2(I)- SFCTMP(I) - ETANRG / RCH(I) ) / RR(I) + T12B = DF1(I) * STC (1,I) / (DTOT * RR(I) * RCH(I)) + + T12 = (SFCTMP(I) + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- + T1(I) = T12 + SSOIL(I) = DF1(I) * (T1(I)- STC (1,I)) / DTOT + SNEQV(I) = MAX(0.0, SNEQV(I)-ESNOW2) + FLX3(I) = 0.0 + EX = 0.0 + SNOMLT(I) = 0.0 + ELSE +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- + T1(I) = TFREEZ + IF ( DTOT .GT. 2.0*DSOIL ) THEN + DTOT = 2.0*DSOIL + ENDIF + SSOIL(I) = DF1(I) * (T1(I)- STC (1,I)) / DTOT + IF (SNEQV(I)-ESNOW2 <= ESDMIN) THEN + SNEQV(I) = 0.0 + EX = 0.0 + SNOMLT(I) = 0.0 + FLX3(I) = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (SNEQV) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + SNEQV(I) = SNEQV(I)-ESNOW2 + ETP3 = ETP(I) * LSUBC + SEH = RCH(I) * (T1(I)- TH2(I)) + T14 = ( T1(I) * T1(I) ) * ( T1(I) * T1(I) ) + FLX3(I) = FDOWN(I) - FLX1(I)- FLX2(I)- EMISSI(I)*SIGMA * T14- SSOIL(I) - SEH - ETANRG + IF (FLX3(I) <= 0.0) FLX3(I) = 0.0 + EX = FLX3(I)*0.001/ LSUBF + SNOMLT(I) = EX * DT +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + IF (SNEQV(I)- SNOMLT(I) >= ESDMIN) THEN + SNEQV(I) = SNEQV(I)- SNOMLT(I) + ELSE +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + EX = SNEQV(I) / DT + FLX3(I) = EX *1000.0* LSUBF + SNOMLT(I) = SNEQV(I) + + SNEQV(I) = 0.0 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! FOR GLACIAL ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. +! ---------------------------------------------------------------------- + ZZ1(I) = 1.0 + YY(I) = STC (1,I) -0.5* SSOIL(I) * ZSOIL (1,I)* ZZ1(I)/ DF1(I) + ENDIF + ENDIF +ENDDO +!$acc end parallel + +!NV!!$acc parallel +!NV!!$acc loop gang vector +!NV!DO I=its,ite +!NV! IF((XLAND(I)-1.5).LT.0.)THEN +!NV! IF (ICE(I) == -1) THEN +!NV!! ---------------------------------------------------------------------- +!NV!! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. +!NV!! ---------------------------------------------------------------------- +!NV! CALL SHFLX_gpu (STC(1:NSOIL,I),NSOIL,DT,YY(I),ZZ1(I),ZSOIL(1:NSOIL,I),TBOT(I),DF1(I)) +!NV! ENDIF +!NV! ENDIF +!NV!ENDDO +!NV!!$acc end parallel + + CALL SHFLX_gpu1 (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1,XLAND,ICE,its,ite) + + +!$acc parallel +!$acc loop gang vector +DO I=its,ite + IF((XLAND(I)-1.5).LT.0.)THEN + IF (ICE(I) == -1) THEN +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + IF (SNEQV(I) .GE. 0.10) THEN + CALL SNOWPACK_gpu (SNEQV(I),DT,SNOWH(I),SNDENS(I),T1(I),YY(I)) + ELSE + SNEQV(I) = 0.10 + SNOWH(I) = 0.50 +!KWM???? SNDENS = +!KWM???? SNCOND = + ENDIF + ENDIF + ENDIF +ENDDO +!$acc end parallel +! ---------------------------------------------------------------------- +!$acc end data + END SUBROUTINE SNOPAC_gpu1 + SUBROUTINE SNOWPACK (SNEQV,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) ! ---------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 180ff65333..47a1a39d9e 100755 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -212,9 +212,14 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER :: I,J -!$acc data create(dz8w1d,U1D,V1D,QV1D,P1D,T1D) +!$acc data present(U3D,V3D,T3D,QV3D,P3D,dz8w,PSFC,CHS,CHS2,CQS2,CPM, & +!$acc ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,FM,FH, & +!$acc XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, & +!$acc U10,V10,TH2,T2,Q2,GZ1OZ0,WSPD,BR,ustm,ck,cka,cd,cda) & +!$acc create(dz8w1d,U1D,V1D,QV1D,P1D,T1D,DX2D) + DO J=jts,jte -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO i=its,ite DX2D(i)=DX(i,j) @@ -393,13 +398,18 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 REAL :: Z0T, CZC -!$acc data create(PSFC,TGDSA,THGB,SCR3,THX,SCR4,THVX,QX,ZQKLP1, & -!$acc ZQKL,ZA,GOVRTH,RHOX,GZ2OZ0,GZ10OZ0,PSIM10,PSIH10,PSIM2, & -!$acc PSIH2,WSPDI,DENOMQ,DENOMQ2,DENOMT2) + +!$acc data present(UX,VX,T1D,QV1D,P1D,dz8w1d,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, & +!$acc ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,FM,FH,XLAND,HFX,QFX, & +!$acc TSK,U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH,QSFC,LH,GZ1OZ0, & +!$acc WSPD,BR,ustm,ck,cka,cd,cda) & +!$acc create(PSFC,TGDSA,THGB,SCR3,THX,SCR4,THVX,QX,ZQKLP1, & +!$acc ZQKL,ZA,GOVRTH,RHOX,GZ2OZ0,GZ10OZ0,PSIM10,PSIH10,PSIM2, & +!$acc PSIH2,WSPDI,DENOMQ,DENOMQ2,DENOMT2) !------------------------------------------------------------------- KL=kte -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO i=its,ite ! PSFC cb @@ -441,7 +451,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! SCR4(I,K) STORE VIRTUAL TEMPERATURE. !!! DO 30 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(PL,THCON) DO I=its,ite ! PL cb @@ -479,7 +489,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !!! 50 CONTINUE ! !!! DO 60 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(E1,PL) DO I=its,ite E1=SVP1*EXP(SVP2*(TGDSA(I)-SVPT0)/(TGDSA(I)-SVP3)) @@ -534,7 +544,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! AKB(1976), EQ(12). !!! DO 260 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(ZL,TSKV,DTHVDZ,fluxc,VCONV,DTHVM, & !$acc VSGD) DO I=its,ite @@ -612,7 +622,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !CCCCC !!! DO 320 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(ZOL10,ZOL2,NZOL,RZOL,NZOL10,RZOL10,NZOL2,RZOL2) DO I=its,ite !CCCCC @@ -761,7 +771,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! ZA(1982) EQS(2.60),(2.61). ! !!! DO 330 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(DTG,PSIX,PSIX10,PSIT,ZL,PSIQ,PSIT2, & !$acc PSIQ2,PSIQ10,VISC,RESTAR,Z0T,Z0Q,GZ0OZT,GZ0OZQ,CZIL) DO I=its,ite @@ -921,7 +931,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). !!! DO 360 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(ZW,ZN1,ZN2,ZL,DTTHX) DO I=its,ite IF((XLAND(I)-1.5).GE.0)THEN @@ -982,7 +992,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & IF ( .NOT. ( PRESENT(SCM_FORCE_FLUX) .AND. (SCM_FORCE_FLUX.EQ.1) ) ) THEN ! !!! DO 370 I=its,ite -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector DO I=its,ite QFX(I)=FLQC(I)*(QSFC(I)-QX(I)) @@ -1014,7 +1024,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & !!! 400 CONTINUE END IF !!! 405 CONTINUE -!$acc parallel vector_length(32) +!$acc parallel !$acc loop gang vector private(ZL) DO I=its,ite IF((XLAND(I)-1.5).GE.0)THEN diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 3943d0b979..2e4fc37c60 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -294,6 +294,7 @@ subroutine mpas_dmpar_init(dminfo, mpi_comm)!{{{ call MPI_Comm_dup(mpi_comm, dminfo % comm, mpi_ierr) else dminfo % initialized_mpi = .true. + !$acc init #ifdef MPAS_OPENMP desiredThreadLevel = MPI_THREAD_FUNNELED call MPI_Init_thread(desiredThreadLevel, threadLevel, mpi_ierr) @@ -1418,7 +1419,7 @@ subroutine mpas_dmpar_scatter_ints(dminfo, nprocs, noutlist, displs, counts, inl integer, intent(in) :: noutlist !< Input: Number integers to receive integer, dimension(nprocs), intent(in) :: displs !< Input: Displacement in sending array integer, dimension(nprocs), intent(in) :: counts !< Input: Number of integers to distribute - integer, dimension(:), pointer :: inlist !< Input: List of integers to send + integer, dimension(:), intent(in) :: inlist !< Input: List of integers to send integer, dimension(noutlist), intent(inout) :: outlist !< Output: List of received integers #ifdef _MPI diff --git a/src/framework/mpas_timer.F b/src/framework/mpas_timer.F index fa61001061..70d675890a 100644 --- a/src/framework/mpas_timer.F +++ b/src/framework/mpas_timer.F @@ -27,6 +27,10 @@ module mpas_timer use mpas_threading use mpas_log +#ifdef MPAS_NVTX_RANGES + use nvtx +#endif + #ifdef MPAS_PERF_MOD_TIMERS use perf_mod #endif @@ -110,6 +114,10 @@ subroutine mpas_timer_start(timer_name, clear_timer_in)!{{{ clear_timer = clear_timer_in end if +#ifdef MPAS_NVTX_RANGES + call nvtxStartRange(trim(timer_name)) +#endif + #ifdef MPAS_TAU_TIMERS call tau_start(trimmed_name) #endif @@ -255,6 +263,10 @@ subroutine mpas_timer_stop(timer_name)!{{{ trimmed_name = trim(timer_name) nlen = len(trimmed_name) +#ifdef MPAS_NVTX_RANGES + call nvtxEndRange() +#endif + #ifdef MPAS_TAU_TIMERS call tau_stop(trimmed_name) #endif