Skip to content

Commit

Permalink
FV3: this commits #refs 46522
Browse files Browse the repository at this point in the history 
-Added recommended fix from code review

Change-Id: I1dd0728e2f26aae1152ec3cbeb220972e90208f0
  • Loading branch information
@junwang-noaa
junwang-noaa committed Feb 15, 2018
1 parent 1cc52d4 commit 6b8f273
Show file tree
Hide file tree
Showing 10 changed files with 269 additions and 251 deletions.
133 changes: 117 additions & 16 deletions atmos_cubed_sphere/tools/fv_mp_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -137,15 +137,21 @@ module fv_mp_mod
END INTERFACE

INTERFACE mp_bcst
MODULE PROCEDURE mp_bcst_i4
MODULE PROCEDURE mp_bcst_i
MODULE PROCEDURE mp_bcst_r4
MODULE PROCEDURE mp_bcst_r8
MODULE PROCEDURE mp_bcst_1d_r4
MODULE PROCEDURE mp_bcst_1d_r8
MODULE PROCEDURE mp_bcst_2d_r4
MODULE PROCEDURE mp_bcst_2d_r8
MODULE PROCEDURE mp_bcst_3d_r4
MODULE PROCEDURE mp_bcst_3d_r8
MODULE PROCEDURE mp_bcst_4d_r4
MODULE PROCEDURE mp_bcst_4d_r8
MODULE PROCEDURE mp_bcst_3d_i8
MODULE PROCEDURE mp_bcst_4d_i8
MODULE PROCEDURE mp_bcst_1d_i
MODULE PROCEDURE mp_bcst_2d_i
MODULE PROCEDURE mp_bcst_3d_i
MODULE PROCEDURE mp_bcst_4d_i
END INTERFACE

INTERFACE mp_reduce_min
Expand All @@ -158,7 +164,7 @@ module fv_mp_mod
MODULE PROCEDURE mp_reduce_max_r4
MODULE PROCEDURE mp_reduce_max_r8_1d
MODULE PROCEDURE mp_reduce_max_r8
MODULE PROCEDURE mp_reduce_max_i4
MODULE PROCEDURE mp_reduce_max_i
END INTERFACE

INTERFACE mp_reduce_sum
Expand Down Expand Up @@ -2087,14 +2093,14 @@ end subroutine mp_gather_3d_r8
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_i4 :: Call SPMD broadcast
! mp_bcst_i :: Call SPMD broadcast
!
subroutine mp_bcst_i4(q)
subroutine mp_bcst_i(q)
integer, intent(INOUT) :: q

call MPI_BCAST(q, 1, MPI_INTEGER, masterproc, commglobal, ierror)

end subroutine mp_bcst_i4
end subroutine mp_bcst_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
Expand Down Expand Up @@ -2129,6 +2135,70 @@ end subroutine mp_bcst_r8
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_1d_r4 :: Call SPMD broadcast
!
subroutine mp_bcst_1d_r4(q, idim)
integer, intent(IN) :: idim
real(kind=4), intent(INOUT) :: q(idim)

call MPI_BCAST(q, idim, MPI_REAL, masterproc, commglobal, ierror)

end subroutine mp_bcst_1d_r4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_1d_r8 :: Call SPMD broadcast
!
subroutine mp_bcst_1d_r8(q, idim)
integer, intent(IN) :: idim
real(kind=8), intent(INOUT) :: q(idim)

call MPI_BCAST(q, idim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)

end subroutine mp_bcst_1d_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_2d_r4 :: Call SPMD broadcast
!
subroutine mp_bcst_2d_r4(q, idim, jdim)
integer, intent(IN) :: idim, jdim
real(kind=4), intent(INOUT) :: q(idim,jdim)

call MPI_BCAST(q, idim*jdim, MPI_REAL, masterproc, commglobal, ierror)

