subroutine bkgcov(cstate) !$$$ subprogram documentation block ! . . . . ! subprogram: bkgcov perform hor & vert of background error ! prgmmr: kleist org: np22 date: 2004-07-22 ! ! abstract: perform horizontal and vertical parts of background error ! ! program history log: ! 2004-07-22 kleist ! 2004-10-26 kleist - remove u,v ! 2004-11-03 treadon - move definition of horizontal scale weighting ! factors to namelist ! 2004-11-22 derber - add openMP ! 2008-06-05 safford - rm unused vars ! 2010-03-01 zhu - make changes for generalizing control vectors ! - replace explicit use of each control variable ! by a control_state 'cstate' ! - use nrf* for generalized control variables ! - make changes to interfaces of sub2grid and grid2sub ! 2010-04-28 todling - update to use gsi_bundle ! 2011-06-29 todling - no explict reference to internal bundle arrays ! 2012-06-25 parrish - replace sub2grid/grid2sub with general_sub2grid/general_grid2sub. ! Remove arrays sst, slndt, sicet. These are now contained as ! motley variables in input/output bundle cstate. Remove unused variables ! nnnn1o,latlon11. ! ! input argument list: ! cstate - bundle containing control fields ! ! output argument list: ! all after smoothing, combining scales ! cstate - bundle containing control fields ! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP !$$$ use kinds, only: r_kind,i_kind use constants, only: zero use gridmod, only: nlat,nlon use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g_raf implicit none ! Passed Variables type(gsi_bundle),intent(inout) :: cstate ! Local Variables integer(i_kind) n,n3d,istatus,nlevs real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork real(r_kind),pointer,dimension(:,:,:):: ptr3d=>NULL() nlevs=s2g_raf%nlevs_loc n3d=cstate%n3d ! Multiply by background error variances, and break up skin temp ! into components call bkgvar(cstate,0) ! Apply vertical smoother !$omp parallel do schedule(dynamic,1) private(n,ptr3d,istatus) do n=1,n3d call gsi_bundlegetpointer ( cstate,cstate%r3(n)%shortname,ptr3d,istatus ) call frfhvo(ptr3d,n) end do ! Convert from subdomain to full horizontal field distributed among processors call general_sub2grid(s2g_raf,cstate%values,hwork) ! Apply horizontal smoother for number of horizontal scales call smoothrf(hwork,nlevs) ! Put back onto subdomains call general_grid2sub(s2g_raf,hwork,cstate%values) ! Apply vertical smoother !$omp parallel do schedule(dynamic,1) private(n,ptr3d,istatus) do n=1,n3d call gsi_bundlegetpointer ( cstate,cstate%r3(n)%shortname,ptr3d,istatus ) call frfhvo(ptr3d,n) end do ! Multiply by background error variances, and combine sst,sldnt, and sicet ! into skin temperature field call bkgvar(cstate,1) return end subroutine bkgcov ! ----------------------------------------------------------------------------- subroutine ckgcov(z,cstate,nval_lenz) !$$$ subprogram documentation block ! . . . . ! subprogram: ckgcov sqrt of bkgcov ! prgmmr: kleist org: np22 date: 2004-07-22 ! ! abstract: perform horizontal and vertical parts of background error ! ! program history log: ! 2007-04-24 parrish ! 2008-12-04 todling - turn sst,slndt,sicet to locals per GSI May08 ! update to bkgcov above. ! 2010-03-15 zhu - use nrf* and cstate for generalized control variable ! - make changes to interface of grid2sub ! 2010-04-28 todling - udpate to use gsi_bundle ! 2011-06-29 todling - no explict reference to internal bundle arrays ! 2011-09-05 todling - add explicit reference to navl_lenz, and remove connection through jfunc ! 2012-06-25 parrish - replace grid2sub with general_grid2sub. ! Remove arrays sst, slndt, sicet. These are now contained as ! motley variables in input/output bundle cstate. Remove unused variables ! nnnn1o,latlon11,nval_levs. ! 2016-03-25 todling - revisit beta multiplier term ! ! input argument list: ! z - long vector input control fields ! cstate - bundle containing control fields ! nlevs - number of vertical levels for smoothing ! nval_lenz- length of sqrt-B control vector ! ! output argument list: ! all after smoothing, combining scales ! cstate - bundle containing control fields ! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP !$$$ use kinds, only: r_kind,i_kind use constants, only: zero use gridmod, only: nlat,nlon use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use general_sub2grid_mod, only: general_grid2sub use general_commvars_mod, only: s2g_raf use hybrid_ensemble_parameters, only: l_hyb_ens use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult implicit none ! Passed Variables integer(i_kind) ,intent(in ) :: nval_lenz type(gsi_bundle),intent(inout) :: cstate real(r_kind),dimension(nval_lenz),intent(in ) :: z ! Local Variables integer(i_kind) k,n3d,istatus,nlevs real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork real(r_kind),dimension(:,:,:),pointer:: ptr3d=>NULL() nlevs=s2g_raf%nlevs_loc ! Apply horizontal smoother for number of horizontal scales call sqrt_smoothrf(z,hwork,nlevs) ! Put back onto subdomains call general_grid2sub(s2g_raf,hwork,cstate%values) ! Apply vertical smoother n3d=cstate%n3d !$omp parallel do schedule(dynamic,1) private(k,ptr3d,istatus) do k=1,n3d call gsi_bundlegetpointer ( cstate,cstate%r3(k)%shortname,ptr3d,istatus ) call frfhvo(ptr3d,k) end do ! Multiply by background error variances, and combine sst,sldnt, and sicet ! into skin temperature field call bkgvar(cstate,1) ! Apply static betas if(l_hyb_ens) call sqrt_beta_s_mult(cstate) return end subroutine ckgcov ! ----------------------------------------------------------------------------- subroutine ckgcov_ad(z,cstate,nval_lenz) !$$$ subprogram documentation block ! . . . . ! subprogram: ckgcov_ad adjoint of ckgcov ! prgmmr: kleist org: np22 date: 2004-07-22 ! ! abstract: perform horizontal and vertical parts of background error ! ! program history log: ! 2007-04-24 parrish ! 2008-12-04 todling - turn sst,slndt,sicet to locals per GSI May08 ! update to bkgcov above. ! 2010-03-15 zhu - use nrf* and cstate for generalized control variable ! - make changes to interface of sub2grid ! 2010-04-15 treadon - add %values to cstate in bkgvar call ! 2010-04-28 todling - update to use gsi_bundle ! 2011-06-29 todling - no explict reference to internal bundle arrays ! 2011-09-05 todling - add explicit reference to navl_lenz, and remove connection through jfunc ! 2012-06-25 parrish - replace sub2grid with general_sub2grid. ! Remove arrays sst, slndt, sicet. These are now contained as ! motley variables in input/output bundle cstate. Remove unused variables ! nnnn1o,latlon11. ! 2016-03-25 todling - revisit beta multiplier term ! ! input argument list: ! z - long vector adjoint input/output control fields ! cstate - bundle containing control fields ! nlevs - number of vertical levels for smoothing ! nval_lenz- length of sqrt-B control vector ! ! output argument list: ! all after smoothing, combining scales ! cstate - bundle containing adjoint control fields ! ! attributes: ! language: f90 ! machine: ibm RS/6000 SP !$$$ use kinds, only: r_kind,i_kind use constants, only: zero use gridmod, only: nlat,nlon use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use general_sub2grid_mod, only: general_sub2grid use general_commvars_mod, only: s2g_raf use hybrid_ensemble_parameters, only: l_hyb_ens use hybrid_ensemble_isotropic, only: sqrt_beta_s_mult implicit none ! Passed Variables integer(i_kind) ,intent(in ) :: nval_lenz type(gsi_bundle),intent(inout) :: cstate real(r_kind),dimension(nval_lenz),intent(inout) :: z ! Local Variables integer(i_kind) k,n3d,istatus,nlevs real(r_kind),dimension(nlat*nlon*s2g_raf%nlevs_alloc):: hwork real(r_kind),dimension(:,:,:),pointer:: ptr3d=>NULL() nlevs=s2g_raf%nlevs_loc ! Apply static betas if(l_hyb_ens) call sqrt_beta_s_mult(cstate) ! Multiply by background error variances, and break up skin temp ! into components call bkgvar(cstate,0) ! Apply vertical smoother n3d=cstate%n3d !$omp parallel do schedule(dynamic,1) private(k,ptr3d,istatus) do k=1,n3d call gsi_bundlegetpointer ( cstate,cstate%r3(k)%shortname,ptr3d,istatus ) call frfhvo(ptr3d,k) end do ! Convert from subdomain to full horizontal field distributed among processors call general_sub2grid(s2g_raf,cstate%values,hwork) ! Apply horizontal smoother for number of horizontal scales call sqrt_smoothrf_ad(z,hwork,nlevs) return end subroutine ckgcov_ad