From 299a1e549818f6a4187f6a73c1be24f682b2dd22 Mon Sep 17 00:00:00 2001 From: "john.derber" Date: Thu, 21 Sep 2023 13:56:37 +0000 Subject: [PATCH] Final update of branch. Fixes error in control_vectors. --- src/gsi/control_vectors.f90 | 8 +++++--- src/gsi/general_spectral_transforms.f90 | 4 ++-- src/gsi/get_gefs_ensperts_dualres.f90 | 10 +++++----- src/gsi/hybrid_ensemble_isotropic.F90 | 9 +++------ src/gsi/read_prepbufr.f90 | 6 +++--- src/gsi/stpcalc.f90 | 3 +-- 6 files changed, 19 insertions(+), 21 deletions(-) diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 97578124d2..73f605b95f 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -897,21 +897,23 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) itot=max(m3d,0)+max(m2d,0) if(l_hyb_ens)itot=itot+n_ens*naensgrp allocate(partsum(itot)) + partsum=zero_quad do ii=1,nsubwin !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m3d - partsum(i) = dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) + partsum(i) = partsum(i)+dplevs(xcv%step(ii)%r3(i)%q,ycv%step(ii)%r3(i)%q,ihalo=1) enddo !$omp parallel do schedule(dynamic,1) private(i) do i = 1,m2d - partsum(m3d+i) = dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) + partsum(m3d+i) = partsum(m3d+i)+dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) enddo if(l_hyb_ens) then do ig=1,naensgrp nigtmp=n_ens*(ig-1) !$omp parallel do schedule(dynamic,1) private(i) do i = 1,n_ens - partsum(m3d+m2d+nigtmp+i) = dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1) + partsum(m3d+m2d+nigtmp+i) = partsum(m3d+m2d+nigtmp+i) + & + dplevs(xcv%aens(ii,ig,i)%r3(1)%q,ycv%aens(ii,ig,i)%r3(1)%q,ihalo=1) end do end do end if diff --git a/src/gsi/general_spectral_transforms.f90 b/src/gsi/general_spectral_transforms.f90 index d4f0959489..541923e450 100644 --- a/src/gsi/general_spectral_transforms.f90 +++ b/src/gsi/general_spectral_transforms.f90 @@ -368,8 +368,8 @@ subroutine sfilter(grd,sp,filter,grid) call general_sptez_s(sp,spec_work,work,-1) - gnlon=float(grd%nlon) -! gnlon=real(grd%nlon,r_kind) +! gnlon=float(grd%nlon) + gnlon=real(grd%nlon,r_kind) do i=1,sp%nc spec_work(i)=spec_work(i)*gnlon end do diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index 52002594ae..beff850628 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -187,12 +187,12 @@ subroutine get_gefs_ensperts_dualres do j=1,jm do i=1,im ! Use following lines for results identical to previous version -! tv(i,j,k)= tv(i,j,k)*(one+fv*q(i,j,k)) -! q(i,j,k)=max(q(i,j,k),zero) -! tsen(i,j,k)=tv(i,j,k)/(one+fv*q(i,j,k)) + tv(i,j,k)= tv(i,j,k)*(one+fv*q(i,j,k)) q(i,j,k)=max(q(i,j,k),zero) - tsen(i,j,k)=tv(i,j,k) - tv(i,j,k)= tsen(i,j,k)*(one+fv*q(i,j,k)) + tsen(i,j,k)=tv(i,j,k)/(one+fv*q(i,j,k)) +! q(i,j,k)=max(q(i,j,k),zero) +! tsen(i,j,k)=tv(i,j,k) +! tv(i,j,k)= tsen(i,j,k)*(one+fv*q(i,j,k)) end do end do end do diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7173797799..fc87026c98 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -2204,6 +2204,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin) enddo endif ! iaens>0 enddo + do ic2=1,nc2d iaens=ensgrp2aensgrp(ig,ic2+nc3d,ibin) if(iaens>0) then @@ -3648,7 +3649,7 @@ subroutine bkerror_a_en(grady) z2=zero do ig2=1,naensgrp do k=1,nval_lenz_en - z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig2,ig) + z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2) enddo enddo call ckgcov_a_en_new_factorization(ig,z2,grady%aens(ii,ig,1:n_ens)) @@ -3714,11 +3715,7 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) real(r_kind),allocatable,dimension(:):: a_en_work - call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) - if(istatus/=0) then - write(6,*)'bkgcov_a_en_new_factorization: trouble getting pointer to ensemble CV' - call stop2(999) - endif + ipnt=1 ! Apply vertical smoother on each ensemble member ! To avoid my having to touch the general sub2grid and grid2sub, diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 2bf3a7d05d..ab39612477 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -2050,9 +2050,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(oelev>7000.0_r_kind) cycle loop_k_levs if(abs(diffvv)>5.0_r_kind.and.oelev<5000.0_r_kind) cycle loop_k_levs ! write(6,*)'sliu diffuu,vv::',diffuu, diffvv - uob=0.0 - vob=0.0 - oelev=0.0 + uob=zero + vob=zero + oelev=zero tkk=0 do ikkk=k,klev diffhgt=obsdat(4,ikkk)-obsdat(4,k) diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 30387341e3..835195dd43 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -263,7 +263,7 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),parameter:: one_tenth_quad = 0.1_r_quad ! Declare local variables - integer(i_kind) i,j,mm1,ii,iis,ibin,ipenloc,it + integer(i_kind) i,j,mm1,ii,ibin,ipenloc,it integer(i_kind) istp_use,nstep,nsteptot,kprt real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo @@ -429,7 +429,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & pbc=zero_quad pjcalc=.false. if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true. - iis=ii ! Delta stepsize sges(1)= stp(ii-1)