end subroutine mp_bcst_2d_r4
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_2d_r8 :: Call SPMD broadcast
!
subroutine mp_bcst_2d_r8(q, idim, jdim)
integer, intent(IN) :: idim, jdim
real(kind=8), intent(INOUT) :: q(idim,jdim)

call MPI_BCAST(q, idim*jdim, MPI_DOUBLE_PRECISION, masterproc, commglobal, ierror)

end subroutine mp_bcst_2d_r8
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
Expand Down Expand Up @@ -2196,31 +2266,62 @@ end subroutine mp_bcst_4d_r8
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_3d_i8 :: Call SPMD broadcast
! mp_bcst_3d_i :: Call SPMD broadcast
!
subroutine mp_bcst_3d_i8(q, idim, jdim, kdim)
subroutine mp_bcst_3d_i(q, idim, jdim, kdim)
integer, intent(IN) :: idim, jdim, kdim
integer, intent(INOUT) :: q(idim,jdim,kdim)

call MPI_BCAST(q, idim*jdim*kdim, MPI_INTEGER, masterproc, commglobal, ierror)

end subroutine mp_bcst_3d_i8
end subroutine mp_bcst_3d_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_4d_i8 :: Call SPMD broadcast
! mp_bcst_1d_i :: Call SPMD broadcast
!
subroutine mp_bcst_1d_i(q, idim)
integer, intent(IN) :: idim
integer, intent(INOUT) :: q(idim)

call MPI_BCAST(q, idim, MPI_INTEGER, masterproc, commglobal, ierror)

end subroutine mp_bcst_1d_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_2d_i :: Call SPMD broadcast
!
subroutine mp_bcst_2d_i(q, idim, jdim)
integer, intent(IN) :: idim, jdim
integer, intent(INOUT) :: q(idim,jdim)

call MPI_BCAST(q, idim*jdim, MPI_INTEGER, masterproc, commglobal, ierror)

end subroutine mp_bcst_2d_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_4d_i :: Call SPMD broadcast
!
subroutine mp_bcst_4d_i8(q, idim, jdim, kdim, ldim)
subroutine mp_bcst_4d_i(q, idim, jdim, kdim, ldim)
integer, intent(IN) :: idim, jdim, kdim, ldim
integer, intent(INOUT) :: q(idim,jdim,kdim,ldim)

call MPI_BCAST(q, idim*jdim*kdim*ldim, MPI_INTEGER, masterproc, commglobal, ierror)

end subroutine mp_bcst_4d_i8
end subroutine mp_bcst_4d_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
Expand Down Expand Up @@ -2334,9 +2435,9 @@ end subroutine mp_reduce_min_r8
!-------------------------------------------------------------------------------
! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
!
! mp_bcst_4d_i4 :: Call SPMD REDUCE_MAX
! mp_bcst_4d_i :: Call SPMD REDUCE_MAX
!
subroutine mp_reduce_max_i4(mymax)
subroutine mp_reduce_max_i(mymax)
integer, intent(INOUT) :: mymax

integer :: gmax
Expand All @@ -2346,7 +2447,7 @@ subroutine mp_reduce_max_i4(mymax)

mymax = gmax

end subroutine mp_reduce_max_i4
end subroutine mp_reduce_max_i
!
! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
!-------------------------------------------------------------------------------
Expand Down
7 changes: 7 additions & 0 deletions atmos_cubed_sphere/tools/fv_nggps_diag.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -362,6 +362,13 @@ subroutine fv_nggps_diag(Atm, zvir, Time)
!--- PS
! Re-compute pressure (dry_mass + water_vapor) surface pressure
if(id_ps > 0) then
do k=1,npzo
do j=jsco,jeco
do i=isco,ieco
wk(i,j,k) = Atm(n)%delp(i,j,k)*(1.-sum(Atm(n)%q(i,j,k,2:Atm(n)%flagstruct%nwat)))
enddo
enddo
enddo
do j=jsco,jeco
do i=isco,ieco
psurf(i,j) = ptop
Expand Down
98 changes: 43 additions & 55 deletions gfsphysics/GFS_layer/GFS_physics_driver.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2897,15 +2897,11 @@ subroutine GFS_physics_driver &
Diag%rain(:) = Diag%rainc(:) + frain * rain1(:)

if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm
i = min(3,Model%num_p3d)
!
! rsun: when ncld = 2 NEED ATTENTION HERE need to re-write this routine
!
call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, &
Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, &
Stateout%gq0, Statein%prsl, Statein%prsi, &
Diag%rain, Statein%phii, Model%num_p3d, &
Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input
call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, &
Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, &
Stateout%gq0, Statein%prsl, Statein%prsi, &
Diag%rain, Statein%phii, Sfcprop%tsfc, & !input
domr, domzr, domip, doms) ! output
!
! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS '
Expand All @@ -2917,21 +2913,32 @@ subroutine GFS_physics_driver &
! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i)
! end do
! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation

if (Model%imp_physics /= 11) then
do i=1,im
Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )
if(doms(i) > 0.0 .or. domip(i) > 0.0) then
Sfcprop%srflag(i) = 1.
else
Sfcprop%srflag(i) = 0.
end if
enddo
endif

do i=1,im
if(doms(i) > 0.0 .or. domip(i) > 0.0) then
Sfcprop%srflag(i) = 1.
else
Sfcprop%srflag(i) = 0.
end if
enddo
endif

if (Model%lssav) then
Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:)
Diag%totice (:) = Diag%totice (:) + Diag%ice(:)
Diag%totsnw (:) = Diag%totsnw (:) + Diag%snow(:)
Diag%totgrp (:) = Diag%totgrp (:) + Diag%graupel(:)
!
if (Model%cal_pre) then
Diag%tdomr(:) = Diag%tdomr(:) + domr(:) * dtf
Diag%tdomzr(:) = Diag%tdomzr(:) + domzr(:) * dtf
Diag%tdomip(:) = Diag%tdomip(:) + domip(:) * dtf
Diag%tdoms(:) = Diag%tdoms(:) + doms(:) * dtf
endif

if (Model%ldiag3d) then
Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain
Expand All @@ -2953,51 +2960,32 @@ subroutine GFS_physics_driver &
enddo
enddo

! --- ... lu: snow-rain detection is performed in land/sice module

if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag
Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp
!rsun if (Model%lgfdlmp) then
!rsun do i = 1, im
!rsun Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0)
!rsun! determine convective rain/snow by surface temperature
!rsun! determine large-scale rain/snow by rain/snow coming out directly from MP
!rsun if (Sfcprop%tsfc(i) .ge. 273.15) then
!rsun crain = Diag%rainc(i)
!rsun csnow = 0.0
!rsun else
!rsun crain = 0.0
!rsun csnow = Diag%rainc(i)
!rsun endif
!rsun if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then
!rsun Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
!rsun endif
!rsun enddo
!rsun endif
else
if (Model%imp_physics == 11) then
! determine convective rain/snow by surface temperature
! determine large-scale rain/snow by rain/snow coming out directly from MP
do i = 1, im
Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp
Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0)
if (Model%imp_physics == 11) then
! determine convective rain/snow by surface temperature
! determine large-scale rain/snow by rain/snow coming out directly from MP
if (Sfcprop%tsfc(i) .ge. 273.15) then
crain = Diag%rainc(i)
csnow = 0.0
else
crain = 0.0
csnow = Diag%rainc(i)
endif
if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then
Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
endif
if (Sfcprop%tsfc(i) .ge. 273.15) then
crain = Diag%rainc(i)
csnow = 0.0
else
if (t850(i) <= 273.16) then
Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
endif
crain = 0.0
csnow = Diag%rainc(i)
endif
enddo
endif
if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then
Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
endif
enddo
else if( .not. Model%cal_pre) then
do i = 1, im
Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp
Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0)
if (t850(i) <= 273.16) then
Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1)
endif
enddo
endif

! --- ... coupling insertion

Expand Down
Loading

0 comments on commit 6b8f273

Please sign in to comment.