diff --git a/src/gsi/adjtest.f90 b/src/gsi/adjtest.f90 index d910d14f1..e1a5da7d0 100644 --- a/src/gsi/adjtest.f90 +++ b/src/gsi/adjtest.f90 @@ -33,10 +33,12 @@ module adjtest use control_vectors, only: control_vector,allocate_cv,random_cv, & deallocate_cv,dot_product,assignment(=) use state_vectors, only: allocate_state,deallocate_state,dot_product +use gridmod, only : minmype use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) use bias_predictors, only: predictors,allocate_preds,deallocate_preds, & assignment(=) +use control2state_mod, only: control2state,c2sset,control2state_ad implicit none private @@ -81,7 +83,7 @@ subroutine adtest(xhat) integer(i_kind) :: ii,idig real(r_kind) :: zz1,zz2,zz3 -if (mype==0) write(6,*)'ADTEST starting' +if (mype==minmype) write(6,*)'ADTEST starting' ! ---------------------------------------------------------------------- ! Allocate local variables @@ -97,10 +99,10 @@ subroutine adtest(xhat) ! Initialize control space vectors if (present(xhat)) then xtest1=xhat - if (mype==0) write(6,*)'ADTEST use input xhat' + if (mype==minmype) write(6,*)'ADTEST use input xhat' else call random_cv(xtest1) - if (mype==0) write(6,*)'ADTEST use random_cv(xhat)' + if (mype==minmype) write(6,*)'ADTEST use random_cv(xhat)' endif xtest2=zero @@ -135,18 +137,20 @@ subroutine adtest(xhat) do ii=1,nsubwin zz2=zz2+dot_product(stest1(ii),stest1(ii)) enddo -DO ii=1,nrclen +do ii=1,nrclen zz2=zz2+sbias1%values(ii)*sbias1%values(ii) -ENDDO +enddo -if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then - zz3=two*abs(zz1-zz2)/(zz1+zz2) -else - zz3=abs(zz1-zz2) -endif -idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) +if (mype==minmype) then + if ( abs(zz1+zz2) > sqrt(tiny(zz3)) ) then + zz3=two*abs(zz1-zz2)/(zz1+zz2) + else + zz3=abs(zz1-zz2) + end if + idig= int(-log(zz3+tiny(zz3))/log(10.0_r_kind)) -if (mype==0) then +! Note that this result is not completely correct especially on processors +! other than minmype. See issue 548. write(6,'(A)')' ADTEST 0.123456789012345678' write(6,'(A,ES25.18)')' ADTEST = ',zz1 write(6,'(A,ES25.18)')' ADTEST = ',zz2 @@ -166,7 +170,7 @@ subroutine adtest(xhat) call deallocate_preds(sbias2) ! ---------------------------------------------------------------------- -if (mype==0) write(6,*)'ADTEST finished' +if (mype==minmype) write(6,*)'ADTEST finished' return end subroutine adtest diff --git a/src/gsi/adjtest_obs.f90 b/src/gsi/adjtest_obs.f90 index 67e2ff0cd..294dc32ca 100644 --- a/src/gsi/adjtest_obs.f90 +++ b/src/gsi/adjtest_obs.f90 @@ -78,6 +78,7 @@ subroutine adtest_obs use m_obsdiags, only: obsLLists use m_obsLList, only: obsLList_getTLDdotprod + use control2state_mod, only: control2state implicit none diff --git a/src/gsi/aeroinfo.f90 b/src/gsi/aeroinfo.f90 index dd8489029..a030bdeff 100644 --- a/src/gsi/aeroinfo.f90 +++ b/src/gsi/aeroinfo.f90 @@ -313,12 +313,10 @@ subroutine aeroinfo_read ! Successful read, return to calling routine else -! File does not exist, write warning message to alert users +! File does not exist, write warning message to unit 6 to alert users if (mype==mype_aero) then - open(iout_aero) - write(iout_aero,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' - write(iout_aero,*)'AEROINFO_READ: jpch_aero=',jpch_aero - close(iout_aero) + write(6,*)'AEROINFO_READ: ***WARNING*** FILE ',trim(fname),' does not exist' + write(6,*)'AEROINFO_READ: jpch_aero=',jpch_aero endif end if diff --git a/src/gsi/atms_spatial_average_mod.f90 b/src/gsi/atms_spatial_average_mod.f90 index dd05faa23..b3e4aafc4 100644 --- a/src/gsi/atms_spatial_average_mod.f90 +++ b/src/gsi/atms_spatial_average_mod.f90 @@ -153,7 +153,7 @@ SUBROUTINE ATMS_Spatial_Average(Num_Obs, NChanl, FOV, Time, BT_InOut, & Scanline_Back(FOV(I),Scanline(I))=I END DO -!$omp parallel do schedule(dynamic,1) private(ichan,iscan,ios,ifov) +!$omp parallel do schedule(dynamic,1) private(i,ichan,iscan,ios,ifov) DO IChan=1,nchanl err(ichan)=0 diff --git a/src/gsi/bicg.f90 b/src/gsi/bicg.f90 index 6eb2f7890..d7ac743d8 100644 --- a/src/gsi/bicg.f90 +++ b/src/gsi/bicg.f90 @@ -30,7 +30,7 @@ subroutine bicg() use kinds, only: r_kind,i_kind,r_quad use gsi_4dvar, only: l4dvar, & - ladtest, lgrtest, lanczosave, ltcost, nwrvecs + ladtest, lgrtest, lanczosave, ltcost, nwrvecs, lsqrtb use jfunc, only: jiter,miter,niter,xhatsave,yhatsave,jiterstart use constants, only: zero,tiny_r_kind use mpimod, only: mype @@ -39,6 +39,7 @@ subroutine bicg() use obsmod, only: lsaveobsens,l_do_adjoint use adjtest, only: adtest use grdtest, only: grtest +use gsi_bundlemod, only : gsi_bundlegetpointer use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,write_cv,inquire_cv use control_vectors, only: dot_product,assignment(=) @@ -89,6 +90,13 @@ subroutine bicg() call allocate_cv(gradf) call allocate_cv(grads) +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + ! Get initial cost function and gradient nprt=2 diff --git a/src/gsi/bicglanczos.F90 b/src/gsi/bicglanczos.F90 index 1914b0214..13525e38c 100755 --- a/src/gsi/bicglanczos.F90 +++ b/src/gsi/bicglanczos.F90 @@ -57,13 +57,14 @@ module bicglanczos use constants, only : zero, one, half,two, zero_quad,tiny_r_kind use timermod , only : timer_ini, timer_fnl use lanczos , only : save_precond -use gsi_4dvar, only : iorthomax +use gsi_4dvar, only : iorthomax,lsqrtb use control_vectors, only: control_vector use control_vectors, only: allocate_cv,deallocate_cv,inquire_cv use control_vectors, only: read_cv,write_cv use control_vectors, only: dot_product,assignment(=) use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) +use gsi_bundlemod, only : gsi_bundlegetpointer use mpimod , only : mpi_comm_world use mpimod, only: mype use jfunc , only : iter, jiter @@ -248,7 +249,13 @@ subroutine pcglanczos(xhat,yhat,pcost,gradx,grady,preduc,kmaxit,lsavevecs) if(nprt>=1.and.ltcost_) call allocate_cv(gradf) call allocate_cv(dirw) -!--- 'zeta' is an upper bound on the relative error of the gradient. +if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if +end if + !--- 'zeta' is an upper bound on the relative error of the gradient. zeta = 1.0e-4_r_kind zreqrd = preduc diff --git a/src/gsi/bkerror.f90 b/src/gsi/bkerror.f90 index b3a014069..7eb83b09d 100644 --- a/src/gsi/bkerror.f90 +++ b/src/gsi/bkerror.f90 @@ -71,7 +71,6 @@ subroutine bkerror(grady) ! Declare local variables integer(i_kind) i,ii - integer(i_kind) i_t,i_p,i_st,i_vp integer(i_kind) ipnts(4),istatus ! integer(i_kind) nval_lenz,ndim2d real(r_kind),pointer,dimension(:,:,:):: p_t =>NULL() @@ -97,11 +96,7 @@ subroutine bkerror(grady) ! Only need to get pointer for ii=1 - all other are the same call gsi_bundlegetpointer ( grady%step(1), (/'t ','sf','vp','ps'/), & ipnts, istatus ) - i_t = ipnts(1) - i_st = ipnts(2) - i_vp = ipnts(3) - i_p = ipnts(4) - dobal = i_t>0.and.i_p>0.and.i_st>0.and.i_vp>0 + dobal = ipnts(1)>0 .and. ipnts(2)>0 .and. ipnts(3)>0 .and. ipnts(4)>0 ! if ensemble run, multiply by sqrt_beta_s if(l_hyb_ens) call sqrt_beta_s_mult(grady) diff --git a/src/gsi/calctends_no_tl.f90 b/src/gsi/calctends_no_tl.f90 index 73be86be2..d4dacb94a 100644 --- a/src/gsi/calctends_no_tl.f90 +++ b/src/gsi/calctends_no_tl.f90 @@ -244,28 +244,21 @@ subroutine calctends_no_tl(st,vp,t,p,mype,u_t,v_t,t_t,p_t,uvflag) end if end if -! top/bottom boundary condition: do j=jtstart(kk),jtstop(kk) do i=1,lat2 + +! top/bottom boundary condition: + what(i,j,1)=zero what(i,j,nsig+1)=zero - enddo - enddo - ! load actual dp/dt - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 p_t(i,j)=prsth(i,j,1) - end do - end do ! before big k loop, zero out the km1 summation arrays - do j=jtstart(kk),jtstop(kk) - do i=1,lat2 sumkm1 (i,j)=zero sum2km1 (i,j)=zero sumvkm1 (i,j)=zero diff --git a/src/gsi/compact_diffs.f90 b/src/gsi/compact_diffs.f90 index 14f7b8fdc..ae0340791 100644 --- a/src/gsi/compact_diffs.f90 +++ b/src/gsi/compact_diffs.f90 @@ -268,7 +268,6 @@ subroutine stvp2uv(work,idim) integer(i_kind) ix,iy integer(i_kind) ny,i,j real(r_kind) polsu,polnu,polnv,polsv - real(r_kind),dimension(nlon):: grid3n,grid3s,grid1n,grid1s real(r_kind),dimension(nlat-2,nlon):: a,b,grid1,grid2,grid3,grid4 if(idim <=1) write(6,*) ' error in call to stvp2uv ',idim @@ -318,27 +317,17 @@ subroutine stvp2uv(work,idim) polnv=polnv/float(nlon) polsu=polsu/float(nlon) polsv=polsv/float(nlon) - do ix=1,nlon - grid3n(ix)= polnu*coslon(ix)+polnv*sinlon(ix) - grid1n(ix)=-polnu*sinlon(ix)+polnv*coslon(ix) - grid3s(ix)= polsu*coslon(ix)+polsv*sinlon(ix) - grid1s(ix)= polsu*sinlon(ix)-polsv*coslon(ix) - end do ! work(1 is u, work(2 is v do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - work(1,i,j)=grid3(i-1,j) - work(2,i,j)=grid1(i-1,j) - else if(i == 1)then - work(1,i,j)=grid3s(j) - work(2,i,j)=grid1s(j) - else - work(1,i,j)=grid3n(j) - work(2,i,j)=grid1n(j) - end if + do i=2,nlat-1 + work(1,i,j)=grid3(i-1,j) + work(2,i,j)=grid1(i-1,j) end do - enddo + work(1,1,j)= polsu*coslon(j)+polsv*sinlon(j) + work(2,1,j)= polsu*sinlon(j)-polsv*coslon(j) + work(1,nlat,j)= polnu*coslon(j)+polnv*sinlon(j) + work(2,nlat,j)= -polnu*sinlon(j)+polnv*coslon(j) + end do return end subroutine stvp2uv @@ -749,18 +738,14 @@ subroutine tstvp2uv(work,idim) ny=nlat-2 do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then - grid3(i-1,j)=work(1,i,j) - grid1(i-1,j)=work(2,i,j) - else if(i == 1)then - grid3s(j)=work(1,i,j) - grid1s(j)=work(2,i,j) - else - grid3n(j)=work(1,i,j) - grid1n(j)=work(2,i,j) - end if + do i=2,nlat-1 + grid3(i-1,j)=work(1,i,j) + grid1(i-1,j)=work(2,i,j) end do + grid3s(j)=work(1,1,j) + grid1s(j)=work(2,1,j) + grid3n(j)=work(1,nlat,j) + grid1n(j)=work(2,nlat,j) end do polnu=zero @@ -815,16 +800,15 @@ subroutine tstvp2uv(work,idim) nlon,ny,noq) !$omp end parallel sections do j=1,nlon - do i=1,nlat - if(i /= 1 .and. i /= nlat)then -! NOTE: Adjoint of first derivative is its negative - work(1,i,j)=-(a(i-1,j)+d(i-1,j)) - work(2,i,j)=-(b(i-1,j)+c(i-1,j)) - else - work(1,i,j)=zero - work(2,i,j)=zero - end if + do i=2,nlat-1 +! NOTE: Adjoint of first derivative is its negative + work(1,i,j)=-(a(i-1,j)+d(i-1,j)) + work(2,i,j)=-(b(i-1,j)+c(i-1,j)) end do + work(1,1,j)=zero + work(2,1,j)=zero + work(1,nlat,j)=zero + work(2,nlat,j)=zero end do return diff --git a/src/gsi/constants.f90 b/src/gsi/constants.f90 index 484e46b8b..b4cf77506 100644 --- a/src/gsi/constants.f90 +++ b/src/gsi/constants.f90 @@ -90,7 +90,7 @@ module constants ! Declare derived constants integer(i_kind):: huge_i_kind - integer(i_kind), parameter :: max_varname_length=64 + integer(i_kind), parameter :: max_varname_length=20 real(r_single):: tiny_single, huge_single real(r_kind):: xai, xa, xbi, xb, dldt, rozcon,ozcon,fv, tpwcon,eps, rd_over_g real(r_kind):: el2orc, g_over_rd, rd_over_cp, cpr, omeps, epsm1, factor2 diff --git a/src/gsi/control2state.f90 b/src/gsi/control2state.f90 index fb87c1d0e..f2d8849ce 100644 --- a/src/gsi/control2state.f90 +++ b/src/gsi/control2state.f90 @@ -1,3 +1,65 @@ +!------------------------------------------------------------------------- +! NOAA/NCEP, National Centers for Environmental Prediction GSI ! +!------------------------------------------------------------------------- +!BOP +! +! !MODULE: control2state_mod --- control2state_mod variables and routines +! +! !INTERFACE: +! +module control2state_mod + +! !USES: + + +! !DESCRIPTION: module control2state routines and variables + +use kinds, only: r_kind,i_kind +use constants, only : max_varname_length, zero +use control_vectors, only: control_vector,c2sset_flg +use control_vectors, only: cvars3d,cvars2d +use bias_predictors, only: predictors +use jfunc, only: nsclen,npclen,ntclen +use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb,ladtest_obs +use gsi_chemguess_mod, only: gsi_chemguess_get +use gsi_metguess_mod, only: gsi_metguess_get +use gsi_bundlemod, only: gsi_bundlegetpointer +use gsi_bundlemod, only: gsi_bundlecreate +use gsi_bundlemod, only: gsi_bundle +use gsi_bundlemod, only: gsi_bundlegetvar +use gsi_bundlemod, only: gsi_bundleputvar +use gsi_bundlemod, only: gsi_bundledestroy +use gsi_bundlemod, only: assignment(=) +use gridmod, only: nems_nmmb_regional +use gridmod, only: regional, twodvar_regional +use gridmod, only: lat2,lon2,nsig,nlat,nlon +use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use mpeu_util, only: getindex + +implicit none + +private +public :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +public :: do_cw_to_hydro_hwrf,nclouds,ngases +public :: control2state +public :: control2state_ad +public :: c2sset +public :: icpblh,icgust,icvis,icoz,icwspd10m,icw +public :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +public :: icsfwter,icvpwter,ictcamt,iclcbas +public :: iccldch,icuwnd10m,icvwnd10m + +logical :: do_getprs,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro +logical :: do_cw_to_hydro_hwrf + +integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw +integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv +integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas +integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m + +integer :: ngases,nclouds + +contains subroutine control2state(xhat,sval,bval) !$$$ subprogram documentation block ! . . . . @@ -57,31 +119,11 @@ subroutine control2state(xhat,sval,bval) ! bval - Bias predictors ! !$$$ end documentation block -use kinds, only: r_kind,i_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, l4dvar, lsqrtb, ladtest_obs -use gridmod, only: regional,lat2,lon2,nsig, nlat, nlon, twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_tl use amassaeromod, only: amass2aero_tl -use cwhydromod, only: cw2hydro_tl_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_bundlemod, only: assignment(=) -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only : max_varname_length, zero use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use general_commvars_mod, only: s2g_cv -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 +use cwhydromod, only: cw2hydro_tl +use cwhydromod, only: cw2hydro_tl_hwrf implicit none ! Declare passed variables @@ -94,22 +136,9 @@ subroutine control2state(xhat,sval,bval) character(len=max_varname_length),allocatable,dimension(:) :: gases character(len=max_varname_length),allocatable,dimension(:) :: clouds real(r_kind),dimension(nlat*nlon*s2g_cv%nlevs_alloc) :: hwork -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz type(gsi_bundle):: wbundle ! work bundle -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -! Declare required local control variables -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: icsfwter,icvpwter,ictcamt,iclcbas -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() @@ -120,14 +149,6 @@ subroutine control2state(xhat,sval,bval) real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh real(r_kind),pointer,dimension(:,:) :: sv_ps=>NULL(),sv_sst=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_gust=>NULL(),sv_vis=>NULL(),sv_pblh=>NULL() real(r_kind),pointer,dimension(:,:) :: sv_wspd10m=>NULL(),sv_tcamt=>NULL(),sv_lcbas=>NULL() @@ -143,82 +164,17 @@ subroutine control2state(xhat,sval,bval) real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter -logical :: do_getprs_tl,do_normal_rh_to_q,do_tv_to_tsen,do_getuv,do_cw_to_hydro -logical :: do_cw_to_hydro_hwrf - - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(106) -end if -if (nsubwin/=1 .and. .not.l4dvar) then - write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar - call stop2(107) -end if - -! Inquire about cloud-vars -call gsi_metguess_get('clouds::3d',nclouds,istatus) +if (c2sset_flg)call c2sset(xhat,sval) if (nclouds>0) then allocate(clouds(nclouds)) call gsi_metguess_get('clouds::3d',clouds,istatus) end if -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) if (ngases>0) then allocate(gases(ngases)) call gsi_chemguess_get('gsinames',gases,istatus) endif -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getprs_tl =lc_ps.and.lc_t .and.ls_prse -do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q -do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen -do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v - -do_cw_to_hydro=.false. -do_cw_to_hydro_hwrf=.false. -if (regional) then - do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) ! Loop over control steps do jj=1,nsubwin @@ -295,7 +251,7 @@ subroutine control2state(xhat,sval,bval) ! Copy other variables call gsi_bundlegetvar ( wbundle, 't' , sv_tv, istatus ) ! Get 3d pressure - if(do_getprs_tl) call getprs_tl(cv_ps,cv_t,sv_prse) + if(do_getprs) call getprs_tl(cv_ps,cv_t,sv_prse) ! Convert input normalized RH to q if(do_normal_rh_to_q) call normal_rh_to_q(cv_rh,cv_t,sv_prse,sv_q) @@ -445,3 +401,471 @@ subroutine control2state(xhat,sval,bval) return end subroutine control2state +subroutine c2sset(xhat,sval) +!$$$ subprogram documentation block +! . . . . +! subprogram: c2sset +! prgmmr: derber +! +! abstract: Sets flags for control2state and control2state_ad +! +! program history log: +! 2022-08-30 derber - initial code from control2state + +! input argument list: +! xhat - Control variable +! sval - State variable +! +!$$$ end documentation block +implicit none + +! Declare passed variables +type(control_vector), intent(in) :: xhat +type(gsi_bundle) , intent(in) :: sval(nsubwin) + +! Declare local variables +character(len=*),parameter::myname='c2sset' +integer(i_kind) :: istatus + +! Note: The following does not aim to get all variables in +! the state and control vectors, but rather the ones +! this routines knows how to handle. +! Declare required local control variables +integer(i_kind), parameter :: ncvars = 9 +integer(i_kind) :: icps(ncvars) +character(len=3), parameter :: mycvars(ncvars) = (/ & ! vars from CV needed here + 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) +logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi + +! Declare required local state variables +integer(i_kind), parameter :: nsvars = 12 +integer(i_kind) :: isps(nsvars) +character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here + 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & + 'qr ', 'qs ', 'qg ', 'qh ' /) +logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi +logical :: ls_qr,ls_qs,ls_qg,ls_qh + + + +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(106) +end if +if (nsubwin/=1 .and. .not.l4dvar) then + write(6,*)trim(myname),': error 3dvar',nsubwin,l4dvar + call stop2(107) +end if + +! Inquire about cloud-vars +call gsi_metguess_get('clouds::3d',nclouds,istatus) + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) + +! Since each internal vector of xhat has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (xhat%step(1),mycvars,icps,istatus) +lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 +lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 +lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 + +! Since each internal vector of sval has the same structure, pointers are +! the same independent of the subwindow jj +call gsi_bundlegetpointer (sval(1),mysvars,isps,istatus) +ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 +ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 +ls_qi =isps(7)>0; ls_w =isps(8)>0 +ls_qr =isps(9)>0; ls_qs =isps(10)>0 +ls_qg =isps(11)>0; ls_qh =isps(12)>0 + +! Define what to do depending on what's in CV and SV +do_getprs =lc_ps.and.lc_t .and.ls_prse +do_normal_rh_to_q=lc_rh.and.lc_t .and.ls_prse.and.ls_q +do_tv_to_tsen =lc_t .and.ls_q .and.ls_tsen +do_getuv =lc_sf.and.lc_vp.and.ls_u.and.ls_v + +do_cw_to_hydro=.false. +do_cw_to_hydro_hwrf=.false. +if (regional) then + do_cw_to_hydro=lc_cw.and.ls_ql.and.ls_qi + do_cw_to_hydro_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh +else + do_cw_to_hydro=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global +endif + +call gsi_bundlegetpointer (xhat%step(1),'oz',icoz,istatus) +call gsi_bundlegetpointer (xhat%step(1),'gust',icgust,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vis',icvis,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pblh',icpblh,istatus) +call gsi_bundlegetpointer (xhat%step(1),'wspd10m',icwspd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'td2m',ictd2m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mxtm',icmxtm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'mitm',icmitm,istatus) +call gsi_bundlegetpointer (xhat%step(1),'pmsl',icpmsl,istatus) +call gsi_bundlegetpointer (xhat%step(1),'howv',ichowv,istatus) +call gsi_bundlegetpointer (xhat%step(1),'sfwter',icsfwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vpwter',icvpwter,istatus) +call gsi_bundlegetpointer (xhat%step(1),'w',icw,istatus) +call gsi_bundlegetpointer (xhat%step(1),'tcamt',ictcamt,istatus) +call gsi_bundlegetpointer (xhat%step(1),'lcbas',iclcbas,istatus) +call gsi_bundlegetpointer (xhat%step(1),'cldch',iccldch,istatus) +call gsi_bundlegetpointer (xhat%step(1),'uwnd10m',icuwnd10m,istatus) +call gsi_bundlegetpointer (xhat%step(1),'vwnd10m',icvwnd10m,istatus) + +c2sset_flg=.false. +return +end subroutine c2sset +subroutine control2state_ad(rval,bval,grad) +!$$$ subprogram documentation block +! . . . . +! subprogram: control2state_ad +! prgmmr: tremolet +! +! abstract: Converts variables from physical space to control space +! This is also the adjoint of control2state +! +! program history log: +! 2007-04-16 tremolet - initial code +! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d +! 2009-01-15 todling - handle predictors in quad precision +! 2009-04-21 derber - modify call to getstvp to call to getuv +! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) +! 2009-08-12 lueken - update documentation +! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp +! so introduce extra code to handle this case. +! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running +! in hybrid ensemble mode. +! 2010-03-24 zhu - use cstate for generalizing control variable +! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle +! 2010-05-31 todling - better consistency checks; add co/co2 +! - ready to bypass analysis of (any) meteorological fields +! 2010-06-15 todling - generalized handling of chemistry +! 2011-02-22 zhu - add gust,vis,pblh +! 2011-05-15 auligne/todling - generalized cloud handling +! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad +! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad +! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters +! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction +! 2013-10-25 todling - nullify work pointers +! 2013-10-28 todling - rename p3d to prse +! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA +! 2014-03-19 pondeca - add wspd10m +! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl +! 2014-05-07 pondeca - add howv +! 2014-06-16 carley/zhu - add tcamt and lcbas +! 2014-12-03 derber - introduce parallel regions for optimization +! 2015-07-10 pondeca - add cloud ceiling height (cldch) +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu +! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. +! 2016-05-03 pondeca - add uwnd10m, and vwnd10m +! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using +! total mass as control variable. +! +! input argument list: +! rval - State variable +! bval +! output argument list: +! grad - Control variable +! +!$$$ +use amassaeromod, only: amass2aero_ad +use cwhydromod, only: cw2hydro_ad +use cwhydromod, only: cw2hydro_ad_hwrf + +implicit none + +! Declare passed variables +type(gsi_bundle) , intent(inout) :: rval(nsubwin) +type(predictors) , intent(in ) :: bval +type(control_vector), intent(inout) :: grad + +! Declare local variables +character(len=*),parameter::myname='control2state_ad' +character(len=max_varname_length),allocatable,dimension(:) :: gases +character(len=max_varname_length),allocatable,dimension(:) :: clouds +integer(i_kind) :: ii,jj,ic,id,istatus,istatus_oz +type(gsi_bundle) :: wbundle ! work bundle + +real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() +real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() +!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() + +! Declare required local state variables +real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() +real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() +real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() + +real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter + + + +!****************************************************************************** + +if (c2sset_flg)call c2sset(grad,rval) +if (lsqrtb) then + write(6,*)trim(myname),': not for sqrt(B)' + call stop2(311) +end if + +! Inquire about clouds +if (nclouds>0) then + allocate(clouds(nclouds)) + call gsi_metguess_get ('clouds::3d',clouds,istatus) +endif + +! Inquire about chemistry +call gsi_chemguess_get('dim',ngases,istatus) +if (ngases>0) then + allocate(gases(ngases)) + call gsi_chemguess_get('gsinames',gases,istatus) +endif + + +! Loop over control steps +do jj=1,nsubwin + +! Create a work bundle similar to grad control vector's bundle + call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) + if (istatus/=0) then + write(6,*) trim(myname),': trouble creating work bundle' + call stop2(999) + endif + +!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) + +!$omp section + + call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) + call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) + call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) + call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) + call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) + call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) +! Convert RHS calculations for u,v to st/vp for application of +! background error + if (do_getuv) then + if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then + call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) + call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) + allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & + uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) + + uland=zero ; uwter=zero + vland=zero ; vwter=zero + + call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) + + call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) + call getuv(uland,vland,cv_sf,cv_vp,1) + deallocate(uland,vland,uwter,vwter) + else + call getuv(rv_u,rv_v,cv_sf,cv_vp,1) + endif + endif + + if(jj == 1)then + do ii=1,nsclen + grad%predr(ii)=bval%predr(ii) + enddo + do ii=1,npclen + grad%predp(ii)=bval%predp(ii) + enddo + if (ntclen>0) then + do ii=1,ntclen + grad%predt(ii)=bval%predt(ii) + enddo + end if + end if + +!$omp section + +! Get pointers to required control variables + call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) + call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) + call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) + +! Get pointers to this subwin require state variables + call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) + call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) + call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) + call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) + call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) + +! Adjoint of control to initial state + call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) + call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) + call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) + + if (do_cw_to_hydro .and. .not.do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi + call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) + elseif (do_cw_to_hydro_hwrf) then +! Case when cloud-vars do not map one-to-one +! e.g. cw-to-ql&qi&qr&qs&qg&qh + call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) + else +! Case when cloud-vars map one-to-one, take care of them together +! e.g. cw-to-cw + do ic=1,nclouds + id=getindex(cvars3d,clouds(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) + endif + enddo + end if +! Calculate sensible temperature + if(do_tv_to_tsen) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) + +! Adjoint of convert input normalized RH to q to add contribution of moisture +! to t, p , and normalized rh + if(do_normal_rh_to_q) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) + +! Adjoint to convert ps to 3-d pressure + if(do_getprs) call getprs_ad(cv_ps,cv_t,rv_prse) + + +!$omp section + + call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) + call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) + +! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) + call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) + + if (icoz>0) then + call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) + else + if(istatus_oz==0) rv_oz=zero + end if + +! Same one-to-one map for chemistry-vars; take care of them together + if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then + write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' + call stop2(999) + endif + + if (icvt_cmaq_fv3 == 2) then + call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) + else + do ic=1,ngases + id=getindex(cvars3d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) + endif + + id=getindex(cvars2d,gases(ic)) + if (id>0) then + call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) + call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) + endif + enddo + end if + if (icgust>0) then + call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) + call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) + end if + if (icvis >0) then + call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) + call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) + end if + if (icpblh>0)then + call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) + call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) + end if + if (icwspd10m>0) then + call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) + call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) + end if + if (ictd2m>0) then + call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) + call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) + end if + if (icmxtm>0) then + call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) + call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) + end if + if (icmitm>0) then + call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) + call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) + end if + if (icpmsl>0) then + call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) + call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) + end if + if (ichowv>0) then + call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) + call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) + end if + if (icw>0) then + call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) + call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) + if(nems_nmmb_regional)then + call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) + call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) + end if + end if + if (ictcamt>0) then + call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) + call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) + end if + if (iclcbas>0) then + call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) + call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) + call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) + ! Adjoint of convert loglcbas to lcbas + call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) + end if + if (iccldch >0) then + call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) + call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) + end if + if (icuwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) + end if + if (icvwnd10m>0) then + call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) + call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) + end if + +!$omp end parallel sections + +! Adjoint of transfer variables + + do ii=1,wbundle%ndim + grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) + enddo + call gsi_bundledestroy(wbundle,istatus) + if (istatus/=0) then + write(6,*) trim(myname),': trouble destroying work bundle' + call stop2(999) + endif + +end do + +! Clean up +if (ngases>0) deallocate(gases) + +if (nclouds>0) deallocate(clouds) + +return +end subroutine control2state_ad +end module control2state_mod diff --git a/src/gsi/control2state_ad.f90 b/src/gsi/control2state_ad.f90 deleted file mode 100644 index ce1e9d2cd..000000000 --- a/src/gsi/control2state_ad.f90 +++ /dev/null @@ -1,441 +0,0 @@ -subroutine control2state_ad(rval,bval,grad) -!$$$ subprogram documentation block -! . . . . -! subprogram: control2state_ad -! prgmmr: tremolet -! -! abstract: Converts variables from physical space to control space -! This is also the adjoint of control2state -! -! program history log: -! 2007-04-16 tremolet - initial code -! 2008-11-28 todling - update to GSI May 2008: add tsen and p3d -! 2009-01-15 todling - handle predictors in quad precision -! 2009-04-21 derber - modify call to getstvp to call to getuv -! 2009-06-15 parrish - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run) -! 2009-08-12 lueken - update documentation -! 2009-11-27 parrish - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp -! so introduce extra code to handle this case. -! 2010-02-20 parrish - introduce modifications to allow dual resolution capability when running -! in hybrid ensemble mode. -! 2010-03-24 zhu - use cstate for generalizing control variable -! 2010-04-29 todling - update to use gsi_bundle; rename cstate to wbundle -! 2010-05-31 todling - better consistency checks; add co/co2 -! - ready to bypass analysis of (any) meteorological fields -! 2010-06-15 todling - generalized handling of chemistry -! 2011-02-22 zhu - add gust,vis,pblh -! 2011-05-15 auligne/todling - generalized cloud handling -! 2011-07-12 zhu - add do_cw_to_hydro_ad and cw2hydro_ad -! 2011-11-01 eliu - generalize the use of do_cw_to_hydro_ad -! 2012-02-08 kleist - remove strong_bk_ad and ensemble_forward_model_ad and related parameters -! 2013-05-23 zhu - add ntclen and predt for aircraft temperature bias correction -! 2013-10-25 todling - nullify work pointers -! 2013-10-28 todling - rename p3d to prse -! 2014-01-31 mkim - add support for when ql and qi are CVs for all-sky mw radiance DA -! 2014-03-19 pondeca - add wspd10m -! 2014-04-10 pondeca - add td2m,mxtm,mitm,pmsl -! 2014-05-07 pondeca - add howv -! 2014-06-16 carley/zhu - add tcamt and lcbas -! 2014-12-03 derber - introduce parallel regions for optimization -! 2015-07-10 pondeca - add cloud ceiling height (cldch) -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2017-05-12 Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu -! 2016-08-12 lippi - add vertical velocity (w) to mycvars and mysvars. -! 2016-05-03 pondeca - add uwnd10m, and vwnd10m -! 2022-05-24 H.Wang - add amass2aero_ad for regional FV3-CMAQ DA when using -! total mass as control variable. -! -! input argument list: -! rval - State variable -! bval -! output argument list: -! grad - Control variable -! -!$$$ -use kinds, only: i_kind,r_kind -use control_vectors, only: control_vector -use control_vectors, only: cvars3d,cvars2d -use bias_predictors, only: predictors -use gsi_4dvar, only: nsubwin, lsqrtb -use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional -use jfunc, only: nsclen,npclen,ntclen -use cwhydromod, only: cw2hydro_ad -use amassaeromod, only: amass2aero_ad -use cwhydromod, only: cw2hydro_ad_hwrf -use gsi_bundlemod, only: gsi_bundlecreate -use gsi_bundlemod, only: gsi_bundle -use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundlegetvar -use gsi_bundlemod, only: gsi_bundleputvar -use gsi_bundlemod, only: gsi_bundledestroy -use gsi_chemguess_mod, only: gsi_chemguess_get -use gsi_metguess_mod, only: gsi_metguess_get -use mpeu_util, only: getindex -use constants, only: max_varname_length,zero -use gridmod, only: nems_nmmb_regional -use chemmod, only: laeroana_fv3cmaq, naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,icvt_cmaq_fv3 - -implicit none - -! Declare passed variables -type(gsi_bundle) , intent(inout) :: rval(nsubwin) -type(predictors) , intent(in ) :: bval -type(control_vector), intent(inout) :: grad - -! Declare local variables -character(len=*),parameter::myname='control2state_ad' -character(len=max_varname_length),allocatable,dimension(:) :: gases -character(len=max_varname_length),allocatable,dimension(:) :: clouds -integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz -type(gsi_bundle) :: wbundle ! work bundle - -! Note: The following does not aim to get all variables in -! the state and control vectors, but rather the ones -! this routines knows how to handle. -integer(i_kind), parameter :: ncvars = 9 -integer(i_kind) :: icps(ncvars) -integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw -integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv -integer(i_kind) :: ictcamt,iclcbas,icsfwter,icvpwter -integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m -character(len=3), parameter :: mycvars(ncvars) = (/ & - 'sf ', 'vp ', 'ps ', 't ', 'q ', 'cw ', 'ql ', 'qi ', 'w ' /) -logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi -real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() -real(r_kind),pointer,dimension(:,:) :: cv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL() -!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL() - -! Declare required local state variables -integer(i_kind), parameter :: nsvars = 12 -integer(i_kind) :: isps(nsvars) -character(len=4), parameter :: mysvars(nsvars) = (/ & ! vars from ST needed here - 'u ', 'v ', 'prse', 'q ', 'tsen', 'ql ', 'qi ', 'w ', & - 'qr ', 'qs ', 'qg ', 'qh ' /) -logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi -logical :: ls_qr,ls_qs,ls_qg,ls_qh -real(r_kind),pointer,dimension(:,:) :: rv_ps=>NULL(),rv_sst=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_wspd10m=>NULL(),rv_tcamt=>NULL(),rv_lcbas=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL() -real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL() -real(r_kind),pointer,dimension(:,:) :: rv_rank2=>NULL() - -real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter - -logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad -logical :: do_cw_to_hydro_ad_hwrf - - -!****************************************************************************** - -if (lsqrtb) then - write(6,*)trim(myname),': not for sqrt(B)' - call stop2(311) -end if - -! Inquire about clouds -call gsi_metguess_get ('clouds::3d',nclouds,istatus) -if (nclouds>0) then - allocate(clouds(nclouds)) - call gsi_metguess_get ('clouds::3d',clouds,istatus) -endif - -! Inquire about chemistry -call gsi_chemguess_get('dim',ngases,istatus) -if (ngases>0) then - allocate(gases(ngases)) - call gsi_chemguess_get('gsinames',gases,istatus) -endif - -! Since each internal vector [step(jj)] of grad has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus) -lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0 -lc_t =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0 -lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w =icps(9)>0 - -! Since each internal vector of xhat has the same structure, pointers are -! the same independent of the subwindow jj -call gsi_bundlegetpointer (rval(1),mysvars,isps,istatus) -ls_u =isps(1)>0; ls_v =isps(2)>0; ls_prse=isps(3)>0 -ls_q =isps(4)>0; ls_tsen=isps(5)>0; ls_ql =isps(6)>0 -ls_qi =isps(7)>0; ls_w =isps(8)>0 -ls_qr =isps(9)>0; ls_qs =isps(10)>0 -ls_qg =isps(11)>0; ls_qh =isps(12)>0 - -! Define what to do depending on what's in CV and SV -do_getuv =lc_sf.and.lc_vp.and.ls_u .and.ls_v -do_tv_to_tsen_ad =lc_t .and.ls_q .and.ls_tsen -do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q -do_getprs_ad =lc_t .and.lc_ps.and.ls_prse - -do_cw_to_hydro_ad=.false. -do_cw_to_hydro_ad_hwrf=.false. -if (regional) then - do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi - do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh -else - do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global -endif - -call gsi_bundlegetpointer (grad%step(1),'oz',icoz,istatus) -call gsi_bundlegetpointer (grad%step(1),'gust',icgust,istatus) -call gsi_bundlegetpointer (grad%step(1),'vis',icvis,istatus) -call gsi_bundlegetpointer (grad%step(1),'pblh',icpblh,istatus) -call gsi_bundlegetpointer (grad%step(1),'wspd10m',icwspd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'td2m',ictd2m,istatus) -call gsi_bundlegetpointer (grad%step(1),'mxtm',icmxtm,istatus) -call gsi_bundlegetpointer (grad%step(1),'mitm',icmitm,istatus) -call gsi_bundlegetpointer (grad%step(1),'pmsl',icpmsl,istatus) -call gsi_bundlegetpointer (grad%step(1),'howv',ichowv,istatus) -call gsi_bundlegetpointer (grad%step(1),'sfwter',icsfwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'vpwter',icvpwter,istatus) -call gsi_bundlegetpointer (grad%step(1),'w',icw,istatus) -call gsi_bundlegetpointer (grad%step(1),'tcamt',ictcamt,istatus) -call gsi_bundlegetpointer (grad%step(1),'lcbas',iclcbas,istatus) -call gsi_bundlegetpointer (grad%step(1),'cldch',iccldch,istatus) -call gsi_bundlegetpointer (grad%step(1),'uwnd10m',icuwnd10m,istatus) -call gsi_bundlegetpointer (grad%step(1),'vwnd10m',icvwnd10m,istatus) - -! Loop over control steps -do jj=1,nsubwin - -! Create a work bundle similar to grad control vector's bundle - call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus ) - if (istatus/=0) then - write(6,*) trim(myname),': trouble creating work bundle' - call stop2(999) - endif - -!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter) - -!$omp section - - call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus) - call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus) - call gsi_bundlegetpointer (rval(jj),'u' ,rv_u, istatus) - call gsi_bundlegetpointer (rval(jj),'v' ,rv_v, istatus) - call gsi_bundleputvar ( wbundle, 'sf', zero, istatus ) - call gsi_bundleputvar ( wbundle, 'vp', zero, istatus ) -! Convert RHS calculations for u,v to st/vp for application of -! background error - if (do_getuv) then - if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then - call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus) - call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus) - allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), & - uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig)) - - uland=zero ; uwter=zero - vland=zero ; vwter=zero - - call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0) - - call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1) - call getuv(uland,vland,cv_sf,cv_vp,1) - deallocate(uland,vland,uwter,vwter) - else - call getuv(rv_u,rv_v,cv_sf,cv_vp,1) - endif - endif - - if(jj == 1)then - do ii=1,nsclen - grad%predr(ii)=bval%predr(ii) - enddo - do ii=1,npclen - grad%predp(ii)=bval%predp(ii) - enddo - if (ntclen>0) then - do ii=1,ntclen - grad%predt(ii)=bval%predt(ii) - enddo - end if - end if - -!$omp section - -! Get pointers to required control variables - call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus) - call gsi_bundlegetpointer (wbundle,'t' ,cv_t, istatus) - call gsi_bundlegetpointer (wbundle,'q' ,cv_rh ,istatus) - -! Get pointers to this subwin require state variables - call gsi_bundlegetpointer (rval(jj),'ps' ,rv_ps, istatus) - call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus) - call gsi_bundlegetpointer (rval(jj),'tv' ,rv_tv, istatus) - call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus) - call gsi_bundlegetpointer (rval(jj),'q' ,rv_q , istatus) - -! Adjoint of control to initial state - call gsi_bundleputvar ( wbundle, 't' , rv_tv, istatus ) - call gsi_bundleputvar ( wbundle, 'q' , zero, istatus ) - call gsi_bundleputvar ( wbundle, 'ps', rv_ps, istatus ) - - if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi - call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds) - elseif (do_cw_to_hydro_ad_hwrf) then -! Case when cloud-vars do not map one-to-one -! e.g. cw-to-ql&qi&qr&qs&qg&qh - call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen) - else -! Case when cloud-vars map one-to-one, take care of them together -! e.g. cw-to-cw - do ic=1,nclouds - id=getindex(cvars3d,clouds(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, clouds(ic),rv_rank3,istatus) - endif - enddo - end if -! Calculate sensible temperature - if(do_tv_to_tsen_ad) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen) - -! Adjoint of convert input normalized RH to q to add contribution of moisture -! to t, p , and normalized rh - if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q) - -! Adjoint to convert ps to 3-d pressure - if(do_getprs_ad) call getprs_ad(cv_ps,cv_t,rv_prse) - - -!$omp section - - call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus) - call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus ) - -! call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus) - call gsi_bundlegetpointer (rval(jj),'oz' ,rv_oz , istatus_oz) - - if (icoz>0) then - call gsi_bundleputvar ( wbundle, 'oz', rv_oz, istatus ) - else - if(istatus_oz==0) rv_oz=zero - end if - -! Same one-to-one map for chemistry-vars; take care of them together - if (.not.laeroana_fv3cmaq .and. icvt_cmaq_fv3 == 2) then - write(6,*) ' icvt_cmaq_fv3 == 2 but laeroana_fv3cmaq=false stop!!!' - call stop2(999) - endif - - if (icvt_cmaq_fv3 == 2) then - call amass2aero_ad(rval(jj),wbundle,aeronames_cmaq_fv3,naero_cmaq_fv3) - else - do ic=1,ngases - id=getindex(cvars3d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank3,istatus) - endif - - id=getindex(cvars2d,gases(ic)) - if (id>0) then - call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus) - call gsi_bundleputvar (wbundle, gases(ic),rv_rank2,istatus) - endif - enddo - end if - if (icgust>0) then - call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus) - call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus ) - end if - if (icvis >0) then - call gsi_bundlegetpointer (rval(jj),'vis' ,rv_vis , istatus) - call gsi_bundleputvar ( wbundle, 'vis' , rv_vis , istatus ) - end if - if (icpblh>0)then - call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus) - call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus ) - end if - if (icwspd10m>0) then - call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus) - call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus ) - end if - if (ictd2m>0) then - call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus) - call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus ) - end if - if (icmxtm>0) then - call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus) - call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus ) - end if - if (icmitm>0) then - call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus) - call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus ) - end if - if (icpmsl>0) then - call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus) - call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus ) - end if - if (ichowv>0) then - call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus) - call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus ) - end if - if (icw>0) then - call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus) - call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus ) - if(nems_nmmb_regional)then - call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus) - call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus ) - end if - end if - if (ictcamt>0) then - call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus) - call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus ) - end if - if (iclcbas>0) then - call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus) - call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus) - call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus ) - ! Adjoint of convert loglcbas to lcbas - call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas) - end if - if (iccldch >0) then - call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus) - call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch , istatus ) - end if - if (icuwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus ) - end if - if (icvwnd10m>0) then - call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus) - call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus ) - end if - -!$omp end parallel sections - -! Adjoint of transfer variables - - do ii=1,wbundle%ndim - grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii) - enddo - call gsi_bundledestroy(wbundle,istatus) - if (istatus/=0) then - write(6,*) trim(myname),': trouble destroying work bundle' - call stop2(999) - endif - -end do - -! Clean up -if (ngases>0) deallocate(gases) - -if (nclouds>0) deallocate(clouds) - -return -end subroutine control2state_ad diff --git a/src/gsi/control_vectors.f90 b/src/gsi/control_vectors.f90 index 084725777..ea41b36c4 100644 --- a/src/gsi/control_vectors.f90 +++ b/src/gsi/control_vectors.f90 @@ -83,6 +83,7 @@ module control_vectors use hybrid_ensemble_parameters, only: beta_s0,l_hyb_ens use hybrid_ensemble_parameters, only: grd_ens use constants, only : max_varname_length +use gridmod, only : minmype use m_rerank, only : rerank use GSI_BundleMod, only : GSI_BundleCreate @@ -112,7 +113,7 @@ module control_vectors public dot_product public prt_control_norms, axpy, random_cv, setup_control_vectors, & write_cv, read_cv, inquire_cv, maxval, qdot_prod_sub, init_anacv, & - final_anacv + final_anacv,c2sset_flg ! ! Public variables @@ -157,6 +158,7 @@ module control_vectors integer(i_kind) :: latlon11,latlon1n,lat2,lon2,nsig,n_ens integer(i_kind) :: nval_lenz_en logical,save :: lsqrtb,lcalc_gfdl_cfrac +logical :: c2sset_flg integer(i_kind) :: m_vec_alloc, max_vec_alloc, m_allocs, m_deallocs @@ -413,6 +415,7 @@ subroutine init_anacv write(6,*) myname_,': ALL CONTROL VARIABLES ', nrf_var end if lcalc_gfdl_cfrac = .false. +c2sset_flg = .true. end subroutine init_anacv subroutine final_anacv @@ -889,12 +892,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) end do endif else + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + itot=max(m3d,0)+max(m2d,0) + if(l_hyb_ens)itot=itot+n_ens + allocate(partsum(itot)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - itot=max(m3d,0)+max(m2d,0) - if(l_hyb_ens)itot=itot+naensgrp*n_ens - allocate(partsum(itot)) !$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) @@ -915,12 +918,12 @@ real(r_quad) function qdot_prod_sub(xcv,ycv) do i=1,itot qdot_prod_sub = qdot_prod_sub + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if ! Duplicated part of vector - if(mype == 0)then + if(mype == minmype)then do j=nclen1+1,nclen qdot_prod_sub=qdot_prod_sub+xcv%values(j)*ycv%values(j) end do @@ -966,37 +969,35 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) character(len=*) , intent(in ) :: eb real(r_quad) , intent( out) :: prods(nsubwin+1) - real(r_quad) :: zz(nsubwin) integer(i_kind) :: ii,i,nn,m3d,m2d real(r_quad),allocatable,dimension(:) :: partsum integer(i_kind) :: ig integer(i_kind) ::ngtmp,nn0 prods(:)=zero_quad - zz(:)=zero_quad ! Independent part of vector if (lsqrtb) then if(trim(eb) == 'cost_b') then do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%step(ii)%values(:) ,ycv%step(ii)%values(:) ) end do endif if(trim(eb) == 'cost_e') then do ig=1,naensgrp do nn=1,n_ens do ii=1,nsubwin - zz(ii)=zz(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) + prods(ii)=prods(ii)+qdot_product( xcv%aens(ii,ig,nn)%values(:) ,ycv%aens(ii,ig,nn)%values(:) ) end do end do end do endif else if(trim(eb) == 'cost_b') then + m3d=xcv%step(1)%n3d + m2d=xcv%step(1)%n2d + allocate(partsum(m2d+m3d)) do ii=1,nsubwin - m3d=xcv%step(ii)%n3d - m2d=xcv%step(ii)%n2d - allocate(partsum(m2d+m3d)) !$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) @@ -1006,17 +1007,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) partsum(m3d+i)= dplevs(xcv%step(ii)%r2(i)%q,ycv%step(ii)%r2(i)%q,ihalo=1) enddo do i = 1,m2d+m3d - zz(ii)=zz(ii) + partsum(i) + prods(ii)=prods(ii) + partsum(i) end do - deallocate(partsum) end do + deallocate(partsum) end if if(trim(eb) == 'cost_e') then - do ii=1,nsubwin ! RTod: somebody could work in opt/zing this ... - allocate(partsum(n_ens*naensgrp)) + allocate(partsum(n_ens*naensgrp)) + do ii=1,nsubwin +!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d,ig,ngtmp,nn0) do ig=1,naensgrp ngtmp=(ig-1)*n_ens -!$omp parallel do schedule(dynamic,1) private(nn,m3d,m2d) do nn=1,n_ens nn0=nn+ngtmp partsum(nn0) = zero_quad @@ -1031,20 +1032,17 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) enddo end do do nn=1,n_ens*naensgrp - zz(ii)=zz(ii)+partsum(nn) + prods(ii)=prods(ii)+partsum(nn) end do - deallocate(partsum) end do + deallocate(partsum) end if end if - call mpl_allreduce(nsubwin,qpvals=zz) - prods(1:nsubwin) = zz(1:nsubwin) - ! Duplicated part of vector - if(trim(eb) == 'cost_b') then + if(mype == minmype .and. trim(eb) == 'cost_b' ) then if (nsclen>0) then - prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predr(:),ycv%predr(:)) + prods(nsubwin+1) = qdot_product(xcv%predr(:),ycv%predr(:)) endif if (npclen>0) then prods(nsubwin+1) = prods(nsubwin+1) + qdot_product(xcv%predp(:),ycv%predp(:)) @@ -1054,6 +1052,9 @@ subroutine qdot_prod_vars_eb(xcv,ycv,prods,eb) endif end if + call mpl_allreduce(nsubwin+1,qpvals=prods) + + return end subroutine qdot_prod_vars_eb ! ---------------------------------------------------------------------- diff --git a/src/gsi/convthin.f90 b/src/gsi/convthin.f90 index cc6d2ed1b..99629b8af 100644 --- a/src/gsi/convthin.f90 +++ b/src/gsi/convthin.f90 @@ -326,11 +326,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -358,25 +355,17 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -394,7 +383,8 @@ subroutine map3grids(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,iobs ibest_save(itx,ip) = iin ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -473,7 +463,8 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp + real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -510,13 +501,13 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -535,10 +526,10 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! TDR fore/aft (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_fore(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_fore(itx,ip)= crit icount_fore(itx,ip)=icount_fore(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -549,8 +540,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_fore(itx,ip) > 0 .and. crit < score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ! iobsout=ibest_obs(itx,ip) icount(itx,ip)=icount(itx,ip)+1 @@ -560,27 +549,19 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ibest_save(itx,ip)=iobs ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore(itx,ip) > 0 .and. crit > score_crit_fore(itx,ip)) then - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - iuse=.false. - ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else - iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind + iuse=.false. endif ! cases else if(aftswp) then ! aft sweeps + iobs=iobs+1 + iobsout=iobs ! Case(1): first obs at this location, keep this obs as starting point if (icount_aft(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 ibest_obs(itx,ip) = iobs @@ -589,8 +570,6 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case(2): obs score < best value at this location, ! --> update score, count, and best obs counters elseif (icount_aft(itx,ip) > 0 .and. crit < score_crit_aft(itx,ip)) then - iobs=iobs+1 - iobsout=iobs score_crit_aft(itx,ip)= crit icount_aft(itx,ip)=icount_aft(itx,ip)+1 iobsout=ibest_obs(itx,ip) @@ -599,36 +578,20 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io rusage(iobs)=usage ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif(icount_aft(itx,ip) > 0 .and. crit > score_crit_aft(itx,ip)) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case(4): none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit(itx,ip) .and. icount(itx,ip) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then - iobs=iobs+1 - iobsout=iobs + if (icount(itx,ip) > 0 .and. crit < score_crit(itx,ip)) then score_crit(itx,ip)= crit icount(itx,ip)=icount(itx,ip)+1 iiout = ibest_obs(itx,ip) @@ -640,20 +603,17 @@ subroutine map3grids_m(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,crit1,io ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount(itx,ip)==0) then - iobs=iobs+1 - iobsout=iobs score_crit(itx,ip)= crit ibest_obs(itx,ip) = iobs icount(itx,ip)=icount(itx,ip)+1 ibest_save(itx,ip) = iin rusage(iobs)=usage -! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! or none of the above cases are satisified, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/convthin_time.f90 b/src/gsi/convthin_time.f90 index 36ab17839..7f36caf09 100644 --- a/src/gsi/convthin_time.f90 +++ b/src/gsi/convthin_time.f90 @@ -226,7 +226,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -262,13 +263,13 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -306,10 +307,8 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, -! --> do not use this obs, return to calling program. - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit > score_crit_fore_tm(itx,ip,itm)) then - iuse=.false. ! Case(4): none of the above cases are satisified, don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. endif ! cases @@ -337,25 +336,17 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& ibest_save_tm(itx,ip,itm)=iin ! Case(3): obs score > best value at this location, +! Case(4): none of the above cases are satisified, ! --> do not use this obs, return to calling program. - elseif(icount_aft_tm(itx,ip,itm) > 0 .and. crit > score_crit_aft_tm(itx,ip,itm)) then - iuse=.false. - -! Case(4): none of the above cases are satisified, -! --> don't use this obs else iuse = .false. endif ! cases else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit iobsout=ibest_obs_tm(itx,ip,itm) icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 @@ -372,8 +363,9 @@ subroutine map3grids_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,& icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. end if @@ -447,7 +439,8 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c integer(i_kind) ix,iy real(r_kind) dlat1,dlon1,pob1 - real(r_kind) dx,dy,dp,dxx,dyy,dpp + real(r_kind) dx,dy,dp +! real(r_kind) dxx,dyy,dpp real(r_kind) crit!,dist1 logical foreswp, aftswp @@ -484,13 +477,13 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c dx=dlon1-ix ix=max(1,min(ix,mlon(iy))) - dxx=half-min(dx,one-dx) - dyy=half-min(dy,one-dy) - if( pflag == 1) then - dpp=half-min(dp,one-dp) - else - dpp=min(dp,one-dp) - endif +! dxx=half-min(dx,one-dx) +! dyy=half-min(dy,one-dy) +! if( pflag == 1) then +! dpp=half-min(dp,one-dp) +! else +! dpp=min(dp,one-dp) +! endif itx=hll(ix,iy) @@ -508,19 +501,11 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! TDR fore (Pseudo-dual-Doppler-radars) if(foreswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_fore_tm(itx,ip,itm) .and. icount_fore_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.1_r_kind - ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + iobs=iobs+1 + iobsout=iobs + if (icount_fore_tm(itx,ip,itm) > 0 .and. crit < score_crit_fore_tm(itx,ip,itm)) then score_crit_fore_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_fore_tm(itx,ip,itm)=icount_fore_tm(itx,ip,itm)+1 @@ -532,8 +517,6 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_fore_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_fore_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs @@ -541,28 +524,20 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ibest_save_tm(itx,ip,itm) = iobs ! Case: none of the above cases are satisified, -! --> don't use this obs +! Case: obs score > best value at this location, +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if ! TDR aft (Pseudo-dual-Doppler-radars) else if(aftswp) then ! fore sweeps -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_aft_tm(itx,ip,itm) .and. icount_aft_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_aft_tm(itx,ip,itm) > 0 .and. crit < score_crit_aft_tm(itx,ip,itm)) then score_crit_aft_tm(itx,ip,itm)= crit ! iobsout=ibest_obs_tm(itx,ip) icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 @@ -574,37 +549,27 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_aft_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_aft_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_aft_tm(itx,ip,itm)=icount_aft_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iobs +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.1_r_kind end if else -! Case: obs score > best value at this location, -! --> do not use this obs, return to calling program. - if(crit > score_crit_tm(itx,ip,itm) .and. icount_tm(itx,ip,itm) > 0) then - iuse=.false. - iobs=iobs+1 - iobsout=iobs - rusage(iobs)=101.0_r_kind + iobs=iobs+1 + iobsout=iobs ! Case: obs score < best value at this location, ! --> update score, count, and best obs counters - elseif (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then - iobs=iobs+1 - iobsout=iobs + if (icount_tm(itx,ip,itm) > 0 .and. crit < score_crit_tm(itx,ip,itm)) then score_crit_tm(itx,ip,itm)= crit icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 iiout = ibest_obs_tm(itx,ip,itm) @@ -616,20 +581,17 @@ subroutine map3grids_m_tm(flg,pflag,pcoord,nlevp,dlat_earth,dlon_earth,pob,itm,c ! Case: first obs at this location, ! --> keep this obs as starting point elseif (icount_tm(itx,ip,itm)==0) then - iobs=iobs+1 - iobsout=iobs rusage(iobs)=usage score_crit_tm(itx,ip,itm)= crit ibest_obs_tm(itx,ip,itm) = iobs icount_tm(itx,ip,itm)=icount_tm(itx,ip,itm)+1 ibest_save_tm(itx,ip,itm) = iin +! Case: obs score > best value at this location, ! Case: none of the above cases are satisified, -! --> don't use this obs +! --> do not use this obs, return to calling program. else iuse = .false. - iobs=iobs+1 - iobsout=iobs rusage(iobs)=101.0_r_kind end if end if diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 683e13d74..7a14cd322 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -977,11 +977,15 @@ subroutine upd_varch_ if(isurf==1) then if(iamroot_)write(6,'(1x,a6,a20,2i6,2f20.15)')'>>>',idnames(itbl),jj,nn,varch(mm),sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - endif - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(jj,jj)) + end if enddo else allocate(ircv(nchanl1)) @@ -1023,15 +1027,9 @@ subroutine upd_varch_ IJsubset(iii)=ijac(ii) ! subset indexes in channels presently in use endif enddo - if (iii/=ncp) then - if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp - endif - call die(myname_,' serious dimensions insconsistency, aborting') - endif - if (jjj/=ncp) then + if (iii/=ncp .or. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp + write(6,*) myname, ' iii,jjj,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency, aborting') endif @@ -1039,11 +1037,17 @@ subroutine upd_varch_ nn=IJsubset(ii) mm=ich1(nn) rr=IRsubset(ii) - if(isurf==1) varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==2) varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==3) varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==4) varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) - if(isurf==5) varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + if(isurf==1) then + varch_sea(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==2) then + varch_land(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==3) then + varch_ice(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==4) then + varch_snow(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + else if(isurf==5) then + varch_mixed(mm)=sqrt(GSI_BundleErrorCov(itbl)%R(rr,rr)) + end if enddo ! clean up deallocate(IJsubset) @@ -1260,18 +1264,12 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga IJsubset(iii)=ijac(ii) ! subset indexes in Jac/dep presently in use endif enddo - if (iii/=ncp) then + if (iii/=ncp .and. jjj/=ncp) then if (iamroot_) then - write(6,*) myname, ' iii,ncp= ',iii,ncp + write(6,*) myname, ' iii,ncp= ',iii,jjj,ncp endif call die(myname_,' serious dimensions insconsistency (R), aborting') endif - if (jjj/=ncp) then - if (iamroot_) then - write(6,*) myname, ' jjj,ncp= ',jjj,ncp - endif - call die(myname_,' serious dimensions insconsistency (J), aborting') - endif if( ErrorCov%method<0 ) then ! Keep departures and Jacobian unchanged @@ -1300,33 +1298,25 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga ! decompose the sub-matrix - returning the result in the ! structure holding the full covariance - nsigjac=size(jacobian,1) - allocate(row(nsigjac,ncp)) - allocate(col(ncp),col2(ncp)) - row=zero_quad - col=zero_quad - col2=zero_quad - - allocate(qcaj(ncp)) allocate(UT(ncp,ncp)) - qcaj = one - UT = zero if( ErrorCov%method==2 ) then if(lqcoef)then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = raterr2(jjj) + qcaj(jj) = raterr2(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) else subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd) endif else if( ErrorCov%method==1 ) then + allocate(qcaj(ncp)) do jj=1,ncp - jjj=IJsubset(jj) - qcaj(jj) = varinv(jjj) + qcaj(jj) = varinv(IJsubset(jj)) enddo subset = choleskydecom_inv_ (IRsubset,IJsubset,ErrorCov,UT,diagadd,qcaj) + deallocate(qcaj) endif if(.not.subset) then @@ -1345,23 +1335,31 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga do kk=ii,ncp rinvdiag(ii)=rinvdiag(ii)+UT(ii,kk)**2 enddo - enddo + end do + nsigjac=size(jacobian,1) + allocate(row(nsigjac,ncp)) + allocate(col(ncp),col2(ncp)) +!$omp parallel do schedule(dynamic,1) private(ii,jj,nn) do ii=1,ncp + row(:,ii)=zero_quad + col(ii)=zero_quad + col2(ii)=zero_quad do jj=1,ii nn=IJsubset(jj) col(ii) = col(ii) + UT(jj,ii) * depart(nn) - col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) + col2(ii) = col2(ii) + UT(jj,ii) * obs(nn) row(:,ii) = row(:,ii) + UT(jj,ii) * jacobian(:,nn) enddo enddo + deallocate(UT) ! Place Jacobian and departure in output arrays - do jj=1,ncp - mm=IJsubset(jj) - depart(mm)=col(jj) - obs(mm)=col2(jj) - jacobian(:,mm)=row(:,jj) + do ii=1,ncp + mm=IJsubset(ii) + depart(mm)=col(ii) + obs(mm)=col2(ii) + jacobian(:,mm)=row(:,ii) raterr2(mm) = one err2(mm) = one wgtjo(mm) = one @@ -1369,8 +1367,6 @@ logical function scale_jac_(depart,obs,err2,raterr2,jacobian,nchanl,varinv,diaga deallocate(col,col2) deallocate(row) - deallocate(qcaj) - deallocate(UT) else if( ErrorCov%method==3 ) then !use diag(Re) scales GSI specified errors ! inv(Rg) = inv(De*Dg) @@ -1445,17 +1441,16 @@ logical function choleskydecom_inv_(Isubset,IJsubset,ErrorCov,UT,diagadd,qcaj) do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj))/sqrt(qcaj(ii)*qcaj(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo else do jj=1,ncp do ii=1,ncp UT(ii,jj) = ErrorCov%R(Isubset(ii),Isubset(jj)) enddo + UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) enddo endif - do jj=1,ncp - UT(jj,jj) = UT(jj,jj)+diagadd(IJsubset(jj)) - enddo if(r_kind==r_single) then ! this trick only works because this uses the f77 lapack interfaces call SPOTRF('U', ncp, UT, ncp, info ) else if(r_kind==r_double) then diff --git a/src/gsi/cplr_gfs_ensmod.f90 b/src/gsi/cplr_gfs_ensmod.f90 index dc55bcaf9..67f15ebae 100644 --- a/src/gsi/cplr_gfs_ensmod.f90 +++ b/src/gsi/cplr_gfs_ensmod.f90 @@ -16,12 +16,22 @@ module get_gfs_ensmod_mod ! machine: ibm RS/6000 SP ! !$$$ + use kinds, only: i_kind,r_kind,r_single use mpeu_util, only: die use mpimod, only: mype,npe use abstract_ensmod, only: this_ens_class => abstractEnsemble + use genex_mod, only: genex_info implicit none private + + integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz + integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz + integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz + integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz + integer(i_kind) :: n2d + type(genex_info) :: s_a2b + public :: ensemble public :: ensemble_typemold @@ -84,7 +94,6 @@ subroutine get_gfs_Nens(this,grd,members,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: ens_fast_read @@ -153,10 +162,10 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & ! ! input argument list: ! ntindex - time index for ensemble -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! ! output argument list: -! ens_atm_bundle - atm bundle w/ fields for ensemble +! atm_bundle - atm bundle w/ fields for ensemble ! iret - return code, 0 for successful read. ! ! attributes: @@ -166,16 +175,16 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & !$$$ use mpimod, only: mpi_comm_world,ierror,mpi_real8,mpi_integer4,mpi_max - use kinds, only: i_kind,r_single,r_kind use constants, only: zero use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_destroy_info use gsi_4dvar, only: ens_fhrlevs use gsi_bundlemod, only: gsi_bundle - use hybrid_ensemble_parameters, only: n_ens,grd_ens + use gsi_bundlemod, only : assignment(=) + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens use hybrid_ensemble_parameters, only: ensemble_path use control_vectors, only: nc2d,nc3d !use control_vectors, only: cvars2d,cvars3d - use genex_mod, only: genex_info,genex_create_info,genex,genex_destroy_info + use genex_mod, only: genex_create_info,genex,genex_destroy_info use gridmod, only: use_gfs_nemsio use jfunc, only: cnvw_option @@ -195,16 +204,11 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & character(len=70) :: filenamesfc integer(i_kind) :: i,ii,j,jj,k,n integer(i_kind) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens - integer(i_kind) :: ip,ips,ipe,jps,jpe - integer(i_kind) :: ias,iae,iasm,iaem,iaemz,jas,jae,jasm,jaem,jaemz - integer(i_kind) :: kas,kae,kasm,kaem,kaemz,mas,mae,masm,maem,maemz - integer(i_kind) :: ibs,ibe,ibsm,ibem,ibemz,jbs,jbe,jbsm,jbem,jbemz - integer(i_kind) :: kbs,kbe,kbsm,kbem,kbemz,mbs,mbe,mbsm,mbem,mbemz - integer(i_kind) :: n2d + integer(i_kind) :: ip integer(i_kind) :: nlon,nlat,nsig - type(genex_info) :: s_a2b + integer(i_kind),dimension(n_ens) :: io_pe0 real(r_single),allocatable,dimension(:,:,:,:) :: en_full,en_loc - real(r_kind),allocatable,dimension(:,:,:) :: en_loc3 + real(r_kind),allocatable,dimension(:) :: sloc integer(i_kind),allocatable,dimension(:) :: m_cvars2dw,m_cvars3dw integer(i_kind) :: m_cvars2d(nc2d),m_cvars3d(nc3d) type(sub2grid_info) :: grd3d @@ -214,61 +218,69 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & nlon=grd_ens%nlon nsig=grd_ens%nsig + if(ntindex == 1)then ! set up partition of available processors for parallel read - if ( n_ens > npe ) & - call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) + if ( n_ens > npe ) & + call die(myname_, ': ***ERROR*** CANNOT READ ENSEMBLE n_ens > npe, increase npe >= n_ens', 99) - call ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) - ! setup communicator for scatter to subdomains: - - ! first, define gsi subdomain boundaries in global units: + call ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) - ip=1 ! halo width is hardwired at 1 - ips=grd_ens%istart(mype+1) - ipe=ips+grd_ens%lat1-1 - jps=grd_ens%jstart(mype+1) - jpe=jps+grd_ens%lon1-1 + ! setup communicator for scatter to subdomains: + ! first, define gsi subdomain boundaries in global units: !!!!!!!!!!!!NOTE--FOLLOWING HAS MANY VARS TO BE DEFINED--NLAT,NLON ARE ENSEMBLE DOMAIN DIMS !!!!!!!!for example, n2d = nc3d*nsig + nc2d - n2d=nc3d*grd_ens%nsig+nc2d - ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 - if(mype==io_pe) then - iae=nlat - jae=nlon - kae=n2d - mas=n_io_pe_s ; mae=n_io_pe_em - endif - iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae - - ibs =ips ; ibe =ipe ; jbs =jps ; jbe =jpe - ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip - kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens - kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe - iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) - kaemz=max(kasm,kaem) ; maemz=max(masm,maem) - ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) - kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) - call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & - ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & - iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & - ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) - - write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas -22 format(a,'sigf',i2.2,'_ens_mem',i3.3) + n2d=nc3d*grd_ens%nsig+nc2d + ias=1 ; iae=0 ; jas=1 ; jae=0 ; kas=1 ; kae=0 ; mas=1 ; mae=0 + if(mype==io_pe) then + iae=nlat + jae=nlon + kae=n2d + mas=n_io_pe_s ; mae=n_io_pe_em + endif + iasm=ias ; iaem=iae ; jasm=jas ; jaem=jae ; kasm=kas ; kaem=kae ; masm=mas ; maem=mae + + ip=1 ! halo width is hardwired at 1 + ibs=grd_ens%istart(mype+1) + ibe=ibs+grd_ens%lat1-1 + jbs=grd_ens%jstart(mype+1) + jbe=jbs+grd_ens%lon1-1 + + ibsm=ibs-ip ; ibem=ibe+ip ; jbsm=jbs-ip ; jbem=jbe+ip + kbs =1 ; kbe =n2d ; mbs =1 ; mbe =n_ens + kbsm=kbs ; kbem=kbe ; mbsm=mbs ; mbem=mbe + iaemz=max(iasm,iaem) ; jaemz=max(jasm,jaem) + kaemz=max(kasm,kaem) ; maemz=max(masm,maem) + ibemz=max(ibsm,ibem) ; jbemz=max(jbsm,jbem) + kbemz=max(kbsm,kbem) ; mbemz=max(mbsm,mbem) + call genex_create_info(s_a2b,ias ,iae ,jas ,jae ,kas ,kae ,mas ,mae , & + ibs ,ibe ,jbs ,jbe ,kbs ,kbe ,mbs ,mbe , & + iasm,iaem,jasm,jaem,kasm,kaem,masm,maem, & + ibsm,ibem,jbsm,jbem,kbsm,kbem,mbsm,mbem) + + if(mype==0)then + do n=1,n_ens + write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,'on pe', io_pe0(n) + enddo + end if + end if + if(mype==0) write(6,*) ' reading time level ',ntindex allocate(m_cvars2dw(nc2din),m_cvars3dw(nc3din)) m_cvars2dw=-999 m_cvars3dw=-999 - allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + !! read ensembles if ( mas == mae ) then + allocate(en_full(iasm:iaemz,jasm:jaemz,kasm:kaemz,masm:maemz)) + write(filename,22) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas +22 format(a,'sigf',i2.2,'_ens_mem',i3.3) if ( use_gfs_nemsio ) then if (cnvw_option) then write(filenamesfc,23) trim(adjustl(ensemble_path)),ens_fhrlevs(ntindex),mas @@ -284,7 +296,7 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & filename,.true.) end if else - call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & + call parallel_read_gfsnc_state_(en_full,m_cvars2dw,m_cvars3dw,nlon,nlat,nsig, & ias,jas,mas, & iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename) @@ -295,43 +307,41 @@ subroutine get_user_ens_gfs_fastread_(ntindex,atm_bundle, & call mpi_allreduce(m_cvars3dw,m_cvars3d,nc3d,mpi_integer4,mpi_max,mpi_comm_world,ierror) deallocate(m_cvars2dw,m_cvars3dw) + ! scatter to subdomains: +! en_loc=zero allocate(en_loc(ibsm:ibemz,jbsm:jbemz,kbsm:kbemz,mbsm:mbemz)) - - en_loc=zero call genex(s_a2b,en_full,en_loc) - deallocate(en_full) - call genex_destroy_info(s_a2b) ! check on actual routine name + if(mas == mae)deallocate(en_full) + -! transfer en_loc to en_loc3 then to atm_bundle +! call genex_destroy_info(s_a2b) ! check on actual routine name - allocate(en_loc3(lat2in,lon2in,nc2d+nc3d*nsig)) - iret = 0 + allocate(sloc(lat2in*lon2in*(nc2d+nc3d*nsig))) call create_grd23d_(grd3d,nc2d+nc3d*grd%nsig) + + iret=0 do n=1,n_ens + ii=0 do k=1,nc2d+nc3d*nsig - jj=0 do j=jbsm,jbem - jj=jj+1 - ii=0 do i=ibsm,ibem ii=ii+1 - en_loc3(ii,jj,k)=en_loc(i,j,k,n) + sloc(ii)=en_loc(i,j,k,n) enddo enddo enddo - call move2bundle_(grd3d,en_loc3,atm_bundle(n),m_cvars2d,m_cvars3d,iret) + call move2bundle_(grd3d,sloc,atm_bundle(n),m_cvars2d,m_cvars3d,iret) enddo + deallocate(en_loc,sloc) call general_sub2grid_destroy_info(grd3d,grd) - deallocate(en_loc,en_loc3) - end subroutine get_user_ens_gfs_fastread_ -subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) +subroutine move2bundle_(grd3d,sloc,atm_bundle,m_cvars2d,m_cvars3d,iret) !$$$ subprogram documentation block ! . . . . @@ -347,7 +357,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! ! input argument list: ! grd - grd info for ensemble -! en_loc3 - ensemble member +! sloc - ensemble member ! atm_bundle - empty atm bundle ! m_cvars2d - maps 3rd index in en_loc3 for start of each 2d variable ! m_cvars3d - maps 3rd index in en_loc3 for start of each 3d variable @@ -361,13 +371,11 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one,two,fv use general_sub2grid_mod, only: sub2grid_info use hybrid_ensemble_parameters, only: en_perts use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer - use gsi_bundlemod, only : assignment(=) use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use mpeu_util, only: getindex @@ -375,10 +383,10 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) ! Declare passed variables type(sub2grid_info), intent(in ) :: grd3d - real(r_kind), intent(inout) :: en_loc3(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig) type(gsi_bundle), intent(inout) :: atm_bundle + real(r_kind), intent(inout) :: sloc(grd3d%lat2*grd3d%lon2*(nc2d+nc3d*grd3d%nsig)) integer(i_kind), intent(in ) :: m_cvars2d(nc2d),m_cvars3d(nc3d) - integer(i_kind), intent( out) :: iret + integer(i_kind), intent(inout) :: iret ! Declare internal variables character(len=*),parameter :: myname_='move2bundle_' @@ -389,13 +397,14 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) integer(i_kind) :: icw,iql,iqi,iqr,iqs,iqg real(r_kind),pointer,dimension(:,:) :: ps !real(r_kind),pointer,dimension(:,:) :: sst + real(r_kind),dimension(grd3d%lat2,grd3d%lon2,nc2d+nc3d*grd3d%nsig)::en_loc3 real(r_kind),pointer,dimension(:,:,:) :: u,v,tv,q,oz,cwmr real(r_kind),pointer,dimension(:,:,:) :: qlmr,qimr,qrmr,qsmr,qgmr real(r_kind),parameter :: r0_001 = 0.001_r_kind !--- now update halo values of all variables using general_sub2grid - call update_halos_(grd3d,en_loc3) + call update_halos_(grd3d,sloc,en_loc3) ! Check hydrometeors in control variables icw=getindex(cvars3d,'cw') @@ -405,12 +414,16 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) iqs=getindex(cvars3d,'qs') iqg=getindex(cvars3d,'qg') -! initialize atm_bundle to zero +! atm_bundle to zero done earlier - atm_bundle=zero + call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = iret+ierr + !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = iret+ierr + do m=1,nc2d +! convert ps from Pa to cb + if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) +! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now + enddo - call gsi_bundlegetpointer(atm_bundle,'ps',ps, ierr); iret = ierr - !call gsi_bundlegetpointer(atm_bundle,'sst',sst, ierr); iret = ierr call gsi_bundlegetpointer(atm_bundle,'sf',u , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'vp',v , ierr); iret = ierr + iret call gsi_bundlegetpointer(atm_bundle,'t' ,tv, ierr); iret = ierr + iret @@ -425,7 +438,7 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) if ( iret /= 0 ) then if ( mype == 0 ) then write(6,'(A)') trim(myname_) // ': ERROR!' - write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz,cw' + write(6,'(A)') trim(myname_) // ': For now, GFS requires all MetFields: ps,u,v,(sf,vp)tv,q,oz' write(6,'(A)') trim(myname_) // ': but some have not been found. Aborting ... ' write(6,'(A)') trim(myname_) // ': WARNING!' write(6,'(3A,I5)') trim(myname_) // ': Trouble reading ensemble file : ', trim(filename), ', IRET = ', iret @@ -433,13 +446,6 @@ subroutine move2bundle_(grd3d,en_loc3,atm_bundle,m_cvars2d,m_cvars3d,iret) return endif - - do m=1,nc2d -! convert ps from Pa to cb - if(trim(cvars2d(m))=='ps') ps=r0_001*en_loc3(:,:,m_cvars2d(m)) -! if(trim(cvars2d(m))=='sst') sst=en_loc3(:,:,m_cvars2d(m)) !no sst for now - enddo - km1 = en_perts(1,1,1)%grid%km - 1 !$omp parallel do schedule(dynamic,1) private(m) do m=1,nc3d @@ -477,7 +483,6 @@ end subroutine move2bundle_ subroutine create_grd23d_(grd23d,nvert) - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info use hybrid_ensemble_parameters, only: grd_ens @@ -498,21 +503,20 @@ subroutine create_grd23d_(grd23d,nvert) end subroutine create_grd23d_ -subroutine update_halos_(grd,s) +subroutine update_halos_(grd,sloc,s) - use kinds, only: i_kind,r_kind use general_sub2grid_mod, only: sub2grid_info,general_sub2grid,general_grid2sub implicit none ! Declare passed variables type(sub2grid_info), intent(in ) :: grd - real(r_kind), intent(inout) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent( out) :: s(grd%lat2,grd%lon2,grd%num_fields) + real(r_kind), intent(inout) :: sloc(grd%lat2*grd%lon2*grd%num_fields) ! Declare local variables - integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_loc,kend_alloc + integer(i_kind) inner_vars,lat2,lon2,nlat,nlon,nvert,kbegin_loc,kend_alloc integer(i_kind) ii,i,j,k - real(r_kind),allocatable,dimension(:) :: sloc real(r_kind),allocatable,dimension(:,:,:,:) :: work lat2=grd%lat2 @@ -522,22 +526,16 @@ subroutine update_halos_(grd,s) nvert=grd%num_fields inner_vars=grd%inner_vars kbegin_loc=grd%kbegin_loc - kend_loc=grd%kend_loc kend_alloc=grd%kend_alloc - allocate(sloc(lat2*lon2*nvert)) + + + allocate(work(inner_vars,nlat,nlon,kbegin_loc:kend_alloc)) - ii=0 - do k=1,nvert - do j=1,lon2 - do i=1,lat2 - ii=ii+1 - sloc(ii)=s(i,j,k) - enddo - enddo - enddo call general_sub2grid(grd,sloc,work) call general_grid2sub(grd,work,sloc) + deallocate(work) + ii=0 do k=1,nvert do j=1,lon2 @@ -548,33 +546,30 @@ subroutine update_halos_(grd,s) enddo enddo - deallocate(sloc,work) - end subroutine update_halos_ -subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens) +subroutine ens_io_partition_(n_ens,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,io_pe0,i_ens) ! do computation on all processors, then assign final local processor ! values. - use kinds, only: r_kind,i_kind use constants, only: half implicit none ! Declare passed variables - integer(i_kind),intent(in ) :: n_ens,ntindex + integer(i_kind),intent(in ) :: n_ens integer(i_kind),intent( out) :: io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em,i_ens + integer(i_kind),intent( out) :: io_pe0(n_ens) ! Declare local variables - integer(i_kind) :: io_pe0(n_ens) integer(i_kind) :: iskip,jskip,nextra,ipe,n integer(i_kind) :: nsig i_ens=-1 nsig=1 iskip=npe/n_ens - nextra=npe-iskip*n_ens + nextra=npe-iskip*(n_ens-1)-1 jskip=iskip io_pe=-1 io_pe0=-1 @@ -589,13 +584,12 @@ subroutine ens_io_partition_(n_ens,ntindex,io_pe,n_io_pe_s,n_io_pe_e,n_io_pe_em, else jskip=iskip endif + if(ipe > npe) then + write(6,*)' ens_io_partition_: ***ERROR*** ',ipe,jskip,' processor error: PROGRAM STOPS' + call stop2(999) + end if ipe=ipe+jskip enddo - if(mype==0)then - do n=1,n_ens - write(6,'(3(a,1x,i5,1x))') 'reading ensemble member', n,' time level',ntindex,'on pe', io_pe0(n) - enddo - end if do n=1,n_ens if(mype==io_pe0(n)) then @@ -614,7 +608,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi iasm,iaemz,jasm,jaemz,kasm,kaemz,masm,maemz, & filename,init_head,filenamesfc) - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use nemsio_module, only: nemsio_init,nemsio_open,nemsio_close use ncepnems_io, only: error_msg,imp_physics @@ -641,7 +634,6 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi ! Declare local variables integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,latb2,lonb2 integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg integer(i_kind) iret integer(i_kind) :: istop = 101 integer(i_kind),dimension(7):: idate @@ -726,23 +718,40 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi allocate(work(nlon*(nlat-2))) if (imp_physics == 11) allocate(work2(nlon*(nlat-2))) allocate(temp3(nlat,nlon,nsig,nc3d)) - allocate(temp2(nlat,nlon,nc2d)) + temp3=zero k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if(cvars3d(k3)=='sf') k3u=k3 - if(cvars3d(k3)=='vp') k3v=k3 - if(cvars3d(k3)=='t') k3t=k3 - if(cvars3d(k3)=='q') k3q=k3 - if(cvars3d(k3)=='cw') k3cw=k3 - if(cvars3d(k3)=='oz') k3oz=k3 - if(cvars3d(k3)=='ql') k3ql=k3 - if(cvars3d(k3)=='qi') k3qi=k3 - if(cvars3d(k3)=='qr') k3qr=k3 - if(cvars3d(k3)=='qs') k3qs=k3 - if(cvars3d(k3)=='qg') k3qg=k3 do k=1,nsig - if(trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='sf') then + k3u=k3 + call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='vp') then + k3v=k3 + call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='q') then + k3q=k3 + call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) + if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) + call move1_(work,temp3(:,:,k,k3),nlon,nlat) + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + elseif(trim(cvars3d(k3))=='cw') then + k3cw=k3 call nemsio_readrecv(gfile,'clwmr','mid layer',k,work,iret=iret) if (iret /= 0) call error_msg(trim(myname_),trim(filename),'clwmr','read',istop+6,iret,.true.) if (imp_physics == 11) then @@ -789,30 +798,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (iret /= 0) call error_msg(trim(myname_),trim(filename),'grle','read',istop+12,iret) call move1_(work,temp3(:,:,k,k3),nlon,nlat) call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='oz') then - call nemsio_readrecv(gfile,'o3mr','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'o3mr','read',istop+5,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='q') then - call nemsio_readrecv(gfile,'spfh','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),trim(cvars3d(k3)),'read',istop+4,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='t') then - call nemsio_readrecv(gfile,'tmp','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'tmp','read',istop+3,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='sf') then - call nemsio_readrecv(gfile,'ugrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'ugrd','read',istop+1,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - elseif(trim(cvars3d(k3))=='vp') then - call nemsio_readrecv(gfile,'vgrd','mid layer',k,work,iret=iret) - if (iret /= 0) call error_msg(trim(myname_),trim(filename),'vgrd','read',istop+2,iret,.true.) - call move1_(work,temp3(:,:,k,k3),nlon,nlat) - endif + end if enddo enddo do k=1,nsig @@ -822,10 +808,29 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +! move temp3 to en_full + kf=0 + do k3=1,nc3d + m_cvars3d(k3)=kf+1 + do k=1,nsig + kf=kf+1 + jj=jas-1 + do j=1,nlon + jj=jj+1 + ii=ias-1 + do i=1,nlat + ii=ii+1 + en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) + enddo + enddo + enddo + enddo + deallocate(temp3) ! convert T to Tv: postpone this calculation ! temp3(:,:,:,k3t)=temp3(:,:,:,k3t)*(one+fv*temp3(:,:,:,k3q)) + allocate(temp2(nlat,nlon,nc2d)) temp2=zero do k2=1,nc2d !if(trim(cvars2d(k2))=='sst') then @@ -844,24 +849,7 @@ subroutine parallel_read_nemsio_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsi deallocate(work) if (imp_physics == 11) deallocate(work2) -! move temp2,temp3 to en_full - kf=0 - do k3=1,nc3d - m_cvars3d(k3)=kf+1 - do k=1,nsig - kf=kf+1 - jj=jas-1 - do j=1,nlon - jj=jj+1 - ii=ias-1 - do i=1,nlat - ii=ii+1 - en_full(ii,jj,kf,mas)=temp3(i,j,k,k3) - enddo - enddo - enddo - enddo - deallocate(temp3) +! move temp2 to en_full do k2=1,nc2d m_cvars2d(k2)=kf+1 kf=kf+1 @@ -894,7 +882,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: r60,r3600,zero,one,half,deg2rad use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use general_sub2grid_mod, only: sub2grid_info @@ -917,7 +904,6 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig logical :: file_exist integer(i_kind) i,ii,j,jj,k,lonb,latb,levs,kr,ierror integer(i_kind) k2,k3,k3u,k3v,k3t,k3q,k3cw,k3oz,kf - integer(i_kind) k3ql,k3qi,k3qr,k3qs,k3qg character(len=120) :: myname_ = 'parallel_read_gfsnc_state_' real(r_single),allocatable,dimension(:,:,:) :: rwork3d1, rwork3d2 real(r_single),allocatable,dimension(:,:) :: temp2,rwork2d @@ -968,9 +954,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig allocate(rwork3d1(nlon,(nlat-2),nsig)) allocate(temp3(nlat,nlon,nsig,nc3d)) k3u=0 ; k3v=0 ; k3t=0 ; k3q=0 ; k3cw=0 ; k3oz=0 - k3ql=0; k3qi=0; k3qr=0; k3qs=0; k3qg=0 do k3=1,nc3d - if (trim(cvars3d(k3))=='cw') then + if(trim(cvars3d(k3))=='t') then + k3t=k3 + call read_vardata(atmges, 'tmp', rwork3d1) + else if(trim(cvars3d(k3))=='sf') then + k3u=k3 + call read_vardata(atmges, 'ugrd', rwork3d1) + else if(trim(cvars3d(k3))=='vp') then + k3v=k3 + call read_vardata(atmges, 'vgrd', rwork3d1) + else if(trim(cvars3d(k3))=='q') then + k3q=k3 + call read_vardata(atmges, 'spfh', rwork3d1) + else if (trim(cvars3d(k3))=='cw') then k3cw=k3 call read_vardata(atmges, 'clwmr', rwork3d1) allocate(rwork3d2(nlon,(nlat-2),nsig)) @@ -978,90 +975,25 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig call read_vardata(atmges, 'icmr', rwork3d2) rwork3d1 = rwork3d1 + rwork3d2 deallocate(rwork3d2) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do + else if(trim(cvars3d(k3))=='oz') then + k3oz=k3 + call read_vardata(atmges, 'o3mr', rwork3d1) else if(trim(cvars3d(k3))=='ql') then - k3ql=k3 call read_vardata(atmges, 'clwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qi') then - k3qi=k3 call read_vardata(atmges, 'icmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qr') then - k3qr=k3 call read_vardata(atmges, 'rwmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qs') then - k3qs=k3 call read_vardata(atmges, 'snmr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do else if(trim(cvars3d(k3))=='qg') then - k3qg=k3 call read_vardata(atmges, 'grle', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='oz') then - k3oz=k3 - call read_vardata(atmges, 'o3mr', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='q') then - k3q=k3 - call read_vardata(atmges, 'spfh', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='t') then - k3t=k3 - call read_vardata(atmges, 'tmp', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='sf') then - k3u=k3 - call read_vardata(atmges, 'ugrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do - else if(trim(cvars3d(k3))=='vp') then - k3v=k3 - call read_vardata(atmges, 'vgrd', rwork3d1) - do k=1,nsig - kr = levs+1-k - call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) - end do end if +!$omp parallel do schedule(dynamic,1) private(k,kr) + do k=1,nsig + kr = levs+1-k + call move1_(rwork3d1(:,:,kr),temp3(:,:,k,k3),nlon,nlat) + end do enddo deallocate(rwork3d1) @@ -1069,13 +1001,20 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig if (k3u==0.or.k3v==0.or.k3t==0.or.k3q==0.or.k3oz==0) & write(6,'(" WARNING, problem with one of k3-")') +!$omp parallel do schedule(dynamic,1) private(k,k3) do k=1,nsig call fillpoles_sv_(temp3(:,:,k,k3u),temp3(:,:,k,k3v),nlon,nlat,clons,slons) end do -! move temp2,temp3 to en_full - kf=0 +! move temp3 to en_full +!$omp parallel do schedule(dynamic,1) private(k3,k,kf,j,jj,i,ii) do k3=1,nc3d + if(k3 /= k3u .and. k3 /= k3v)then + do k=1,nsig + call fillpoles_ss_(temp3(:,:,k,k3),nlon,nlat) + end do + end if + kf=(k3-1)*nsig m_cvars3d(k3)=kf+1 do k=1,nsig kf=kf+1 @@ -1094,6 +1033,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig deallocate(temp3) allocate(temp2(nlat,nlon)) allocate(rwork2d(nlon,(nlat-2))) + kf=nc3d*nsig do k2=1,nc2d if(trim(cvars2d(k2))=='ps') then call read_vardata(atmges, 'pressfc', rwork2d) @@ -1103,6 +1043,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig temp2=zero endif +! move temp2 to en_full kf=kf+1 m_cvars2d(k2)=kf jj=jas-1 @@ -1115,6 +1056,7 @@ subroutine parallel_read_gfsnc_state_(en_full,m_cvars2d,m_cvars3d,nlon,nlat,nsig enddo enddo enddo +! call close_dataset(atmges) deallocate(rwork2d) deallocate(temp2) @@ -1147,7 +1089,6 @@ subroutine fillpoles_ss_(temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero,one implicit none @@ -1157,6 +1098,7 @@ subroutine fillpoles_ss_(temp,nlon,nlat) integer(i_kind) nlatm1,i real(r_kind) sumn,sums,rnlon + real(r_single) sumn_sing,sums_sing ! Compute mean along southern and northern latitudes sumn=zero @@ -1167,13 +1109,13 @@ subroutine fillpoles_ss_(temp,nlon,nlat) sums=sums+temp(2,i) end do rnlon=one/float(nlon) - sumn=sumn*rnlon - sums=sums*rnlon + sumn_sing=sumn*rnlon + sums_sing=sums*rnlon ! Load means into local work array do i=1,nlon - temp(1,i) =sums - temp(nlat,i)=sumn + temp(1,i) =sums_sing + temp(nlat,i)=sumn_sing end do end subroutine fillpoles_ss_ @@ -1205,13 +1147,12 @@ subroutine fillpoles_sv_(tempu,tempv,nlon,nlat,clons,slons) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none integer(i_kind),intent(in ) :: nlon,nlat - real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) + real(r_single), intent(inout) :: tempu(nlat,nlon),tempv(nlat,nlon) real(r_kind), intent(in ) :: clons(nlon),slons(nlon) integer(i_kind) i @@ -1266,7 +1207,6 @@ subroutine move1_(work,temp,nlon,nlat) ! !$$$ - use kinds, only: i_kind,r_kind,r_single use constants, only: zero implicit none @@ -1316,7 +1256,6 @@ subroutine get_gfs_ens(this,grd,member,ntindex,atm_bundle,iret) ! !$$$ - use kinds, only: i_kind,r_kind use gridmod, only: use_gfs_nemsio, use_gfs_ncio use general_sub2grid_mod, only: sub2grid_info use gsi_4dvar, only: ens_fhrlevs @@ -1420,7 +1359,6 @@ subroutine put_gfs_ens(this,grd,member,ntindex,pert,iret) ! !$$$ - use kinds, only: i_kind use general_sub2grid_mod, only: sub2grid_info use gsi_bundlemod, only: gsi_bundle use gsi_4dvar, only: ens_fhrlevs @@ -1483,7 +1421,6 @@ end subroutine put_gfs_ens subroutine non_gaussian_ens_grid_gfs(this,elats,elons) - use kinds, only: r_kind use hybrid_ensemble_parameters, only: sp_ens implicit none @@ -1515,7 +1452,6 @@ end subroutine non_gaussian_ens_grid_gfs subroutine create_sub2grid_info(s2gi,nsig,npe,s2gi_ref) !> Create temporary communication information object for read ensemble routines - use kinds, only: i_kind use gridmod, only: regional use general_sub2grid_mod, only: sub2grid_info use general_sub2grid_mod, only: general_sub2grid_create_info diff --git a/src/gsi/cplr_gfs_nstmod.f90 b/src/gsi/cplr_gfs_nstmod.f90 index b482085aa..220fa55af 100644 --- a/src/gsi/cplr_gfs_nstmod.f90 +++ b/src/gsi/cplr_gfs_nstmod.f90 @@ -139,15 +139,15 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) integer(i_kind):: itnst,itnstp integer(i_kind):: ix,iy,ixp,iyp,j real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11,dtnst,dtnstp - real(r_kind):: tref_00,tref_01,tref_10,tref_11,tr_tmp - real(r_kind):: dt_cool_00,dt_cool_01,dt_cool_10,dt_cool_11 - real(r_kind):: z_c_00,z_c_01,z_c_10,z_c_11 - real(r_kind):: dt_warm_00,dt_warm_01,dt_warm_10,dt_warm_11 - real(r_kind):: z_w_00,z_w_01,z_w_10,z_w_11,z_w_tmp - real(r_kind):: c_0_00,c_0_01,c_0_10,c_0_11 - real(r_kind):: c_d_00,c_d_01,c_d_10,c_d_11 - real(r_kind):: w_0_00,w_0_01,w_0_10,w_0_11 - real(r_kind):: w_d_00,w_d_01,w_d_10,w_d_11 + real(r_kind):: tref_tt,tref2 + real(r_kind):: dt_cool_tt + real(r_kind):: z_c_tt + real(r_kind):: dt_warm_tt + real(r_kind):: z_w_tt + real(r_kind):: c_0_tt + real(r_kind):: c_d_tt + real(r_kind):: w_0_tt + real(r_kind):: w_d_tt real(r_kind):: wgtavg,dlat,dlon logical outside @@ -199,138 +199,137 @@ subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr) ! ! Use the time interpolation factors for nst files ! - tref_00 = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp - tref_01 = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp - tref_10 = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp - tref_11 = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp - - dt_cool_00 = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp - dt_cool_01 = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp - dt_cool_10 = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp - dt_cool_11 = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp - - z_c_00 = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp - z_c_01 = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp - z_c_10 = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp - z_c_11 = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp - - dt_warm_00 = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp - dt_warm_01 = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp - dt_warm_10 = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp - dt_warm_11 = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp - - z_w_00 = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp - z_w_01 = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp - z_w_10 = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp - z_w_11 = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp - - c_0_00 = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp - c_0_01 = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp - c_0_10 = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp - c_0_11 = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp - - c_d_00 = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp - c_d_01 = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp - c_d_10 = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp - c_d_11 = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp - - w_0_00 = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp - w_0_01 = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp - w_0_10 = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp - w_0_11 = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp - - w_d_00 = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp - w_d_01 = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp - w_d_10 = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp - w_d_11 = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp ! Interpolate nst variables to obs location (water surface only) wgtavg = zero - tr_tmp = zero + tref2 = zero dt_cool = zero - z_c = zero dt_warm = zero - z_w_tmp = zero + z_c = zero + z_w = zero c_0 = zero c_d = zero w_0 = zero w_d = zero + tz_tr = one + dtw = zero + dtc = zero if (istyp00 == 0)then + tref_tt = tref_full (ix ,iy ,itnst)*dtnst + tref_full (ix ,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iy ,itnst)*dtnst + z_c_full (ix ,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iy ,itnst)*dtnst + z_w_full (ix ,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iy ,itnst)*dtnst + c_0_full (ix ,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iy ,itnst)*dtnst + c_d_full (ix ,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iy ,itnst)*dtnst + w_0_full (ix ,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iy ,itnst)*dtnst + w_d_full (ix ,iy ,itnstp)*dtnstp wgtavg = wgtavg + w00 - tr_tmp = tr_tmp + w00*tref_00 - dt_cool = dt_cool + w00*dt_cool_00 - z_c = z_c + w00*z_c_00 - dt_warm = dt_warm + w00*dt_warm_00 - z_w_tmp = z_w_tmp + w00*z_w_00 - c_0 = c_0 + w00*c_0_00 - c_d = c_d + w00*c_d_00 - w_0 = w_0 + w00*w_0_00 - w_d = w_d + w00*w_d_00 + tref2 = tref2 + w00*tref_tt + dt_cool = dt_cool + w00*dt_cool_tt + dt_warm = dt_warm + w00*dt_warm_tt + z_c = z_c + w00*z_c_tt + z_w = z_w + w00*z_w_tt + c_0 = c_0 + w00*c_0_tt + c_d = c_d + w00*c_d_tt + w_0 = w_0 + w00*w_0_tt + w_d = w_d + w00*w_d_tt endif if(istyp01 == 0)then + tref_tt = tref_full (ix ,iyp,itnst)*dtnst + tref_full (ix ,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ix ,iyp,itnst)*dtnst + z_c_full (ix ,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ix ,iyp,itnst)*dtnst + z_w_full (ix ,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ix ,iyp,itnst)*dtnst + c_0_full (ix ,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ix ,iyp,itnst)*dtnst + c_d_full (ix ,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ix ,iyp,itnst)*dtnst + w_0_full (ix ,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ix ,iyp,itnst)*dtnst + w_d_full (ix ,iyp,itnstp)*dtnstp wgtavg = wgtavg + w01 - tr_tmp = tr_tmp + w01*tref_01 - dt_cool = dt_cool + w01*dt_cool_01 - z_c = z_c + w01*z_c_01 - dt_warm = dt_warm + w01*dt_warm_01 - z_w_tmp = z_w_tmp + w01*z_w_01 - c_0 = c_0 + w01*c_0_01 - c_d = c_d + w01*c_d_01 - w_0 = w_0 + w01*w_0_01 - w_d = w_d + w01*w_d_01 + tref2 = tref2 + w01*tref_tt + dt_cool = dt_cool + w01*dt_cool_tt + dt_warm = dt_warm + w01*dt_warm_tt + z_c = z_c + w01*z_c_tt + z_w = z_w + w01*z_w_tt + c_0 = c_0 + w01*c_0_tt + c_d = c_d + w01*c_d_tt + w_0 = w_0 + w01*w_0_tt + w_d = w_d + w01*w_d_tt end if if(istyp10 == 0)then + tref_tt = tref_full (ixp,iy ,itnst)*dtnst + tref_full (ixp,iy ,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iy ,itnst)*dtnst + z_c_full (ixp,iy ,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iy ,itnst)*dtnst + z_w_full (ixp,iy ,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iy ,itnst)*dtnst + c_0_full (ixp,iy ,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iy ,itnst)*dtnst + c_d_full (ixp,iy ,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iy ,itnst)*dtnst + w_0_full (ixp,iy ,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iy ,itnst)*dtnst + w_d_full (ixp,iy ,itnstp)*dtnstp wgtavg = wgtavg + w10 - tr_tmp = tr_tmp + w10*tref_10 - dt_cool = dt_cool + w10*dt_cool_10 - z_c = z_c + w10*z_c_10 - dt_warm = dt_warm + w10*dt_warm_10 - z_w_tmp = z_w_tmp + w10*z_w_10 - c_0 = c_0 + w10*c_0_10 - c_d = c_d + w10*c_d_10 - w_0 = w_0 + w10*w_0_10 - w_d = w_d + w10*w_d_10 + tref2 = tref2 + w10*tref_tt + dt_cool = dt_cool + w10*dt_cool_tt + dt_warm = dt_warm + w10*dt_warm_tt + z_c = z_c + w10*z_c_tt + z_w = z_w + w10*z_w_tt + c_0 = c_0 + w10*c_0_tt + c_d = c_d + w10*c_d_tt + w_0 = w_0 + w10*w_0_tt + w_d = w_d + w10*w_d_tt end if if(istyp11 == 0)then + tref_tt = tref_full (ixp,iyp,itnst)*dtnst + tref_full (ixp,iyp,itnstp)*dtnstp + dt_cool_tt = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp + dt_warm_tt = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp + z_c_tt = z_c_full (ixp,iyp,itnst)*dtnst + z_c_full (ixp,iyp,itnstp)*dtnstp + z_w_tt = z_w_full (ixp,iyp,itnst)*dtnst + z_w_full (ixp,iyp,itnstp)*dtnstp + c_0_tt = c_0_full (ixp,iyp,itnst)*dtnst + c_0_full (ixp,iyp,itnstp)*dtnstp + c_d_tt = c_d_full (ixp,iyp,itnst)*dtnst + c_d_full (ixp,iyp,itnstp)*dtnstp + w_0_tt = w_0_full (ixp,iyp,itnst)*dtnst + w_0_full (ixp,iyp,itnstp)*dtnstp + w_d_tt = w_d_full (ixp,iyp,itnst)*dtnst + w_d_full (ixp,iyp,itnstp)*dtnstp wgtavg = wgtavg + w11 - tr_tmp = tr_tmp + w11*tref_11 - dt_cool = dt_cool + w11*dt_cool_11 - z_c = z_c + w11*z_c_11 - dt_warm = dt_warm + w11*dt_warm_11 - z_w_tmp = z_w_tmp + w11*z_w_11 - c_0 = c_0 + w11*c_0_11 - c_d = c_d + w11*c_d_11 - w_0 = w_0 + w11*w_0_11 - w_d = w_d + w11*w_d_11 + tref2 = tref2 + w11*tref_tt + dt_cool = dt_cool + w11*dt_cool_tt + dt_warm = dt_warm + w11*dt_warm_tt + z_c = z_c + w11*z_c_tt + z_w = z_w + w11*z_w_tt + c_0 = c_0 + w11*c_0_tt + c_d = c_d + w11*c_d_tt + w_0 = w_0 + w11*w_0_tt + w_d = w_d + w11*w_d_tt end if + if(wgtavg < 1.e-6)return - if(wgtavg > zero)then - tr_tmp = tr_tmp/wgtavg - tref = tr_tmp - - z_w_tmp = z_w_tmp/wgtavg - z_w = z_w_tmp + tref = tref2/wgtavg + z_w = z_w/wgtavg + z_c = z_c/wgtavg - dt_cool = dt_cool/wgtavg - z_c = z_c/wgtavg - dt_warm = dt_warm/wgtavg + if(fac_tsl == 1)then c_0 = c_0/wgtavg c_d = c_d/wgtavg + dt_cool = dt_cool/wgtavg + if(z_c > zero)dtc = dt_cool*(one-min(zob,z_c)/z_c) + else + c_0 = zero + c_d = zero + dt_cool = zero + end if + if(fac_dtl == 1)then w_0 = w_0/wgtavg w_d = w_d/wgtavg + dt_warm = dt_warm/wgtavg + if(z_w > zero)dtw = dt_warm*(one-min(zob,z_w)/z_w) + else + w_0 = zero + w_d = zero + dt_warm = zero + end if - dtw = fac_dtl*dt_warm*(one-min(zob,z_w)/z_w) - if ( z_c > zero ) then - dtc = fac_tsl*dt_cool*(one-min(zob,z_c)/z_c) - else - dtc = zero - endif - call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) + call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr) - end if end subroutine deter_nst_ !******************************************************************************************* @@ -343,10 +342,10 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) ! ! dt_warm : diurnal warming amount at the surface ! xz : DTL depth (M) -! c_0 : coefficint 1 to calculate d(Tc)/d(Ts) -! c_d : coefficint 2 to calculate d(Tc)/d(Ts) -! w_0 : coefficint 1 to calculate d(Tw)/d(Ts) -! w_d : coefficint 2 to calculate d(Tw)/d(Ts) +! c_0 : coefficient 1 to calculate d(Tc)/d(Ts) +! c_d : coefficient 2 to calculate d(Tc)/d(Ts) +! w_0 : coefficient 1 to calculate d(Tw)/d(Ts) +! w_d : coefficient 2 to calculate d(Tw)/d(Ts) ! ! output variables ! @@ -354,34 +353,39 @@ subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr) use kinds, only: r_kind use constants, only: one,two,half,zero - use gsi_nstcouplermod, only: fac_dtl,fac_tsl real(kind=r_kind), intent(in) :: dt_warm,c_0,c_d,w_0,w_d,zc,zw,z real(kind=r_kind), intent(out) :: tztr ! local variables - real(kind=r_kind) :: c1,c2,c3 + real(kind=r_kind) :: c1,c2,c3,fact - c1 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-(fac_dtl*w_d-fac_tsl*c_d)*z - c2 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-fac_dtl*w_d*z - c3 = one+fac_tsl*two*c_0+fac_dtl*c_d*z tztr = one + c1 = zero + c2 = zero + c3 = zero if ( dt_warm > zero ) then - if ( z <= zc .and. c1 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c1 - elseif ( z > zc .and. z < zw .and. c2 /= zero ) then - tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c2 + fact = (one-w_0+c_0) + if ( z <= zc) then + c1 = one-two*(w_0-c_0)-(w_d-c_d)*z + if ( c1 /= zero ) tztr = fact/c1 + elseif ( z > zc .and. z < zw) then + c2 = one-two*(w_0-c_0)-w_d*z + if (c2 /= zero ) tztr = fact/c2 + else endif - elseif ( dt_warm == zero .and. c3 /= zero ) then - if ( z <= zc ) then - tztr = (one+fac_tsl*c_0)/c3 + elseif (dt_warm == zero) then + if ( z <= zc) then + c3 = one+two*c_0+c_d*z + if (c3 /= zero) tztr = (one+c_0)/c3 endif endif - if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then - write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr -100 format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0') - tztr = one + if ( tztr < 0.5_r_kind .or. tztr > 1.5_r_kind ) then + write(6,100) c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr +100 format('CAL_TZTR compute ',12(g13.6,1x),' RESET tztr to 0.5 .or. 1.5') + tztr = min(1.5_r_kind,tztr) + tztr = max(0.5_r_kind,tztr) endif end subroutine cal_tztr_ diff --git a/src/gsi/cwhydromod.f90 b/src/gsi/cwhydromod.f90 index a27bba545..d2bde7812 100644 --- a/src/gsi/cwhydromod.f90 +++ b/src/gsi/cwhydromod.f90 @@ -100,14 +100,23 @@ subroutine cw2hydro(sval,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*(one-work(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 + sv_rank3(i,j,k)=cwgues(i,j,k)*work(i,j,k) + end do + end do + end do + end if end do return @@ -174,16 +183,25 @@ subroutine cw2hydro_tl(sval,wbundle,clouds,nclouds) call gsi_bundlegetpointer (sval,clouds(ic),sv_rank3,istatus) if (istatus/=0) cycle sv_rank3=zero - do k=1,nsig - do j=1,lon2 - do i=1,lat2 -! if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) -! if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) - if (clouds(ic)=='ql') sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) - if (clouds(ic)=='qi') sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k))-cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*(one-work0(i,j,k)) + end do end do end do - end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 +! sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k)+cwgues(i,j,k)*work(i,j,k) + sv_rank3(i,j,k)=cv_cw(i,j,k)*work0(i,j,k) + end do + end do + end do + end if end do return @@ -226,8 +244,6 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) real(r_kind),pointer,dimension(:,:,:) :: cv_cw ! Get pointer to required control variable -call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) -cv_cw=zero do k=1,nsig do j=1,lon2 @@ -239,25 +255,30 @@ subroutine cw2hydro_ad(rval,wbundle,clouds,nclouds) end do end do +call gsi_bundlegetpointer (wbundle,'cw',cv_cw,istatus) do ic=1,nclouds call gsi_bundlegetpointer (rval,clouds(ic),rv_rank3,istatus) if (istatus/=0) cycle - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - if (clouds(ic)=='ql') then + if (clouds(ic)=='ql') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*(one-work0(i,j,k)) rv_rank3(i,j,k)=zero - end if - - if (clouds(ic)=='qi') then + end do + end do + end do + else if (clouds(ic)=='qi') then + do k=1,nsig + do j=1,lon2 + do i=1,lat2 cv_cw(i,j,k)=cv_cw(i,j,k)+rv_rank3(i,j,k)*work0(i,j,k) rv_rank3(i,j,k)=zero - end if - + end do end do end do - end do + end if + end do return diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 3c88aabb2..e4e77283a 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -207,7 +207,6 @@ subroutine deter_sfc(alat,alon,dlat_earth,dlon_earth,obstime,isflg, & sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -517,7 +516,6 @@ subroutine deter_sfc_type(dlat_earth,dlon_earth,obstime,isflg,tsavg) sfcpct(istyp10)=sfcpct(istyp10)+w10 sfcpct(istyp11)=sfcpct(istyp11)+w11 - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1109,7 +1107,7 @@ subroutine deter_sfc_fov(fov_flag,ifov,instr,ichan,sat_aziang,dlat_earth_deg,& do i = min_i(j), max_i(j) call reduce2full(i,j,ifull) call time_int_sfc(ifull,j,itsfc,itsfcp,dtsfc,dtsfcp,sfc_mdl) -!$omp parallel do schedule(dynamic,1)private(jjj,iii,lat_mdl,lon_mdl) +!$omp parallel do schedule(dynamic,1) private(jjj,iii,lat_mdl,lon_mdl) do jjj = 1, subgrid_lengths_y if (y_off(jjj) >= zero) then lat_mdl = (one-y_off(jjj))*rlats_sfc(j)+y_off(jjj)*rlats_sfc(j+1) @@ -1316,7 +1314,6 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1482,7 +1479,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) ! sfcpct(3)=min(sfcpct(3),sfcpct(1)) ! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 else if(sfcpct(1) > 0.99_r_kind)then @@ -1986,7 +1982,6 @@ subroutine calc_sfc(sfc_sum,isflg,idomsfc,sfcpct,vfr,sty,vty,sm, & sfcr = sfc_sum%sfcr/count_tot zz = sfc_sum%zz/count_tot - isflg = 0 if(sfcpct(0) > 0.99_r_kind)then isflg = 0 ! open water else if(sfcpct(1) > 0.99_r_kind)then diff --git a/src/gsi/evaljgrad.f90 b/src/gsi/evaljgrad.f90 index 788454034..e66ca11b8 100644 --- a/src/gsi/evaljgrad.f90 +++ b/src/gsi/evaljgrad.f90 @@ -73,6 +73,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use mpeu_util, only: die use mpl_allreducemod, only: mpl_allreduce +use intradmod, only: setrad implicit none @@ -195,6 +196,7 @@ subroutine evaljgrad(xhat,fjcost,gradx,lupdfgs,nprt,calledby) end do qpred=zero_quad +call setrad(sval(1)) ! Compare obs to solution and transpose back to grid (H^T R^{-1} H) call intjo(rval,qpred,sval,sbias) diff --git a/src/gsi/genqsat.f90 b/src/gsi/genqsat.f90 index ed0eb152e..bc3318749 100644 --- a/src/gsi/genqsat.f90 +++ b/src/gsi/genqsat.f90 @@ -145,9 +145,9 @@ subroutine genqsat(qsat,tsen,prsl,lat2,lon2,nsig,ice,iderivative) esw = psat * (tr**xa) * exp(xb*(one-tr)) esi = psat * (tr**xai) * exp(xbi*(one-tr)) w = (tdry - tmix) / (ttp - tmix) -! es = w * esw + (one-w) * esi - es = w * psat * (tr**xa) * exp(xb*(one-tr)) & - + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) + es = w * esw + (one-w) * esi +! es = w * psat * (tr**xa) * exp(xb*(one-tr)) & +! + (one-w) * psat * (tr**xai) * exp(xbi*(one-tr)) endif diff --git a/src/gsi/get_gefs_ensperts_dualres.f90 b/src/gsi/get_gefs_ensperts_dualres.f90 index 1cb7586a8..fab95ad21 100644 --- a/src/gsi/get_gefs_ensperts_dualres.f90 +++ b/src/gsi/get_gefs_ensperts_dualres.f90 @@ -64,6 +64,7 @@ subroutine get_gefs_ensperts_dualres use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: gsi_bundledestroy use gsi_bundlemod, only: gsi_gridcreate + use gsi_bundlemod, only : assignment(=) use gsi_enscouplermod, only: gsi_enscoupler_get_user_nens use gsi_enscouplermod, only: gsi_enscoupler_create_sub2grid_info use gsi_enscouplermod, only: gsi_enscoupler_destroy_sub2grid_info @@ -150,6 +151,7 @@ subroutine get_gefs_ensperts_dualres call gsi_bundlecreate(en_read(n),en_perts(1,1,1)%grid,'ensemble member',istatus,names2d=cvars2d,names3d=cvars3d) if ( istatus /= 0 ) & call die('get_gefs_ensperts_dualres',': trouble creating en_read bundle, istatus =',istatus) + en_read(n) = zero end do ! allocate(z(im,jm)) @@ -158,14 +160,6 @@ subroutine get_gefs_ensperts_dualres ! sst2=zero ! for now, sst not used in ensemble perturbations, so if sst array is called for ! then sst part of en_perts will be zero when sst2=zero -!$omp parallel do schedule(dynamic,1) private(m,n) - do m=1,ntlevs_ens - do n=1,n_ens - en_perts(n,1,m)%valuesr4=zero_single - end do - end do - - ntlevs_ens_loop: do m=1,ntlevs_ens call gsi_enscoupler_get_user_Nens(grd_tmp,n_ens,m,en_read,iret) @@ -180,28 +174,39 @@ subroutine get_gefs_ensperts_dualres cycle endif + en_bar%values=zero if (.not.q_hyb_ens) then !use RH - kap1=rd_over_cp+one - kapr=one/rd_over_cp - do n=1,n_ens + allocate(pri(im,jm,km+1)) + allocate(prsl(im,jm,km),tsen(im,jm,km)) + allocate(qs(im,jm,km)) + end if + do n=1,n_ens + call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier + do k=1,km + do j=1,jm + do i=1,im + q(i,j,k)=max(q(i,j,k),zero) + end do + end do + end do + if (.not.q_hyb_ens) then !use RH call gsi_bundlegetpointer(en_read(n),'ps',ps,ier);istatus=ier call gsi_bundlegetpointer(en_read(n),'t' ,tv,ier);istatus=istatus+ier - call gsi_bundlegetpointer(en_read(n),'q' ,q ,ier);istatus=istatus+ier ! Compute RH ! Get 3d pressure field now on interfaces - allocate(pri(im,jm,km+1)) call general_getprs_glb(ps,tv,pri) - allocate(prsl(im,jm,km),tsen(im,jm,km),qs(im,jm,km)) ! Get sensible temperature and 3d layer pressure if (idsl5 /= 2) then + kap1=rd_over_cp+one + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i) do k=1,km do j=1,jm do i=1,im prsl(i,j,k)=((pri(i,j,k)**kap1-pri(i,j,k+1)**kap1)/& (kap1*(pri(i,j,k)-pri(i,j,k+1))))**kapr - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do @@ -211,12 +216,11 @@ subroutine get_gefs_ensperts_dualres do j=1,jm do i=1,im prsl(i,j,k)=(pri(i,j,k)+pri(i,j,k+1))*half - tsen(i,j,k)= tv(i,j,k)/(one+fv*max(zero,q(i,j,k))) + tsen(i,j,k)= tv(i,j,k)/(one+fv*q(i,j,k)) end do end do end do end if - deallocate(pri) ice=.true. iderivative=0 @@ -228,14 +232,7 @@ subroutine get_gefs_ensperts_dualres end do end do end do - deallocate(tsen,prsl,qs) - enddo - end if - - - en_bar%values=zero - - n_ens_loop: do n=1,n_ens + end if !$omp parallel do schedule(dynamic,1) private(i,k,j,ic3,hydrometeor,istatus,p3) @@ -246,14 +243,14 @@ subroutine get_gefs_ensperts_dualres trim(cvars3d(ic3))=='qs' .or. trim(cvars3d(ic3))=='qg' .or. & trim(cvars3d(ic3))=='qh' - call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m - call stop2(999) - end if if ( hydrometeor ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if do k=1,km do j=1,jm do i=1,im @@ -263,13 +260,17 @@ subroutine get_gefs_ensperts_dualres end do else if ( trim(cvars3d(ic3)) == 'oz' .and. oz_univ_static ) then + call gsi_bundlegetpointer(en_read(n),trim(cvars3d(ic3)),p3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to ',trim(cvars3d(ic3)),' from read in member ',n,m + call stop2(999) + end if p3 = zero end if end do !c3d do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i) - en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i) + en_bar%values(i)=en_bar%values(i)+en_read(n)%values(i)*bar_norm end do @@ -279,14 +280,14 @@ subroutine get_gefs_ensperts_dualres ! know who would want to commented out code below but be mindful ! of how it interacts with option sst_staticB, please - Todling. - end do n_ens_loop ! end do over ensemble - - do i=1,nelen - en_bar%values(i)=en_bar%values(i)*bar_norm - end do + end do ! end do over ensembles + if (.not.q_hyb_ens) then !use RH + deallocate(pri) + deallocate(tsen,prsl) + deallocate(qs) + end if ! Before converting to perturbations, get ensemble spread - !-- if (m == 1 .and. write_ens_sprd ) call ens_spread_dualres(en_bar,1) !!! it is not clear of the next statement is thread/$omp safe. if (write_ens_sprd ) call ens_spread_dualres(en_bar,m) @@ -297,7 +298,6 @@ subroutine get_gefs_ensperts_dualres ! Copy pbar to module array. ps_bar may be needed for vertical localization ! in terms of scale heights/normalized p/p -! Convert to mean do j=1,jm do i=1,im ps_bar(i,j,m)=x2(i,j) @@ -309,7 +309,7 @@ subroutine get_gefs_ensperts_dualres !$omp parallel do schedule(dynamic,1) private(n,i,ic3,ipic,k,j) do n=1,n_ens do i=1,nelen - en_perts(n,1,m)%valuesr4(i)=en_perts(n,1,m)%valuesr4(i)-en_bar%values(i) + en_perts(n,1,m)%valuesr4(i)=en_read(n)%values(i)-en_bar%values(i) end do if(.not. q_hyb_ens) then do ic3=1,nc3d @@ -332,6 +332,7 @@ subroutine get_gefs_ensperts_dualres end do end do ntlevs_ens_loop !end do over bins + call gsi_bundledestroy(en_bar,istatus) if(nsclgrp > 1 .and. global_spectral_filter_sd) then do m=1,ntlevs_ens do n=1,n_ens @@ -725,8 +726,6 @@ subroutine general_getprs_glb(ps,tv,prs) real(r_kind),parameter:: ten = 10.0_r_kind - kapr=one/rd_over_cp - if (regional) then if(wrf_nmm_regional.or.nems_nmmb_regional) then do k=1,nsig+1 @@ -767,32 +766,45 @@ subroutine general_getprs_glb(ps,tv,prs) end do endif else - k=1 - k2=nsig+1 - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ps(i,j) - prs(i,j,k2)=zero - end do - end do if (idvc5 /= 3) then !$omp parallel do schedule(dynamic,1) private(k,j,i) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ak5(k)+bk5(k)*ps(i,j) + end do + end do + end if end do else + kapr=one/rd_over_cp !$omp parallel do schedule(dynamic,1) private(k,j,i,trk) - do k=2,nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr - prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + do k=1,nsig + if(k == 1)then + k2=nsig+1 + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + prs(i,j,k)=ps(i,j) + prs(i,j,k2)=zero + end do end do - end do + else + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + trk=(half*(tv(i,j,k-1)+tv(i,j,k))/tref5(k))**kapr + prs(i,j,k)=ak5(k)+(bk5(k)*ps(i,j))+(ck5(k)*trk) + end do + end do + end if end do end if end if diff --git a/src/gsi/getsiga.f90 b/src/gsi/getsiga.f90 index 788e0652d..ad47017be 100644 --- a/src/gsi/getsiga.f90 +++ b/src/gsi/getsiga.f90 @@ -198,6 +198,7 @@ subroutine view_cv_ad (xhat,mydate,filename,readcv) use state_vectors, only: allocate_state,deallocate_state,prt_state_norms use bias_predictors, only: predictors,allocate_preds,deallocate_preds,assignment(=) use bias_predictors, only: read_preds +use control2state_mod, only: control2state_ad implicit none type(control_vector) :: xhat integer(i_kind), intent(in) :: mydate(5) ! as in iadate or ibdate, or similar diff --git a/src/gsi/gridmod.F90 b/src/gsi/gridmod.F90 index 928b9e9c4..559a3f576 100644 --- a/src/gsi/gridmod.F90 +++ b/src/gsi/gridmod.F90 @@ -130,6 +130,7 @@ module gridmod public :: vectosub public :: reload public :: strip_periodic + public :: minmype ! set passed variables to public public :: nnnn1o,iglobal,itotsub,ijn,ijn_s,lat2,lon2,lat1,lon1,nsig,nsig_soil @@ -267,6 +268,7 @@ module gridmod integer(i_kind) jcap ! spectral triangular truncation of ncep global analysis integer(i_kind) jcap_b ! spectral triangular truncation of ncep global background integer(i_kind) nthreads ! number of threads used (currently only used in calctends routines) + integer(i_kind) minmype ! processor with minimum size subdomain logical periodic ! logical flag for periodic e/w domains @@ -574,7 +576,7 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) integer(i_kind) n3d,n2d,nvars,tid,nth integer(i_kind) ipsf,ipvp,jpsf,jpvp,isfb,isfe,ivpb,ivpe integer(i_kind) istatus,icw,iql,iqi - integer(i_kind) icw_cv,iql_cv,iqi_cv + integer(i_kind) icw_cv,iql_cv,iqi_cv,minmax logical,allocatable,dimension(:):: vector logical print_verbose @@ -687,6 +689,8 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) periodic=grd_a%periodic + minmype=0 + minmax=grd_a%ilat1(1)*grd_a%jlon1(1) do i=1,npe istart(i) =grd_a%istart(i) jstart(i) =grd_a%jstart(i) @@ -699,7 +703,12 @@ subroutine init_grid_vars(jcap,npe,cvars3d,cvars2d,cvars,mype) displs_s(i) =grd_a%displs_s(i) ijn(i) =grd_a%ijn(i) displs_g(i) =grd_a%displs_g(i) + if(grd_a%ilat1(i)*grd_a%jlon1(i)< minmax)then + minmax=grd_a%ilat1(i)*grd_a%jlon1(i) + minmype=i-1 + end if end do + if(mype == minmype) write(6,*) ' minmype = ',minmype !#omp parallel private(nth,tid) nth = omp_get_max_threads() diff --git a/src/gsi/gsi_files.cmake b/src/gsi/gsi_files.cmake index 1658c83bf..b98cd2d0d 100644 --- a/src/gsi/gsi_files.cmake +++ b/src/gsi/gsi_files.cmake @@ -124,7 +124,6 @@ constants.f90 control2model.f90 control2model_ad.f90 control2state.f90 -control2state_ad.f90 control_vectors.f90 convb_ps.f90 convb_q.f90 diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index c4317dbd2..c8ce5a45b 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -1825,7 +1825,7 @@ subroutine gsimain_initialize n_ens_gfs=n_ens n_ens_fv3sar=0 else - write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' + if(mype == 0)write(6,*)'n_ens_gfs and n_ens_fv3sar won"t be used if not regional_ensemble_option==5' endif weight_ens_gfs=one weight_ens_fv3sar=one diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 7b133ffb5..fe2e058df 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -3592,7 +3592,7 @@ subroutine bkerror_a_en(grady) !$$$ end documentation block use kinds, only: r_kind,i_kind use constants, only: zero - use gsi_4dvar, only: nsubwin, lsqrtb + use gsi_4dvar, only: nsubwin use control_vectors, only: control_vector use timermod, only: timer_ini,timer_fnl use hybrid_ensemble_parameters, only: n_ens @@ -3610,11 +3610,6 @@ subroutine bkerror_a_en(grady) real(r_kind),allocatable,dimension(:,:) :: z real(r_kind),allocatable,dimension(:) :: ztmp - if (lsqrtb) then - write(6,*)'bkerror_a_en: not for use with lsqrtb' - call stop2(317) - end if - ! Initialize timer call timer_ini('bkerror_a_en') @@ -3629,6 +3624,7 @@ subroutine bkerror_a_en(grady) call sqrt_beta_e_mult(grady) ! Apply variances, as well as vertical & horizontal parts of background error +! !$omp parallel do schedule(dynamic,1) private(ii) do ii=1,nsubwin if (naensgrp==1) then call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) @@ -3710,12 +3706,10 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) type(gsi_bundle),intent(inout) :: a_en(n_ens) ! Local Variables - integer(i_kind) ii,k,iflg,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus 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 - iflg=1 - 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' diff --git a/src/gsi/intall.f90 b/src/gsi/intall.f90 index 0f8faa89f..d10eb1e7e 100644 --- a/src/gsi/intall.f90 +++ b/src/gsi/intall.f90 @@ -184,13 +184,13 @@ subroutine intall(sval,sbias,rval,rbias) use intjomod, only: intjo use bias_predictors, only : predictors,assignment(=) use state_vectors, only: allocate_state,deallocate_state + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use intjcmod, only: intlimq,intlimg,intlimv,intlimp,intlimw10m,intlimhowv,intlimcldch,& intliml,intjcpdry1,intjcpdry2,intjcdfi,intlimqc use timermod, only: timer_ini,timer_fnl use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: assignment(=) - use state_vectors, only: svars2d, svars3d - use mpeu_util, only: getindex use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce @@ -238,11 +238,11 @@ subroutine intall(sval,sbias,rval,rbias) end if if (ljclimqc) then if (.not.ljc4tlevs) then - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') + if (qlpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'ql') + if (qipresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qi') + if (qrpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qr') + if (qspresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qs') + if (qgpresent) call intlimqc(rval(ibin_anl),sval(ibin_anl),ntguessig,'qg') else do ibin=1,nobs_bins if (nobs_bins /= nfldsig) then @@ -250,34 +250,34 @@ subroutine intall(sval,sbias,rval,rbias) else it=ibin end if - if (getindex(svars3d,'ql')>0) call intlimqc(rval(ibin),sval(ibin),it,'ql') - if (getindex(svars3d,'qi')>0) call intlimqc(rval(ibin),sval(ibin),it,'qi') - if (getindex(svars3d,'qr')>0) call intlimqc(rval(ibin),sval(ibin),it,'qr') - if (getindex(svars3d,'qs')>0) call intlimqc(rval(ibin),sval(ibin),it,'qs') - if (getindex(svars3d,'qg')>0) call intlimqc(rval(ibin),sval(ibin),it,'qg') + if (qlpresent) call intlimqc(rval(ibin),sval(ibin),it,'ql') + if (qipresent) call intlimqc(rval(ibin),sval(ibin),it,'qi') + if (qrpresent) call intlimqc(rval(ibin),sval(ibin),it,'qr') + if (qspresent) call intlimqc(rval(ibin),sval(ibin),it,'qs') + if (qgpresent) call intlimqc(rval(ibin),sval(ibin),it,'qg') end do end if end if ! ljclimqc ! RHS for gust constraint - if (getindex(svars2d,'gust')>0)call intlimg(rval(1),sval(1)) + if (gustpresent)call intlimg(rval(1),sval(1)) ! RHS for vis constraint - if (getindex(svars2d,'vis')>0) call intlimv(rval(1),sval(1)) + if (vispresent) call intlimv(rval(1),sval(1)) ! RHS for pblh constraint - if (getindex(svars2d,'pblh')>0) call intlimp(rval(1),sval(1)) + if (pblhpresent) call intlimp(rval(1),sval(1)) ! RHS for wspd10m constraint - if (getindex(svars2d,'wspd10m')>0) call intlimw10m(rval(1),sval(1)) + if (wspd10mpresent) call intlimw10m(rval(1),sval(1)) ! RHS for howv constraint - if (getindex(svars2d,'howv')>0) call intlimhowv(rval(1),sval(1)) + if (howvpresent) call intlimhowv(rval(1),sval(1)) ! RHS for lcbas constraint - if (getindex(svars2d,'lcbas')>0) call intliml(rval(1),sval(1)) + if (lcbaspresent) call intliml(rval(1),sval(1)) ! RHS for cldch constraint - if (getindex(svars2d,'cldch')>0) call intlimcldch(rval(1),sval(1)) + if (cldchpresent) call intlimcldch(rval(1),sval(1)) end if @@ -296,7 +296,7 @@ subroutine intall(sval,sbias,rval,rbias) end if -! Take care of background error for bias correction terms +! Sum over all processors for bias correction terms call mpl_allreduce(nrclen,qpvals=qpred) @@ -313,6 +313,7 @@ subroutine intall(sval,sbias,rval,rbias) ! RHS for Jc DFI if (ljcdfi .and. nobs_bins>1) call intjcdfi(rval,sval) +! Put bias correction terms in correct location if(nsclen > 0)then do i=1,nsclen rbias%predr(i)=qpred(i) diff --git a/src/gsi/intgps.f90 b/src/gsi/intgps.f90 index bc78db085..16ead93d1 100644 --- a/src/gsi/intgps.f90 +++ b/src/gsi/intgps.f90 @@ -118,6 +118,7 @@ subroutine intgps_(gpshead,rval,sval) real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: p_TL,p_AD,t_TL,t_AD,q_TL,q_AD real(r_kind) :: val,pg_gps + real(r_kind),dimension(nsig) :: valk real(r_kind) ::cg_gps,grad,p0,wnotgross,wgross real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq @@ -154,16 +155,19 @@ subroutine intgps_(gpshead,rval,sval) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - - val=zero - ! local refractivity (linear operator) +!$omp parallel do schedule(dynamic,1) private(j,t_TL,q_TL,p_TL) + do j=1,nsig + t_TL=w1*st(i1(j))+w2*st(i2(j))+w3*st(i3(j))+w4*st(i4(j)) + q_TL=w1*sq(i1(j))+w2*sq(i2(j))+w3*sq(i3(j))+w4*sq(i4(j)) + p_TL=w1*sp(i1(j))+w2*sp(i2(j))+w3*sp(i3(j))+w4*sp(i4(j)) + valk(j) = p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + end do + + val=zero do j=1,nsig - t_TL=w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - q_TL=w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - p_TL=w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - val = val + p_TL*gpsptr%jac_p(j) + t_TL*gpsptr%jac_t(j)+q_TL*gpsptr%jac_q(j) + val = val+valk(j) end do if (luse_obsdiag)then @@ -204,6 +208,7 @@ subroutine intgps_(gpshead,rval,sval) ! adjoint +!$omp parallel do schedule(dynamic,1) private(j,t_AD,q_AD,p_AD) do j=1,nsig t_AD = grad*gpsptr%jac_t(j) rt(i1(j))=rt(i1(j))+w1*t_AD diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index c0c23151e..2b093312a 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -740,7 +740,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins @@ -805,8 +805,7 @@ subroutine intjcpdry(rval,sval,nbins,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif @@ -872,7 +871,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! !$$$ use mpimod, only: mype - use gridmod, only: lat2,lon2,nsig,wgtlats,nlon,istart + use gridmod, only: lat2,lon2,nsig,wgtlats,istart use guess_grids, only: ges_prsi,ntguessig use gsi_metguess_mod, only: gsi_metguess_get implicit none @@ -884,7 +883,7 @@ subroutine intjcpdry1(sval,nbins,mass) ! Declare local variables real(r_quad),dimension(nsig) :: mass2 - real(r_quad) rcon,con + real(r_quad) con integer(i_kind) i,j,k,it,ii,mm1,icw,iql,iqi integer(i_kind) iq,iqr,iqs,iqg,iqh,ips real(r_kind),pointer,dimension(:,:,:) :: sq =>NULL() @@ -901,13 +900,11 @@ subroutine intjcpdry1(sval,nbins,mass) it=ntguessig mass=zero_quad - rcon=one_quad/(two_quad*float(nlon)) mm1=mype+1 do n=1,nbins ! Retrieve pointers ! Simply return if any pointer not found - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(sval(n),'q' ,sq, iq ) call gsi_bundlegetpointer(sval(n),'cw',sc, icw ) call gsi_bundlegetpointer(sval(n),'ql',sql, iql ) @@ -1023,11 +1020,10 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) integer(i_kind) :: n it=ntguessig - rcon=one_quad/(two_quad*float(nlon)) + rcon=(one_quad/(two_quad*float(nlon)))**2 mm1=mype+1 do n=1,nbins - iq=0; icw=0; iql=0; iqi=0; iqr=0; iqs=0; iqg=0; iqh=0 call gsi_bundlegetpointer(rval(n),'q' ,rq, iq ) call gsi_bundlegetpointer(rval(n),'cw',rc, icw ) call gsi_bundlegetpointer(rval(n),'ql',rql, iql ) @@ -1037,7 +1033,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) call gsi_bundlegetpointer(rval(n),'qg',rqg, iqg ) call gsi_bundlegetpointer(rval(n),'qh',rqh, iqh ) call gsi_bundlegetpointer(rval(n),'ps',rp, ips ) - if( iq*ips /=0 .or. icw*(iql+iqi) /=0 ) then + if( ips /= 0 .or. iq /=0 .or. icw*(iql+iqi) /=0 ) then if (mype==0) write(6,*)'intjcpdry2: warning - missing some required variables' if (mype==0) write(6,*)'intjcpdry2: constraint for dry mass constraint not performed' return @@ -1045,8 +1041,7 @@ subroutine intjcpdry2(rval,nbins,mass,pjc) ! Remove water-vapor contribution to get incremental dry ps ! if (mype==0) write(6,*)'intjcpdry: total mass =', mass(n) ! if (mype==0) write(6,*)'intjcpdry: wv mass =', mass(nbins+n) - dmass=mass(n)-mass(nbins+n) - dmass=bamp_jcpdry*dmass*rcon*rcon + dmass=bamp_jcpdry*(mass(n)-mass(nbins+n))*rcon if(present(pjc)) then pjc = dmass*dmass endif diff --git a/src/gsi/intjo.f90 b/src/gsi/intjo.f90 index e514a38a2..91b811147 100644 --- a/src/gsi/intjo.f90 +++ b/src/gsi/intjo.f90 @@ -240,8 +240,6 @@ subroutine intjo_(rval,qpred,sval,sbias) use m_obsdiags, only: obOper_destroy use gsi_obOper, only: obOper -use intradmod, only: setrad - implicit none ! Declare passed variables @@ -257,7 +255,6 @@ subroutine intjo_(rval,qpred,sval,sbias) class(obOper),pointer:: it_obOper !****************************************************************************** - call setrad(sval(1)) ! "RHS for jo", as it was labeled in intall(). !$omp parallel do schedule(dynamic,1) private(ibin,it,ix,it_obOper) diff --git a/src/gsi/intrad.f90 b/src/gsi/intrad.f90 index 689b6c821..19bb40003 100644 --- a/src/gsi/intrad.f90 +++ b/src/gsi/intrad.f90 @@ -83,13 +83,14 @@ subroutine setrad(sval) use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex + use mpimod, only: mype implicit none ! Declare passed variables type(gsi_bundle), intent(in ) :: sval ! Declare local variables - integer(i_kind) ier,istatus,indx + integer(i_kind) indx logical look real(r_kind),pointer,dimension(:) :: st,sq,scw,soz,su,sv,sqg,sqh,sqi,sql,sqr,sqs @@ -97,91 +98,110 @@ subroutine setrad(sval) if(done_setting) return -! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0; itsen=0; iqv=0; ius=0; ivs=0; isst=0; ioz=0; icw=0 - iqg=0; iqh=0; iqi=0; iql=0; iqr=0; iqs=0 - call gsi_bundlegetpointer(sval,'u', su, istatus);ius=istatus+ius - call gsi_bundlegetpointer(sval,'v', sv, istatus);ivs=istatus+ivs - call gsi_bundlegetpointer(sval,'tsen' ,st, istatus);itsen=istatus+itsen - call gsi_bundlegetpointer(sval,'q', sq, istatus);iqv=istatus+iqv - call gsi_bundlegetpointer(sval,'cw' ,scw,istatus);icw=istatus+icw - call gsi_bundlegetpointer(sval,'oz' ,soz,istatus);ioz=istatus+ioz - call gsi_bundlegetpointer(sval,'sst',sst,istatus);isst=istatus+isst - call gsi_bundlegetpointer(sval,'qg' ,sqg,istatus);iqg=istatus+iqg - call gsi_bundlegetpointer(sval,'qh' ,sqh,istatus);iqh=istatus+iqh - call gsi_bundlegetpointer(sval,'qi' ,sqi,istatus);iqi=istatus+iqi - call gsi_bundlegetpointer(sval,'ql' ,sql,istatus);iql=istatus+iql - call gsi_bundlegetpointer(sval,'qr' ,sqr,istatus);iqr=istatus+iqr - call gsi_bundlegetpointer(sval,'qs' ,sqs,istatus);iqs=istatus+iqs - lgoback=(ius/=0).and.(ivs/=0).and.(itsen/=0).and.(iqv/=0).and.(ioz/=0).and.(icw/=0).and.(isst/=0) - lgoback=lgoback .and.(iqg/=0).and.(iqh/=0).and.(iqi/=0).and.(iql/=0).and.(iqr/=0).and.(iqs/=0) - if(lgoback)return - ! check to see if variable participates in forward operator ! tsen indx=getindex(radjacnames,'tsen') - look=(itsen==0.and.indx>0) itsen=-1 - if(look) itsen=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'tsen',st, itsen) + look=itsen==0 + if(look) itsen=radjacindxs(indx) + end if ! q indx=getindex(radjacnames,'q') - look=(iqv==0.and.indx>0) iqv=-1 - if(look) iqv=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'q', sq, iqv) + look=iqv==0 + if(look) iqv=radjacindxs(indx) + end if ! oz indx=getindex(radjacnames,'oz') - look=(ioz ==0.and.indx>0) ioz=-1 - if(look) ioz =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'oz' , soz,ioz) + look=ioz ==0 + if(look) ioz =radjacindxs(indx) + end if ! cw indx=getindex(radjacnames,'cw') - look=(icw ==0.and.indx>0) icw=-1 - if(look) icw =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'cw' , scw,icw) + look=icw ==0 + if(look) icw =radjacindxs(indx) + end if ! sst indx=getindex(radjacnames,'sst') - look=(isst==0.and.indx>0) isst=-1 - if(look) isst=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'sst', sst,isst) + look=isst==0 + if(look) isst=radjacindxs(indx) + end if ! us & vs indx=getindex(radjacnames,'u') - look=(ius==0.and.indx>0) ius=-1 - if(look) ius=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'u', su, ius) + look=ius==0 + if(look) ius=radjacindxs(indx) + end if indx=getindex(radjacnames,'v') - look=(ivs==0.and.indx>0) ivs=-1 - if(look) ivs=radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'v', sv, ivs) + look=ivs==0 + if(look) ivs=radjacindxs(indx) + end if ! qg indx=getindex(radjacnames,'qg') - look=(iqg ==0.and.indx>0) iqg=-1 - if(look) iqg =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qg' , sqg,iqg) + look=iqg ==0 + if(look) iqg =radjacindxs(indx) + end if ! qh indx=getindex(radjacnames,'qh') - look=(iqh ==0.and.indx>0) iqh=-1 - if(look) iqh =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qh' , sqh,iqh) + look=iqh ==0 + if(look) iqh =radjacindxs(indx) + end if ! qi indx=getindex(radjacnames,'qi') - look=(iqi ==0.and.indx>0) iqi=-1 - if(look) iqi =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qi' , sqi,iqi) + look=iqi ==0 + if(look) iqi =radjacindxs(indx) + end if ! ql indx=getindex(radjacnames,'ql') - look=(iql ==0.and.indx>0) iql=-1 - if(look) iql =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'ql' , sql,iql) + look=iql ==0 + if(look) iql =radjacindxs(indx) + end if ! qr indx=getindex(radjacnames,'qr') - look=(iqr ==0.and.indx>0) iqr=-1 - if(look) iqr =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qr' , sqr,iqr) + look=iqr ==0 + if(look) iqr =radjacindxs(indx) + end if ! qs indx=getindex(radjacnames,'qs') - look=(iqs ==0.and.indx>0) iqs=-1 - if(look) iqs =radjacindxs(indx) + if(indx > 0)then + call gsi_bundlegetpointer(sval,'qs' , sqs,iqs) + look=iqs ==0 + if(look) iqs =radjacindxs(indx) + end if luseu=ius>=0 lusev=ivs>=0 @@ -196,6 +216,26 @@ subroutine setrad(sval) luseqr=iqr>=0 luseqs=iqs>=0 lusesst=isst>=0 + lgoback=.not.(luseu .or. lusev .or. luset .or. luseq .or. luseoz .or. lusecw .or. & + luseql .or. luseqi .or. luseqh .or. luseqg .or. luseqr .or. luseqs .or. & + lusesst) + + if(mype == 0)then + write(6,*) ' following variables are used in int and stp radiance calculations ' + if(luset) write(6,*)'tsen' + if(luseq) write(6,*)'q' + if(luseoz)write(6,*)'oz' + if(luseu) write(6,*)'u' + if(lusev) write(6,*)'v' + if(lusesst) write(6,*)'sst' + if(lusecw) write(6,*)'cw' + if(luseql) write(6,*)'ql' + if(luseqi) write(6,*)'qi' + if(luseqh) write(6,*)'qh' + if(luseqg) write(6,*)'qg' + if(luseqr) write(6,*)'qr' + if(luseqs) write(6,*)'qs' + end if done_setting = .true. @@ -308,7 +348,7 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) i1,i2,i3,i4,n,k,ic,ix,nn,mm,ncr1,ncr2 - integer(i_kind) ier,istatus + integer(i_kind) istatus integer(i_kind),dimension(nsig) :: i1n,i2n,i3n,i4n real(r_kind),allocatable,dimension(:):: val real(r_kind) w1,w2,w3,w4 @@ -331,7 +371,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) call timer_ini('intrad') ! Retrieve pointers; return when not found (except in case of non-essentials) - ier=0 if(luseu)then call gsi_bundlegetpointer(sval,'u', su, istatus) call gsi_bundlegetpointer(rval,'u', ru, istatus) @@ -468,7 +507,6 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do - ! For all other configurations ! begin channel specific calculations allocate(val(radptr%nchan)) @@ -487,10 +525,8 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) end do end if -!$omp parallel do schedule(dynamic,1) private(nn,ic,ix,k) +!$omp parallel do schedule(dynamic,1) private(nn,k,ncr1) do nn=1,radptr%nchan - ic=radptr%icx(nn) - ix=(ic-1)*npred ! include observation increment and lapse rate contributions to bias correction val(nn)=zero @@ -499,25 +535,24 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) do k=1,nsigradjac val(nn)=val(nn)+tdir(k)*radptr%dtb_dvar(k,nn) end do - end do - ncr1=0 ! Include contributions from remaining bias correction terms - do nn=1,radptr%nchan if( .not. ladtest_obs) then if(radptr%use_corr_obs)then val_quad = zero_quad do mm=1,nn - ncr1=ncr1+1 + ncr1=radptr%iccerr(nn)+mm val_quad=val_quad+radptr%rsqrtinv(ncr1)*biasvect(mm) enddo val(nn)=val(nn) + val_quad else - val(nn)=val(nn)+biasvect(nn) + val(nn)=val(nn) + biasvect(nn) endif end if + end do - if(luse_obsdiag)then + if(luse_obsdiag)then + do nn=1,radptr%nchan if (lsaveobsens) then val(nn)=val(nn)*radptr%err2(nn)*radptr%raterr2(nn) !-- radptr%diags(nn)%ptr%obssen(jiter) = val(nn) @@ -526,13 +561,14 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) !-- if (radptr%luse) radptr%diags(nn)%ptr%tldepart(jiter) = val(nn) if (radptr%luse) call obsdiagNode_set(radptr%diags(nn)%ptr,jiter=jiter,tldepart=val(nn)) endif - endif - end do + end do + end if if (l_do_adjoint) then - do nn=1,radptr%nchan - ic=radptr%icx(nn) - if (.not. lsaveobsens) then + if (.not. lsaveobsens) then +!$omp parallel do schedule(dynamic,1) private(nn,ic,cg_rad,wnotgross,wgross,p0) + do nn=1,radptr%nchan + ic=radptr%icx(nn) if( .not. ladtest_obs) val(nn)=val(nn)-radptr%res(nn) ! Multiply by variance. @@ -546,51 +582,45 @@ subroutine intrad_(radhead,rval,sval,rpred,spred) endif if(.not.ladtest_obs) val(nn) = val(nn)*radptr%err2(nn)*radptr%raterr2(nn) - endif - enddo + enddo + endif ! Extract contributions from bias correction terms -! use compensated summation if( .not. ladtest_obs) then - if (radptr%use_corr_obs) then - ncr1 = 0 - do mm=1,radptr%nchan - ncr1 = ncr1 + mm - ncr2 = ncr1 - biasvect(mm) = zero - do nn=mm,radptr%nchan - biasvect(mm)=biasvect(mm)+radptr%rsqrtinv(ncr2)*val(nn) - ncr2 = ncr2 + nn - enddo - end do - endif + if(radptr%luse)then + if (radptr%use_corr_obs) then +!$omp parallel do schedule(dynamic,1) private(n,nn,ix,ncr1,ncr2,mm) + do nn=1,radptr%nchan + ncr1 = radptr%iccerr(nn)+nn + ncr2 = ncr1 + biasvect(nn) = zero + do mm=nn,radptr%nchan + biasvect(nn)=biasvect(nn)+radptr%rsqrtinv(ncr2)*val(mm) + ncr2 = ncr2 + mm + enddo - if(radptr%luse)then - if(radptr%use_corr_obs)then - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) - enddo + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+biasvect(nn)*radptr%pred(n,nn) enddo - else - do nn=1,radptr%nchan - ix=(radptr%icx(nn)-1)*npred - do n=1,npred - rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) - end do - end do - end if - end if + enddo + else +!$omp parallel do schedule(dynamic,1) private(n,nn,ix) + do nn=1,radptr%nchan + ix=(radptr%icx(nn)-1)*npred + do n=1,npred + rpred(ix+n)=rpred(ix+n)+radptr%pred(n,nn)*val(nn) + end do + end do + end if + end if - deallocate(biasvect) + deallocate(biasvect) end if ! not ladtest_obs - endif ! Begin adjoint - if (l_do_adjoint) then !$omp parallel do schedule(dynamic,1) private(k,nn) do k=1,nsigradjac tval(k)=zero diff --git a/src/gsi/intsst.f90 b/src/gsi/intsst.f90 index d91024752..6b255d0d0 100644 --- a/src/gsi/intsst.f90 +++ b/src/gsi/intsst.f90 @@ -79,7 +79,7 @@ subroutine intsst(ssthead,rval,sval) ! !$$$ use kinds, only: r_kind,i_kind - use constants, only: half,one,tiny_r_kind,cg_term + use constants, only: zero,half,one,tiny_r_kind,cg_term use obsmod, only: lsaveobsens, l_do_adjoint,luse_obsdiag use qcmod, only: nlnqc_iter,varqc_iter use gsi_nstcouplermod, only: nst_gsi @@ -100,7 +100,6 @@ subroutine intsst(ssthead,rval,sval) ! real(r_kind) penalty real(r_kind) w1,w2,w3,w4 real(r_kind) val - real(r_kind) tval,tdir real(r_kind) cg_sst,p0,grad,wnotgross,wgross,pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst @@ -108,15 +107,14 @@ subroutine intsst(ssthead,rval,sval) ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2) return ! Retrieve pointers ! Simply return if any pointer not found - ier=0 - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);ier=istatus call gsi_bundlegetpointer(rval,'sst',rsst,istatus);ier=istatus+ier if(ier/=0)return - !sstptr => ssthead sstptr => sstNode_typecast(ssthead) do while (associated(sstptr)) j1=sstptr%ij(1) @@ -129,15 +127,9 @@ subroutine intsst(ssthead,rval,sval) w4=sstptr%wij(4) ! Forward model - val=w1*ssst(j1)+w2*ssst(j2)& - +w3*ssst(j3)+w4*ssst(j4) - - if ( nst_gsi > 2 ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - val = tdir*sstptr%tz_tr ! Include contributions from Tz jacobian - else - val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward - endif + val=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = val*sstptr%tz_tr ! Include contributions from Tz jacobian if(luse_obsdiag)then @@ -173,18 +165,12 @@ subroutine intsst(ssthead,rval,sval) endif ! Adjoint - if ( nst_gsi > 2 ) then - tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian - rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points - rsst(j2)=rsst(j2)+w2*tval - rsst(j3)=rsst(j3)+w3*tval - rsst(j4)=rsst(j4)+w4*tval - else - rsst(j1)=rsst(j1)+w1*grad - rsst(j2)=rsst(j2)+w2*grad - rsst(j3)=rsst(j3)+w3*grad - rsst(j4)=rsst(j4)+w4*grad - endif + grad = sstptr%tz_tr*grad ! Extract contributions from surface jacobian + + rsst(j1)=rsst(j1)+w1*grad + rsst(j2)=rsst(j2)+w2*grad + rsst(j3)=rsst(j3)+w3*grad + rsst(j4)=rsst(j4)+w4*grad endif ! if (l_do_adjoint) then diff --git a/src/gsi/intt.f90 b/src/gsi/intt.f90 index 9401026e4..b4082712a 100644 --- a/src/gsi/intt.f90 +++ b/src/gsi/intt.f90 @@ -145,7 +145,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Declare local variables integer(i_kind) j1,j2,j3,j4,j5,j6,j7,j8,ier,istatus,isst,ix,n - real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8,time_t + real(r_kind) w1,w2,w3,w4,w5,w6,w7,w8 ! real(r_kind) penalty real(r_kind) cg_t,val,grad,rat_err2,error2,t_pg,var_jb real(r_kind) psfc_grad,tg_grad @@ -160,14 +160,13 @@ subroutine intt_(thead,rval,sval,rpred,spred) ! Retrieve pointers ! Simply return if any pointer not found - ier=0; isst=0 - call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus+ier + call gsi_bundlegetpointer(sval,'tsen', st,istatus);ier=istatus call gsi_bundlegetpointer(sval,'tv', stv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'q', sq,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'u', su,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'v', sv,istatus);ier=istatus+ier call gsi_bundlegetpointer(sval,'prse', sp,istatus);ier=istatus+ier - call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus+isst + call gsi_bundlegetpointer(sval,'sst',ssst,istatus);isst=istatus if(ier/=0) return call gsi_bundlegetpointer(rval,'tsen', rt,istatus);ier=istatus+ier @@ -179,7 +178,6 @@ subroutine intt_(thead,rval,sval,rpred,spred) call gsi_bundlegetpointer(rval,'sst',rsst,istatus);isst=istatus+isst if(ier/=0) return - time_t=zero !tptr => thead tptr => tNode_typecast(thead) do while (associated(tptr)) @@ -205,20 +203,22 @@ subroutine intt_(thead,rval,sval,rpred,spred) !----------use surface model---------------------- + qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) + us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) + vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) + psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + if(tptr%tv_ob)then ts_prime0=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4) else ts_prime0=w1*st(j1)+w2*st(j2)+w3*st(j3)+w4*st(j4) end if + if (isst==0) then tg_prime0=w1* ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) else tg_prime0=zero end if - qs_prime0=w1* sq(j1)+w2* sq(j2)+w3* sq(j3)+w4* sq(j4) - us_prime0=w1* su(j1)+w2* su(j2)+w3* su(j3)+w4* su(j4) - vs_prime0=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) - psfc_prime0=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) val=psfc_prime0*tptr%tlm_tsfc(1) + tg_prime0*tptr%tlm_tsfc(2) + & ts_prime0 *tptr%tlm_tsfc(3) + qs_prime0*tptr%tlm_tsfc(4) + & @@ -231,8 +231,8 @@ subroutine intt_(thead,rval,sval,rpred,spred) val=w1*stv(j1)+w2*stv(j2)+w3*stv(j3)+w4*stv(j4)& +w5*stv(j5)+w6*stv(j6)+w7*stv(j7)+w8*stv(j8) else - val=w1* st(j1)+w2* st(j2)+w3* st(j3)+w4* st(j4)& - +w5* st(j5)+w6* st(j6)+w7* st(j7)+w8* st(j8) + val=w1*st(j1)+ w2*st(j2)+ w3*st(j3)+ w4*st(j4)& + +w5*st(j5)+ w6*st(j6)+ w7*st(j7)+ w8*st(j8) end if end if @@ -310,21 +310,7 @@ subroutine intt_(thead,rval,sval,rpred,spred) rp(j2)=rp(j2)+w2*psfc_grad rp(j3)=rp(j3)+w3*psfc_grad rp(j4)=rp(j4)+w4*psfc_grad - vs_grad =tptr%tlm_tsfc(6)*grad - rv(j1)=rv(j1)+w1*vs_grad - rv(j2)=rv(j2)+w2*vs_grad - rv(j3)=rv(j3)+w3*vs_grad - rv(j4)=rv(j4)+w4*vs_grad - us_grad =tptr%tlm_tsfc(5)*grad - ru(j1)=ru(j1)+w1*us_grad - ru(j2)=ru(j2)+w2*us_grad - ru(j3)=ru(j3)+w3*us_grad - ru(j4)=ru(j4)+w4*us_grad - qs_grad =tptr%tlm_tsfc(4)*grad - rq(j1)=rq(j1)+w1*qs_grad - rq(j2)=rq(j2)+w2*qs_grad - rq(j3)=rq(j3)+w3*qs_grad - rq(j4)=rq(j4)+w4*qs_grad + if (isst==0) then tg_grad =tptr%tlm_tsfc(2)*grad rsst(j1)=rsst(j1)+w1*tg_grad @@ -333,22 +319,39 @@ subroutine intt_(thead,rval,sval,rpred,spred) rsst(j4)=rsst(j4)+w4*tg_grad end if - ts_grad =tptr%tlm_tsfc(3)*grad if(tptr%tv_ob)then rtv(j1)=rtv(j1)+w1*ts_grad rtv(j2)=rtv(j2)+w2*ts_grad rtv(j3)=rtv(j3)+w3*ts_grad rtv(j4)=rtv(j4)+w4*ts_grad - else rt(j1)=rt(j1)+w1*ts_grad rt(j2)=rt(j2)+w2*ts_grad rt(j3)=rt(j3)+w3*ts_grad rt(j4)=rt(j4)+w4*ts_grad - end if + qs_grad =tptr%tlm_tsfc(4)*grad + rq(j1)=rq(j1)+w1*qs_grad + rq(j2)=rq(j2)+w2*qs_grad + rq(j3)=rq(j3)+w3*qs_grad + rq(j4)=rq(j4)+w4*qs_grad + + us_grad =tptr%tlm_tsfc(5)*grad + ru(j1)=ru(j1)+w1*us_grad + ru(j2)=ru(j2)+w2*us_grad + ru(j3)=ru(j3)+w3*us_grad + ru(j4)=ru(j4)+w4*us_grad + + vs_grad =tptr%tlm_tsfc(6)*grad + rv(j1)=rv(j1)+w1*vs_grad + rv(j2)=rv(j2)+w2*vs_grad + rv(j3)=rv(j3)+w3*vs_grad + rv(j4)=rv(j4)+w4*vs_grad + + + else !------bypass surface model-------------------------- diff --git a/src/gsi/jgrad.f90 b/src/gsi/jgrad.f90 index 2e3255646..c6e2e5415 100755 --- a/src/gsi/jgrad.f90 +++ b/src/gsi/jgrad.f90 @@ -58,6 +58,7 @@ subroutine jgrad(xhat,yhat,fjcost,gradx,lupdfgs,nprt,calledby) use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens use mpl_allreducemod, only: mpl_allreduce use obs_sensitivity, only: efsoi_o2_update +use control2state_mod, only: control2state,control2state_ad implicit none diff --git a/src/gsi/lightinfo.f90 b/src/gsi/lightinfo.f90 index b0ebcdacf..bdd6aee39 100755 --- a/src/gsi/lightinfo.f90 +++ b/src/gsi/lightinfo.f90 @@ -205,11 +205,13 @@ subroutine lightinfo_read else ! File does not exist, write warning message to alert users - if (mype==mype_light) then - open(iout_light) - write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' - close(iout_light) - endif +! For many usages light data is not important. Write line to output. +! if (mype==mype_light) then +! open(iout_light) +! write(iout_light,*)'LIGHTINFO_READ: ***WARNING*** FILE ',trim(fname),'does not exist' + if(mype==mype_light)write(6,*)'LIGHTINFO_READ: FILE ',trim(fname),'does not exist' +! close(iout_light) +! endif end if return diff --git a/src/gsi/m_radNode.F90 b/src/gsi/m_radNode.F90 index 33070e838..ae4854920 100644 --- a/src/gsi/m_radNode.F90 +++ b/src/gsi/m_radNode.F90 @@ -57,6 +57,7 @@ module m_radNode ! square root of inverse of R, only used ! if using correlated obs + integer(i_kind),dimension(:),pointer :: iccerr => NULL() integer(i_kind),dimension(:),pointer :: icx => NULL() integer(i_kind),dimension(:),pointer :: ich => NULL() integer(i_kind) :: nchan ! number of channels for this profile @@ -214,6 +215,7 @@ subroutine obsNode_clean_(aNode) if(associated(aNode%Rpred )) deallocate(aNode%Rpred ) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) _EXIT_(myname_) return end subroutine obsNode_clean_ @@ -276,6 +278,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) if(associated(aNode%Rpred )) deallocate(aNode%Rpred) if(associated(aNode%rsqrtinv)) deallocate(aNode%rsqrtinv) if(associated(aNode%icx )) deallocate(aNode%icx ) + if(associated(aNode%iccerr )) deallocate(aNode%iccerr ) nchan=aNode%nchan allocate( aNode%diags(nchan), & @@ -285,7 +288,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%pred (npred,nchan), & aNode%dtb_dvar(nsigradjac,nchan), & aNode%ich (nchan), & - aNode%icx (nchan) ) + aNode%icx (nchan), aNode%iccerr(nchan) ) read(iunit,iostat=istat) aNode%ich , & aNode%res , & @@ -293,6 +296,7 @@ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij @@ -368,6 +372,7 @@ subroutine obsNode_xwrite_(aNode,junit,jstat) aNode%raterr2 , & aNode%pred , & aNode%icx , & + aNode%iccerr , & aNode%dtb_dvar, & aNode%wij , & aNode%ij diff --git a/src/gsi/ncepgfs_io.f90 b/src/gsi/ncepgfs_io.f90 index 52dcc4e1b..59be6d392 100644 --- a/src/gsi/ncepgfs_io.f90 +++ b/src/gsi/ncepgfs_io.f90 @@ -1440,7 +1440,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) if ( use_gfs_nemsio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else if (fv3_full_hydro) then @@ -1461,7 +1461,7 @@ subroutine write_gfs(increment,mype_atm,mype_sfc) else if ( use_gfs_ncio ) then if ( write_fv3_incr ) then - call write_fv3_increment(grd_a,sp_a,filename,mype_atm, & + call write_fv3_increment(grd_a,filename,mype_atm, & atm_bundle,itoutsig) else call write_gfsncatm(grd_a,sp_a,filename,mype_atm, & diff --git a/src/gsi/obs_sensitivity.f90 b/src/gsi/obs_sensitivity.f90 index 880ee6384..b6498d09f 100644 --- a/src/gsi/obs_sensitivity.f90 +++ b/src/gsi/obs_sensitivity.f90 @@ -61,6 +61,7 @@ module obs_sensitivity use hybrid_ensemble_isotropic, only: create_ensemble,load_ensemble,destroy_ensemble use hybrid_ensemble_isotropic, only: hybens_localization_setup use mpeu_util, only: perr,die +use control2state_mod, only: control2state,control2state_ad ! ------------------------------------------------------------------------------ implicit none save diff --git a/src/gsi/obsmod.F90 b/src/gsi/obsmod.F90 index 3dd936d94..bb317d075 100644 --- a/src/gsi/obsmod.F90 +++ b/src/gsi/obsmod.F90 @@ -435,8 +435,8 @@ module obsmod public :: iout_pcp,iout_rad,iadate,iadatemn,write_diag,reduce_diag,oberrflg,bflag,ndat,dthin,dmesh,l_do_adjoint public :: diag_radardbz public :: lsaveobsens - public :: iout_cldch, mype_cldch - public :: nprof_gps,time_offset,ianldate,tcp_box + public :: iout_cldch, mype_cldch + public :: nprof_gps,time_offset,ianldate,tcp_box public :: iout_oz,iout_co,dsis,ref_obs,obsfile_all,lobserver,tcp_posmatch,perturb_obs,ditype,dsfcalc,dplat public :: time_window,dval,dtype,dfile,dirname,obs_setup,oberror_tune,offtime_data public :: lobsdiagsave,lobsdiag_forenkf,blacklst,hilbert_curve,lobskeep,time_window_max,sfcmodel,ext_sonde @@ -831,7 +831,7 @@ subroutine init_obsmod_dflts iout_tcp=214 ! synthetic tc-mslp iout_lag=215 ! lagrangian tracers iout_co=216 ! co tracers - iout_aero=217 ! aerosol product (aod) + iout_aero=217 ! aerosol product (aod) CURRENTLY NOT USED iout_gust=218 ! wind gust iout_vis=219 ! visibility iout_pblh=221 ! pbl height diff --git a/src/gsi/pcgsoi.f90 b/src/gsi/pcgsoi.f90 index a4ae2431b..fac01c931 100644 --- a/src/gsi/pcgsoi.f90 +++ b/src/gsi/pcgsoi.f90 @@ -130,8 +130,8 @@ subroutine pcgsoi() iguess,read_guess_solution, & niter_no_qc,print_diag_pcg use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar, iwrtinc, ladtest, & - iorthomax - use gridmod, only: twodvar_regional,periodic + iorthomax,lsqrtb + use gridmod, only: twodvar_regional,periodic,minmype use constants, only: zero,one,tiny_r_kind use mpimod, only: mype use mpl_allreducemod, only: mpl_allreduce @@ -148,15 +148,17 @@ subroutine pcgsoi() use bias_predictors, only: update_bias_preds use xhat_vordivmod, only : xhat_vordiv_init, xhat_vordiv_calc, xhat_vordiv_clean use timermod, only: timer_ini,timer_fnl - use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens + use hybrid_ensemble_parameters,only : l_hyb_ens,ntlevs_ens,aniso_a_en use gsi_bundlemod, only : gsi_bundle use gsi_bundlemod, only : self_add,assignment(=) use gsi_bundlemod, only : gsi_bundleprint + use gsi_bundlemod, only : gsi_bundlegetpointer use gsi_4dcouplermod, only : gsi_4dcoupler_grtests use rapidrefresh_cldsurf_mod, only: i_gsdcldanal_type use gsi_io, only: verbose use berror, only: vprecond use stpjomod, only: stpjo_setup + use intradmod, only: setrad implicit none @@ -187,7 +189,7 @@ subroutine pcgsoi() type(control_vector), allocatable, dimension(:) :: cglwork type(control_vector), allocatable, dimension(:) :: cglworkhat integer(i_kind) :: iortho - logical :: print_verbose + logical :: print_verbose,ortho,diag_print logical :: lanlerr,read_success ! Step size diagnostic strings @@ -235,7 +237,9 @@ subroutine pcgsoi() nlnqc_iter=.false. call stpjo_setup(nobs_bins) + ortho=.false. if(iorthomax>0) then + ortho=.true. allocate(cglwork(iorthomax+1)) DO ii=1,iorthomax+1 CALL allocate_cv(cglwork(ii)) @@ -252,10 +256,19 @@ subroutine pcgsoi() end do sbias=zero + call setrad(sval(1)) + if(l_hyb_ens .and. .not. aniso_a_en) then + if (lsqrtb) then + write(6,*)'l_hyb_ens: not for use with lsqrtb' + call stop2(317) + end if + end if ! Perform inner iteration inner_iteration: do iter=0,niter(jiter) + + diag_print= iter <= 1 .and. print_diag_pcg -! Gradually turn on variational qc to avoid possible convergence problems +! Gradually turn on old variational qc to avoid possible convergence problems if(vqc) then nlnqc_iter = iter >= niter_no_qc(jiter) if(jiter == jiterstart) then @@ -266,17 +279,11 @@ subroutine pcgsoi() endif end if ! 1. Calculate gradient - do ii=1,nobs_bins - rval(ii)=zero - end do - rbias=zero gradx=zero - llprt=(mype==0).and.(iter<=1) -! Control to state -! call c2s(xhat,sval,sbias,llprt,.true.) + llprt=(mype==minmype).and.(iter<=1) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(sval(ii),'sval') enddo @@ -285,7 +292,7 @@ subroutine pcgsoi() ! Compare obs to solution and transpose back to grid call intall(sval,sbias,rval,rbias) - if (iter<=1 .and. print_diag_pcg) then + if (diag_print) then do ii=1,nobs_bins call prt_state_norms(rval(ii),'rval') enddo @@ -295,10 +302,12 @@ subroutine pcgsoi() call c2s_ad(gradx,rval,rbias,llprt) ! Print initial Jo table - if (iter==0 .and. print_diag_pcg .and. luse_obsdiag) then - nprt=2 - call evaljo(zjo,iobs,nprt,llouter) - call prt_control_norms(gradx,'gradx') + if (iter==0) then + if(print_diag_pcg .and. luse_obsdiag) then + nprt=2 + call evaljo(zjo,iobs,nprt,llouter) + call prt_control_norms(gradx,'gradx') + end if endif ! Add contribution from background term @@ -308,7 +317,7 @@ subroutine pcgsoi() ! End of gradient calculation ! Re-orthonormalization if requested - if(iorthomax>0) then + if(ortho) then iortho=min(iorthomax,iter) if(iter .ne. 0) then do ii=iortho,1,-1 @@ -323,13 +332,13 @@ subroutine pcgsoi() ! 2. Multiply by background error call multb(gradx,grady) - if(iorthomax>0) then + if(ortho) then ! save gradients if (iter <= iortho) then - zdla = sqrt(dot_product(gradx,grady,r_quad)) + zdla = one/sqrt(dot_product(gradx,grady,r_quad)) do i=1,nclen - cglwork(iter+1)%values(i)=gradx%values(i)/zdla - cglworkhat(iter+1)%values(i)=grady%values(i)/zdla + cglwork(iter+1)%values(i)=gradx%values(i)*zdla + cglworkhat(iter+1)%values(i)=grady%values(i)*zdla end do end if end if @@ -350,7 +359,7 @@ subroutine pcgsoi() ! different due to round off, so use average. gnorm(2)=dprod(2)-0.5_r_quad*(dprod(3)+dprod(4)) gnorm(3)=dprod(2) - if(mype == 0)then + if(mype == minmype)then aindex=abs(dprod(3)/dprod(2)) write(iout_iter,*) 'NL Index ',aindex if(aindex > 0.5_r_kind .or. print_verbose) write(iout_iter,*) 'NL Values ', dprod(3),dprod(2) @@ -370,7 +379,7 @@ subroutine pcgsoi() gnorm(1)=dprod(1) - if(mype == 0)write(iout_iter,*)'Minimization iteration',iter + if(mype == minmype)write(iout_iter,*)'Minimization iteration',iter ! 4. Calculate b and new search direction b=zero @@ -378,13 +387,13 @@ subroutine pcgsoi() if (iter > 1 .or. .not. read_success)then if (gsave>1.e-16_r_kind) b=gnorm(2)/gsave if (b30.0_r_kind) then - if (mype==0) then + if (mype==minmype) then if (iout_6) write(6,105) gnorm(2),gsave,b write(iout_iter,105) gnorm(2),gsave,b endif b=zero endif - if (mype==0 .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b + if (mype==minmype .and. print_verbose) write(6,888)'pcgsoi: gnorm(1:3),b=',gnorm,b end if do i=1,nclen @@ -432,22 +441,20 @@ subroutine pcgsoi() gnormx=gnorm(1)/gnormorig penx=penalty/penorig - if (mype==0) then + if (mype==minmype) then if (iter==0) then zgini=gnorm(1) zfini=penalty write(6,888)'Initial cost function =',zfini write(6,888)'Initial gradient norm =',sqrt(zgini) endif - if(print_verbose)then - write(iout_iter,888)'pcgsoi: gnorm(1:2)',gnorm - write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcost - end if istep=1 if (stp= pennorm .or. end_iter)then - if(mype == 0)then + if(mype == minmype)then if(iout_6) write(6,101) write(iout_iter,101) @@ -508,7 +515,7 @@ subroutine pcgsoi() ! End of inner iteration ! Deallocate space for renormalization - if(iorthomax>0) then + if(ortho) then do ii=1,iorthomax+1 call deallocate_cv(cglwork(ii)) enddo @@ -521,7 +528,7 @@ subroutine pcgsoi() ! Calculate adjusted observation error factor if( oberror_tune .and. (.not.l4dvar) ) then - if (mype == 0) write(6,*) 'PCGSOI: call penal for obs perturbation' + if (mype == minmype) write(6,*) 'PCGSOI: call penal for obs perturbation' ! call c2s(xhat,sval,sbias,.false.,.false.) call penal(sval(1)) @@ -535,17 +542,14 @@ subroutine pcgsoi() if (l_tlnmc .and. baldiag_inc) call strong_baldiag_inc(sval,size(sval)) - llprt=(mype==0) + llprt=(mype==minmype) ! call c2s(xhat,sval,sbias,llprt,.false.) if(print_diag_pcg)then ! Evaluate final cost function and gradient - if (mype==0) write(6,*)'Minimization final diagnostics' + if (mype==minmype) write(6,*)'Minimization final diagnostics' - do ii=1,nobs_bins - rval(ii)=zero - end do call intall(sval,sbias,rval,rbias) gradx=zero call c2s_ad(gradx,rval,rbias,llprt) @@ -575,16 +579,16 @@ subroutine pcgsoi() ! fjcost(1) = dot_product(xhatsave,yhatsave,r_quad) end if ! fjcost(2) = zjo - zfend=penaltynew -! if(l_hyb_ens) zfend=zfend+fjcost_e - if (mype==0) then + if (mype==minmype) then + zfend=penaltynew if(l_hyb_ens) then ! If hybrid ensemble run, print out contribution to Jb and Je separately write(iout_iter,999)'costterms Jb,Je,Jo,Jc,Jl =',jiter,iter,fjcostnew(1)- fjcost_e, & fjcost_e,fjcostnew(2:4) +! zfend=zfend+fjcost_e else write(iout_iter,999)'costterms Jb,Jo,Jc,Jl =',jiter,iter,fjcostnew @@ -905,6 +909,7 @@ subroutine c2s(hat,val,bias,llprt,ltest) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar use gsi_4dcouplermod, only : gsi_4dcoupler_grtests + use control2state_mod, only: control2state,control2state_ad implicit none type(control_vector) ,intent(inout) :: hat @@ -971,6 +976,7 @@ subroutine c2s_ad(hat,val,bias,llprt) use gsi_bundlemod, only : gsi_bundle,assignment(=) use gsi_bundlemod, only : self_add use gsi_4dvar, only: nobs_bins, nsubwin, l4dvar + use control2state_mod, only: control2state_ad implicit none type(control_vector) ,intent(inout) :: hat diff --git a/src/gsi/pvqc.f90 b/src/gsi/pvqc.f90 index 81d27ba99..3353b091a 100755 --- a/src/gsi/pvqc.f90 +++ b/src/gsi/pvqc.f90 @@ -382,8 +382,8 @@ subroutine vqch_iii(ia,ib,ik,x,g,w)! [vqch] g=g-ya w=-w/xx else - g=-qx**2/2 - w=1 + g=-qx**2/2_dp + w=1_dp endif g=p*g end subroutine vqch_iii diff --git a/src/gsi/q_diag.f90 b/src/gsi/q_diag.f90 index 925a5775e..15ef49c6b 100644 --- a/src/gsi/q_diag.f90 +++ b/src/gsi/q_diag.f90 @@ -38,7 +38,7 @@ subroutine q_diag(it,mype) use mpimod, only: mpi_rtype,mpi_comm_world,mpi_sum,ierror use constants,only: zero,two,one,half use gridmod, only: lat2,lon2,nsig,nlat,nlon,lat1,lon1,iglobal,& - displs_g,ijn,wgtlats,itotsub,strip + displs_g,ijn,wgtlats,itotsub,strip,minmype use derivsmod, only: cwgues use general_commvars_mod, only: load_grid use gridmod, only: regional @@ -67,7 +67,7 @@ subroutine q_diag(it,mype) real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() real(r_kind),pointer,dimension(:,:,:):: ges_cwmr_it=>NULL() - mype_out=0 + mype_out=minmype mm1=mype+1 ier=0 diff --git a/src/gsi/qcmod.f90 b/src/gsi/qcmod.f90 index f4afdbae9..7146ceff3 100644 --- a/src/gsi/qcmod.f90 +++ b/src/gsi/qcmod.f90 @@ -2311,7 +2311,6 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if (lcloud .ge. kmax(i)) then if(luse)aivals(11,is) = aivals(11,is) + one varinv(i) = zero - varinv_use(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc cycle end if @@ -2320,12 +2319,10 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & ! If more than 2% of the transmittance comes from the cloud layer, ! reject the channel (0.02 is a tunable parameter) - delta = 0.02_r_kind if ( ptau5(lcloud,i) > 0.02_r_kind) then ! QC4 in statsrad if(luse)aivals(11,is) = aivals(11,is) + one varinv(i) = zero - varinv_use(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_cloud_qc end if end do @@ -2353,8 +2350,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & delta=max(r0_05*tnoise(i),r0_02) if(abs(dts*ts(i)) > delta)then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) & - aivals(10,is) = aivals(10,is) + one + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc end if @@ -2369,8 +2365,7 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & do i=1,nchanl if (ts(i) > 0.2_r_kind) then ! QC3 in statsrad - if(luse .and. varinv(i) > zero) & - aivals(10,is) = aivals(10,is) + one + if(luse .and. varinv(i) > zero) aivals(10,is) = aivals(10,is) + one varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_sfcir_qc end if @@ -2435,75 +2430,68 @@ subroutine qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse,goessndr, & if(hirs) then do i=1,nchanl m=ich(i) - if (iomg_det(m) > 0 .and. i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!90S-60S - if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif -!60S-30S - else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + if(iomg_det(m) > 0 .and. i >= 4 .and. i <= 12)then + if (i < 4 .and. abs(tbcnob(8)) > 40.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + else if(i == 12 .and. abs(tbcnob(8)) > 10.0_r_kind) then varinv(i) = zero if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det endif +!90S-60S + if(cenlat >= -90.0_r_kind .and. cenlat < -60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 12.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 6.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 4.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif +!60S-30S + else if(cenlat >= -60.0_r_kind .and. cenlat < -30.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 10.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if( i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.5_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30S-30N - else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif + else if(cenlat >= -30.0_r_kind .and. cenlat < 30.0_r_kind ) then + if(i == 4 .and. abs(tbcnob(8)) > 5.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. (tbcnob(8) < -2.0_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. (tbcnob(8) < -1.5_r_kind .or. tbcnob(8) > 3.0_r_kind)) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif !30N-60N - else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then - if(iomg_det(m) > 0 .and. i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - if(iomg_det(m) > 0 .and. i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then - varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det - endif - endif !cenlat + else if(cenlat >= 30.0_r_kind .and. cenlat < 60.0_r_kind) then + if(i == 4 .and. abs(tbcnob(8)) > 8.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 5 .and. abs(tbcnob(8)) > 2.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + else if(i == 6 .and. abs(tbcnob(8)) > 1.0_r_kind) then + varinv(i) = zero + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_iomg_det + endif + endif !cenlat + end if if (itopo_det(m) > 0 .and. zsges > 1500.0_r_kind) then varinv(i) = zero - if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det + if ( id_qc(i) == igood_qc ) id_qc(i) = ifail_itopo_det endif end do endif !! if (hirs) @@ -2990,13 +2978,11 @@ subroutine qc_amsua(nchanl,is,ndat,nsig,npred,sea,land,ice,snow,mixed,luse, & dsval=((2.41_r_kind-0.0098_r_kind*tb_obsbc1)*tbc(ich238) + & 0.454_r_kind*tbc(ich314)-tbc(ich890))*w1f6 dsval=max(zero,dsval) - end if - - if(sea)then clwx=cosza*clw*w1f4 else clwx=0.6_r_kind end if + ! QC6 in statsrad if(clwx >= one .and. luse)aivals(13,is) = aivals(13,is) + one factch4=clwx**2+(tbc(ich528)*w2f4)**2 diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index 8bfb015d1..ffc464169 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -1741,7 +1741,7 @@ subroutine init_predx if (.not. (any(inew_rad) .or. any(update_tlapmean))) return if (ndat==0) return - if (mype==0) write(6,*) 'INIT_PREDX: enter routine' +! if (mype==0) write(6,*) 'INIT_PREDX: enter routine' ! Allocate and initialize data arrays if (any(update_tlapmean)) then diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index 9f5efb530..47b675b3a 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -511,10 +511,10 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& ALLOCATE(Relative_Time_In_Seconds(Num_Obs)) ALLOCATE(IScan(Num_Obs)) Relative_Time_In_Seconds = 3600.0_r_kind*T4DV_Save(1:Num_Obs) - write(6,*) 'Calling ATMS_Spatial_Average' +! write(6,*) 'Calling ATMS_Spatial_Average' CALL ATMS_Spatial_Average(Num_Obs, NChanl, IFOV_Save(1:Num_Obs), & Relative_Time_In_Seconds, BT_Save(1:nchanl,1:Num_Obs), IScan, IRet) - write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet +! write(6,*) 'ATMS_Spatial_Average Called with IRet=',IRet DEALLOCATE(Relative_Time_In_Seconds) IF (IRet /= 0) THEN diff --git a/src/gsi/read_bufrtovs.f90 b/src/gsi/read_bufrtovs.f90 index 0aed801ee..0c954c7c1 100644 --- a/src/gsi/read_bufrtovs.f90 +++ b/src/gsi/read_bufrtovs.f90 @@ -228,7 +228,7 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& real(r_kind),allocatable,dimension(:,:):: data_all real(crtm_kind),allocatable,dimension(:):: data1b4 - real(r_double),allocatable,dimension(:):: data1b8,data1b8x + real(r_double),allocatable,dimension(:):: data1b8 real(r_double),dimension(n1bhdr):: bfr1bhdr real(r_double),dimension(n2bhdr):: bfr2bhdr @@ -519,7 +519,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! support multiple spc coefficient files for any given sensor if(amsua .or. amsub .or. mhs)then quiet=.not.verbose - allocate(data1b8x(nchanl)) spc_coeff_versions = 0 spc_coeff_found = .true. do while (spc_coeff_found) @@ -748,13 +747,15 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! unless the satellite is n15 or n16, because tranamsua ! does this conversion because the coefficient files exist ! for it to use - data1b8x=data1b8 data1b4=data1b8 !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if else ! EARS / DB @@ -766,14 +767,16 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& ! data originator, ! then convert back to brightness temperature using the version ! of parameters used by the CRTM - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(sacv),ifov,data1b4) !call apply_antcorr(accoeff_sets(spc_coeff_versions),ifov,data1b4) call apply_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000) data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000) then + data1b8(j) = 1000000._r_kind + else + data1b8(j)=data1b4(j) + end if end do end if end if @@ -785,12 +788,14 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& else ! EARS / DB call ufbrep(lnbufr,data1b8,1,nchanl,iret,'TMBRST') if ( amsua .or. amsub .or. mhs )then - data1b8x=data1b8 data1b4=data1b8 call remove_antcorr(accoeff_sets(1),ifov,data1b4) - data1b8=data1b4 do j=1,nchanl - if(data1b8x(j) > r1000)data1b8(j) = 1000000._r_kind + if(data1b8(j) > r1000)then + data1b8(j) = 1000000._r_kind + else + data1b8(j) = data1b4(j) + end if end do end if end if @@ -1053,8 +1058,6 @@ subroutine read_bufrtovs(mype,val_tovs,ithin,isfcalc,& call closbf(lnbufr) close(lnbufr) - if (allocated(data1b8x)) deallocate(data1b8x) - end do ears_db_loop deallocate(data1b8,data1b4) diff --git a/src/gsi/read_gps.f90 b/src/gsi/read_gps.f90 index 3d8379ee3..c0cef658a 100644 --- a/src/gsi/read_gps.f90 +++ b/src/gsi/read_gps.f90 @@ -368,8 +368,7 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & good=.true. if((abs(rlat)>90._r_kind).or.(abs(rlon)>r360).or.(height<=zero)) then good=.false. - endif - if (ref_obs) then + else if (ref_obs) then if ((ref>=1.e+9_r_kind).or.(ref<=zero).or.(height>=1.e+9_r_kind)) then good=.false. endif @@ -466,8 +465,9 @@ subroutine read_gps(nread,ndata,nodata,infile,lunout,obstype,twind, & write(6,*)'READ_GPS: # bad or missing data=', notgood do i=1,ngpsro_type if (nmrecs_id(i)>0) & - write(6,1020)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) + write(6,1021)'READ_GPS: LEO_id,nprof_gps = ',gpsro_itype(i),nmrecs_id(i) end do +1021 format(a31,i6,i6) write(6,1020)'READ_GPS: ref_obs,nprof_gps= ',ref_obs,nprof_gps 1020 format(a31,L,i6) diff --git a/src/gsi/read_iasi.f90 b/src/gsi/read_iasi.f90 index 367c22450..d0a3793b4 100644 --- a/src/gsi/read_iasi.f90 +++ b/src/gsi/read_iasi.f90 @@ -175,7 +175,6 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& character(len=4) :: senname character(len=80) :: allspotlist character(len=40) :: infile2 - integer(i_kind) :: jstart integer(i_kind) :: iret,ireadsb,ireadmg,irec,next, nrec_startx integer(i_kind),allocatable,dimension(:) :: nrec @@ -202,6 +201,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& real(r_kind),dimension(0:3) :: ts real(r_kind),dimension(10) :: sscale real(crtm_kind),allocatable,dimension(:) :: temperature + real(r_kind),allocatable,dimension(:) :: scalef real(r_kind),allocatable,dimension(:,:):: data_all real(r_kind) cdist,disterr,disterrmax,dlon00,dlat00 @@ -238,7 +238,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& integer(i_kind),parameter :: ilon = 3 integer(i_kind),parameter :: ilat = 4 real(r_kind) :: ptime,timeinflat,crit0 - integer(i_kind) :: ithin_time,n_tbin,it_mesh + integer(i_kind) :: ithin_time,n_tbin,it_mesh,jstart logical print_verbose print_verbose=.false. @@ -396,6 +396,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& allocate(temperature(1)) ! dependent on # of channels in the bufr file allocate(allchan(2,1)) ! actual values set after ireadsb allocate(bufr_chan_test(1))! actual values set after ireadsb + allocate(scalef(1)) ! Big loop to read data file next=0 @@ -442,10 +443,11 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& bufr_size = size(temperature,1) if ( bufr_size /= bufr_nchan ) then ! Re-allocation if number of channels has changed ! Allocate the arrays needed for the channel and radiance array - deallocate(temperature,allchan,bufr_chan_test) + deallocate(temperature,allchan,bufr_chan_test,scalef) allocate(temperature(bufr_nchan)) ! dependent on # of channels in the bufr file allocate(allchan(2,bufr_nchan)) allocate(bufr_chan_test(bufr_nchan)) + allocate(scalef(bufr_nchan)) bufr_chan_test(:)=0 endif ! allocation if @@ -675,6 +677,18 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Read IASI channel number(CHNM) and radiance (SCRA) call ufbseq(lnbufr,allchan,2,bufr_nchan,iret,'IASICHN') + jstart=1 + scalef=one + do i=1,bufr_nchan + scaleloop: do j=jstart,10 + if(allchan(1,i) >= cscale(1,j) .and. allchan(1,i) <= cscale(2,j))then + scalef(i) = sscale(j) + jstart=j + exit scaleloop + end if + end do scaleloop + end do + if (iret /= bufr_nchan) then write(6,*)'READ_IASI: ### ERROR IN READING ', senname, ' BUFR DATA:', & iret, ' CH DATA IS READ INSTEAD OF ',bufr_nchan @@ -703,52 +717,49 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& cycle read_loop endif - iskip = 0 - jstart=1 +!$omp parallel do schedule(dynamic,1) private(i,sc_chan,bufr_chan,radiance) channel_loop: do i=1,satinfo_nchan - sc_chan = sc_index(i) - if ( bufr_index(i) == 0 ) cycle channel_loop bufr_chan = bufr_index(i) + if (bufr_chan /= 0 ) then ! check that channel number is within reason - if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds - radiance = allchan(2,bufr_chan) - scaleloop: do j=jstart,10 - if(allchan(1,bufr_chan) >= cscale(1,j) .and. allchan(1,bufr_chan) <= cscale(2,j))then - radiance = allchan(2,bufr_chan)*sscale(j) - jstart=j - exit scaleloop - end if - end do scaleloop - call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + if (( allchan(2,bufr_chan) > zero .and. allchan(2,bufr_chan) < 99999._r_kind)) then ! radiance bounds + radiance = allchan(2,bufr_chan)*scalef(bufr_chan) + sc_chan = sc_index(i) + call crtm_planck_temperature(sensorindex,sc_chan,radiance,temperature(bufr_chan)) + else + temperature(bufr_chan) = tbmin + endif else temperature(bufr_chan) = tbmin - endif + end if end do channel_loop ! Check for reasonable temperature values + iskip = 0 skip_loop: do i=1,satinfo_nchan if ( bufr_index(i) == 0 ) cycle skip_loop bufr_chan = bufr_index(i) if(temperature(bufr_chan) <= tbmin .or. temperature(bufr_chan) > tbmax ) then - temperature(bufr_chan) = min(tbmax,max(zero,temperature(bufr_chan))) + temperature(bufr_chan) = min(tbmax,max(tbmin,temperature(bufr_chan))) if(iuse_rad(ioff+i) >= 0)iskip = iskip + 1 endif end do skip_loop - if(iskip > 0 .and. print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip - if( iskip > 0 )cycle read_loop + if(iskip > 0)then + if(print_verbose)write(6,*) ' READ_IASI : iskip > 0 ',iskip + cycle read_loop + end if - crit1=crit1 + ten*float(iskip) +! crit1=crit1 + ten*float(iskip) ! If the surface channel exists (~960.0 cm-1) and the AVHRR cloud information is missing, use an ! estimate of the surface temperature to determine if the profile may be clear. if (.not. cloud_info) then pred = tsavg*0.98_r_kind - temperature(sfc_channel_index) pred = max(pred,zero) + crit1=crit1 + pred endif - crit1=crit1 + pred - ! Map obs to grids if (pred == zero) then call finalcheck(dist1,crit1,itx,iuse) @@ -818,11 +829,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& ! Put satinfo defined channel temperatures into data array do l=1,satinfo_nchan i = bufr_index(l) - if ( bufr_index(l) /= 0 ) then - data_all(l+nreal,itx) = temperature(i) ! brightness temerature - else - data_all(l+nreal,itx) = tbmin - endif + data_all(l+nreal,itx) = temperature(i) ! brightness temerature end do nrec(itx)=irec @@ -835,7 +842,7 @@ subroutine read_iasi(mype,val_iasi,ithin,isfcalc,rmesh,jsatid,gstime,& end do ears_db_loop - deallocate(temperature, allchan, bufr_chan_test) + deallocate(temperature, allchan, bufr_chan_test,scalef) deallocate(channel_number,sc_index) deallocate(bufr_index) ! deallocate crtm info diff --git a/src/gsi/read_obs.F90 b/src/gsi/read_obs.F90 index 53b072395..9017c498c 100644 --- a/src/gsi/read_obs.F90 +++ b/src/gsi/read_obs.F90 @@ -221,9 +221,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) lexist=.false. end if if(lexist)then - if(jsatid == '')then - kidsat=0 - else if(jsatid == 'metop-a')then + kidsat=0 + if(jsatid == 'metop-a')then kidsat=4 else if(jsatid == 'metop-b')then kidsat=3 @@ -335,8 +334,6 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) ! kidsat = 288 else if ( jsatid == 'meghat' ) then kidsat = 440 - else - kidsat = 0 end if call closbf(lnbufr) @@ -346,8 +343,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) call datelen(10) if(kidsat /= 0)then - lexist = .false. - satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) + lexist = .false. + satloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) if(ireadsb(lnbufr)==0)then call ufbint(lnbufr,satid,1,1,iret,'SAID') end if @@ -356,8 +353,8 @@ subroutine read_obs_check (lexist,filename,jsatid,dtype,minuse,nread) exit satloop end if nread = nread + 1 - end do satloop - else if(trim(filename) == 'prepbufr')then ! RTod: wired-in filename is not a good idea + end do satloop + else if(trim(filename) == 'prepbufr')then lexist = .false. fileloop: do while(ireadmg(lnbufr,subset,idate2) >= 0) do while(ireadsb(lnbufr)>=0) diff --git a/src/gsi/read_satwnd.f90 b/src/gsi/read_satwnd.f90 index c67d5a7e1..7a372b9e1 100644 --- a/src/gsi/read_satwnd.f90 +++ b/src/gsi/read_satwnd.f90 @@ -1206,7 +1206,7 @@ subroutine read_satwnd(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis else if(itype==240 .or. itype==245 .or. itype==246 .or. itype==251) then ! types 245 and 246 have been used to determine the acceptable pct1 range, but that pct1 range is applied to all GOES-R winds - if (pct1 < 0.04_r_kind) qm=15 + if (pct1 < 0.04_r_kind) qm=15 if (pct1 > 0.50_r_kind) qm=15 endif endif diff --git a/src/gsi/setupcldtot.F90 b/src/gsi/setupcldtot.F90 index 3d899d1a8..a30ef92a9 100755 --- a/src/gsi/setupcldtot.F90 +++ b/src/gsi/setupcldtot.F90 @@ -90,7 +90,7 @@ subroutine setupcldtot(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_di integer(i_kind) ,intent(in ) :: lunin,mype,nele,nobs real(r_kind),dimension(100+7*nsig) ,intent(inout) :: awork real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork - integer(i_kind) ,intent(in ) :: is ! ndat index + integer(i_kind) ,intent(in ) :: is ! ndat index logical ,intent(in ) :: conv_diagsave #ifdef RR_CLOUDANALYSIS diff --git a/src/gsi/setuppcp.f90 b/src/gsi/setuppcp.f90 index 970bc5b9a..8a6c8c0d8 100644 --- a/src/gsi/setuppcp.f90 +++ b/src/gsi/setuppcp.f90 @@ -223,7 +223,7 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& character(12) string character(128) diag_pcp_file - integer(i_kind) km1,mm1,iiflg,iextra,ireal + integer(i_kind) km1,mm1,iextra,ireal integer(i_kind) ii,i,j,k,m,n,ibin,ioff,ioff0 integer(i_kind) ipt integer(i_kind) nsphys,ixp,iyp,ixx,iyy @@ -325,7 +325,6 @@ subroutine setuppcp(obsLL,odiagLL,lunin,mype,aivals,nele,nobs,& ! ONE TIME, INITIAL SETUP PRIOR TO PROCESSING SATELLITE DATA ! ! Initialize variables - iiflg = 1 ncloud = ncld nsphys = max(int(two*deltim/dtphys+0.9999_r_kind),1) dtp = two*deltim/nsphys diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 479d27af9..faa79f0ef 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -404,7 +404,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind),dimension(nchanl):: tcc real(r_kind) :: ptau5deriv, ptau5derivmax real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg - real(r_kind) :: tnoise_save real(r_kind),dimension(:), allocatable :: rsqrtinv real(r_kind),dimension(:), allocatable :: rinvdiag real(r_kind),dimension(nchanl) :: abi2km_bc @@ -422,10 +421,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& integer(i_kind),allocatable,dimension(:) :: sc_index integer(i_kind) :: state_ind, nind, nnz - logical channel_passive + logical,dimension(jpch_rad) :: channel_passive logical,dimension(nobs):: luse integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID - integer(i_kind):: nperobs + integer(i_kind):: nperobs,ncr character(10) filex character(12) string @@ -542,6 +541,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& jc=0 do j=1,jpch_rad + channel_passive(j)=iuse_rad(j)==-1 .or. iuse_rad(j)==0 if(isis == nusis(j))then jc=jc+1 if(jc > nchanl)then @@ -560,10 +560,9 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! Set error instrument channels tnoise(jc)=varch(j) - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=varch(j) + if (passive_bc .and. channel_passive(j)) tnoise(jc)=varch(j) if (iuse_rad(j)>0) l_may_be_passive=.true. if (tnoise(jc) < 1.e4_r_kind) toss = .false. @@ -847,25 +846,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& iinstr=getindex(idnames,trim(covtype)) endif endif - do jc=1,nchanl - j=ich(jc) - - tnoise(jc)=varch(j) - - if(sea .and. (varch_sea(j)>zero)) tnoise(jc)=varch_sea(j) - if(land .and. (varch_land(j)>zero)) tnoise(jc)=varch_land(j) - if(ice .and. (varch_ice(j)>zero)) tnoise(jc)=varch_ice(j) - if(snow .and. (varch_snow(j)>zero)) tnoise(jc)=varch_snow(j) - if(mixed .and. (varch_mixed(j)>zero)) tnoise(jc)=varch_mixed(j) - tnoise_save = tnoise(jc) - - channel_passive=iuse_rad(j)==-1 .or. iuse_rad(j)==0 - if (iuse_rad(j)< -1 .or. (channel_passive .and. & - .not.rad_diagsave)) tnoise(jc)=r1e10 - if (passive_bc .and. channel_passive) tnoise(jc)=tnoise_save - if (tnoise(jc) < 1.e4_r_kind) toss = .false. - end do - ! Count data of different surface types if(luse(n))then if (mixed) then @@ -886,9 +866,30 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif + do jc=1,nchanl + j=ich(jc) + + tnoise(jc)=varch(j) + + if(mixed .and. (varch_mixed(j)>zero)) then + tnoise(jc)=varch_mixed(j) + else if(snow .and. (varch_snow(j)>zero)) then + tnoise(jc)=varch_snow(j) + else if(ice .and. (varch_ice(j)>zero)) then + tnoise(jc)=varch_ice(j) + else if(land .and. (varch_land(j)>zero)) then + tnoise(jc)=varch_land(j) + else if(sea .and. (varch_sea(j)>zero)) then + tnoise(jc)=varch_sea(j) + end if + + if (.not. (passive_bc .and. channel_passive(j))) then + if (iuse_rad(j)< -1 .or. (channel_passive(j) .and. & + .not.rad_diagsave)) tnoise(jc)=r1e10 + end if + ! Load channel data into work array. - do i = 1,nchanl - tb_obs(i) = data_s(i+nreal,n) + tb_obs(jc) = data_s(jc+nreal,n) end do @@ -996,29 +997,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsavg5=tsavg5+dtsavg endif -! If using adaptive angle dependent bias correction, update the predicctors -! for this part of bias correction. The AMSUA cloud liquid water algorithm -! uses total angle dependent bias correction for channels 1 and 2 - if (adp_anglebc) then - do i=1,nchanl - mm=ich(i) - if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then - pred(npred,i)=nadir*deg2rad - else - pred(npred,i)=data_s(iscan_ang,n) - end if - do j=2,angord - pred(npred-j+1,i)=pred(npred,i)**j - end do - cbias(nadir,mm)=zero - if (iuse_rad(mm)/=4) then - do j=1,angord - cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) - end do - end if - end do - end if - ! Compute microwave cloud liquid water or graupel water path for bias correction and QC. clw_obs=zero clw_guess_retrieval=zero @@ -1056,10 +1034,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& id_qc(1:nchanl) = ifail_cloud_qc endif endif - endif ! Screening for cold-air outbreak area (only applied to MW for now) - if (cao_check .and. radmod%lprecip) then - if(microwave .and. sea) then + if (cao_check .and. radmod%lprecip) then if(radmod%lcloud_fwd) then cao_flag = (stability < 12.0_r_kind) .and. (hwp_ratio < half) .and. (tcwv < 8.0_r_kind) if (cao_flag) then ! remove all tropospheric channels @@ -1083,10 +1059,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - cld_rbc_idx2=zero +!$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) - +! If using adaptive angle dependent bias correction, update the predicctors +! for this part of bias correction. The AMSUA cloud liquid water algorithm +! uses total angle dependent bias correction for channels 1 and 2 + if (adp_anglebc) then + if (goessndr .or. goes_img .or. ahi .or. seviri .or. ssmi .or. ssmis .or. gmi .or. abi) then + pred(npred,i)=nadir*deg2rad + else + pred(npred,i)=data_s(iscan_ang,n) + end if + do j=2,angord + pred(npred-j+1,i)=pred(npred,i)**j + end do + cbias(nadir,mm)=zero + if (iuse_rad(mm)/=4) then + do j=1,angord + cbias(nadir,mm)=cbias(nadir,mm)+predchan(npred-j+1,i)*pred(npred-j+1,i) + end do + end if + end if !***** ! COMPUTE AND APPLY BIAS CORRECTION TO SIMULATED VALUES @@ -1115,28 +1109,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if if(radmod%lcloud_fwd .and. sea) pred(3,i ) = zero - - - ! Apply bias correction - - kmax(i) = 0 - if (lwrite_peakwt .or. passive_bc) then - ptau5derivmax = -9.9e31_r_kind -! maximum of weighting function is level at which transmittance -! (ptau5) is changing the fastest. This is used for the level -! assignment (needed for vertical localization). - weightmax(i) = zero - do k=2,nsig - ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & - (log(prsltmp(k-1))-log(prsltmp(k))) ) - if (ptau5deriv > ptau5derivmax) then - ptau5derivmax = ptau5deriv - kmax(i) = k - weightmax(i) = r10*prsitmp(k) ! cb to mb. - end if - enddo - end if tlapchn(i)= (ptau5(2,i)-ptau5(1,i))*(tsavg5-tvp(2)) do k=2,nsig-1 @@ -1234,15 +1207,37 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& bias = bias+predbias(npred+2,i) cldeff_obs(i)=cldeff_obs(i) - bias ! observed cloud delta (bias corrected) endif + end do + kmax = 0 + if (lwrite_peakwt .or. passive_bc) then +!$omp parallel do schedule(dynamic,1) private(i,k,ptau5derivmax,ptau5deriv) + do i=1,nchanl + ptau5derivmax = -9.9e31_r_kind +! maximum of weighting function is level at which transmittance +! (ptau5) is changing the fastest. This is used for the level +! assignment (needed for vertical localization). + weightmax(i) = zero + do k=2,nsig + ptau5deriv = abs( (ptau5(k-1,i)-ptau5(k,i))/ & + (log(prsltmp(k-1))-log(prsltmp(k))) ) + if (ptau5deriv > ptau5derivmax) then + ptau5derivmax = ptau5deriv + kmax(i) = k + weightmax(i) = r10*prsitmp(k) ! cb to mb. + end if + enddo ! End of loop over channels - end do + end do + end if ! Compute retrieved microwave cloud liquid water and ! assign cld_rbc_idx for bias correction in allsky conditions cld_rbc_idx=one + cld_rbc_idx2=zero if (radmod%lcloud_fwd .and. radmod%ex_biascor .and. eff_area) then ierrret=0 +!$omp parallel do schedule(dynamic,1) private(i,mm,j) do i=1,nchanl mm=ich(i) tsim_bc(i)=tsim(i) @@ -1258,19 +1253,19 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& tsim_clr_bc(i)=tsim_clr_bc(i)+predbias(npred+2,i) end do - if(amsua.or.atms) call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) - if(gmi) then - call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) - call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + if(amsua.or.atms) then + call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) + else if(gmi) then + call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) end if if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & clw_guess_retrieval,clw_obs,cld_rbc_idx,ierrret) - end if -! if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested +! else if (radmod%ex_obserr=='ex_obserr2') then ! comment out for now, need to be tested ! call radiance_ex_biascor(radmod,nchanl,cldeff_obs,cldeff_fg,cld_rbc_idx) ! end if - if (radmod%ex_obserr=='ex_obserr3') then + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld_rbc_idx) end if @@ -1323,17 +1318,17 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! Assign observation error for all-sky radiances if (radmod%lcloud_fwd .and. eff_area) then - if (radmod%ex_obserr=='ex_obserr1') & + if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_obserr(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) - if (radmod%ex_obserr=='ex_obserr3') & + else if (radmod%ex_obserr=='ex_obserr3') then call radiance_ex_obserr_gmi(radmod,nchanl,clw_obs,clw_guess_retrieval,tnoise,tnoise_cld,error0) + end if end if do i=1,nchanl mm=ich(i) - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if(tnoise(i) < 1.e4_r_kind .or. (channel_passive .and. rad_diagsave) & - .or. (passive_bc .and. channel_passive))then + if(tnoise(i) < 1.e4_r_kind .or. (channel_passive(mm) .and. rad_diagsave) & + .or. (passive_bc .and. channel_passive(mm)))then varinv(i) = varinv(i)/error0(i)**2 errf(i) = error0(i) else @@ -1365,14 +1360,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do call qc_irsnd(nchanl,is,ndat,nsig,ich,sea,land,ice,snow,luse(n),goessndr, & @@ -1464,14 +1455,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if (seviri .or. abi .or. ahi) then do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1490,9 +1477,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl if((abi .or. ahi) .and. i/=2 .and. i/=3) then varinv(i)=zero - varinv_use(i)=zero - end if - if(seviri .and. i/=2) then + else if(seviri .and. i/=2) then varinv(i)=zero end if end do @@ -1500,15 +1485,15 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! ! additional qc for surface and chn7.3: use split window chns to remove opaque clouds - do i = 1,nchanl - if( (abi .or. ahi ).and. i/=2 .and. i/=3 ) then - if( varinv(i) > tiny_r_kind .and. & - (tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then - varinv(i)=zero - varinv_use(i)=zero - end if - end if - end do + if(abi .or. ahi) then + do i = 1,nchanl + if( i/=2 .and. i/=3 .and.varinv(i) > tiny_r_kind) then + if((tb_obs(7)-tb_obs(8))-(tsim(7)-tsim(8)) <= -0.75_r_kind) then + varinv(i)=zero + end if + end if + end do + end if ! ! ---------- AVRHRR -------------- @@ -1526,14 +1511,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! channels with iuse_rad=-1 or 0 are used in cloud detection. do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1549,14 +1530,10 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! NOTE: use qc_avhrr for viirs qc do i=1,nchanl m=ich(i) - if (varinv(i) < tiny_r_kind) then - varinv_use(i) = zero + if (icld_det(m)>0 .and. varinv(i) >= tiny_r_kind) then + varinv_use(i) = varinv(i) else - if ((icld_det(m)>0)) then - varinv_use(i) = varinv(i) - else - varinv_use(i) = zero - end if + varinv_use(i) = zero end if end do @@ -1570,7 +1547,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& else if( ssmi .or. amsre .or. ssmis )then - frac_sea=data_s(ifrac_sea,n) if(amsre)then bearaz= (270._r_kind-data_s(ilazi_ang,n))*deg2rad sun_zenith=data_s(iszen_ang,n)*deg2rad @@ -1675,20 +1651,29 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do if(amsua .or. atms .or. amsub .or. mhs .or. msu .or. hsb)then - if(amsua)nlev=6 - if(atms)nlev=7 - if(amsub .or. mhs)nlev=5 - if(hsb)nlev=4 - if(msu)nlev=4 + if(amsua)then + nlev=6 + else if(atms)then + nlev=7 + else if(amsub .or. mhs)then + nlev=5 + else if(hsb)then + nlev=4 + else if(msu)then + nlev=4 + end if kval=0 do i=2,nlev ! do i=1,nlev - channel_passive=iuse_rad(ich(i))==-1 .or. iuse_rad(ich(i))==0 - if (varinv(i)=1) .or. & - (passive_bc .and. channel_passive))) then + mm=ich(i) + if (varinv(i)=1) .or. & + (passive_bc .and. channel_passive(mm)))) then kval=max(i-1,kval) - if(amsub .or. hsb .or. mhs)kval=nlev - if((amsua .or. atms) .and. i <= 3)kval = zero + if(amsub .or. hsb .or. mhs)then + kval=nlev + else if((amsua .or. atms) .and. i <= 3) then + kval = zero + end if end if end do if(kval > 0)then @@ -1699,60 +1684,55 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if(amsua)then varinv(15)=zero if(id_qc(15) == igood_qc)id_qc(15)=ifail_interchan_qc - end if - if (atms) then + else if (atms) then varinv(16:18)=zero if(id_qc(16) == igood_qc)id_qc(16)=ifail_interchan_qc if(id_qc(17) == igood_qc)id_qc(17)=ifail_interchan_qc if(id_qc(18) == igood_qc)id_qc(18)=ifail_interchan_qc end if end if - end if - if(mhs.or.amsub)then - do i = 1, nchanl - m = ich(i) - if(sea .and. isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det - endif - - if(sea .and. iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det - endif - if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det - endif - - if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then - varinv(i) = zero - if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det - endif - enddo + if(mhs.or.amsub)then + do i = 1, nchanl + m = ich(i) + if(sea)then + if(isst_det(m) >0 .and. tsavg5 < 278.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_isst_det + + else if(iwndspeed_det(m)>0 .and. tsavg5 < 285.0_r_kind .and. sfc_speed > 10.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwndspeed_det + endif + end if + if(iomg_det(m) > 0 .and. abs(tbcnob(2)) > 5.0_r_kind) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_iomg_det + + else if(itopo_det(m) > 0 .and. zsges > 1000.0_r_kind ) then + varinv(i) = zero + if(id_qc(i) == igood_qc)id_qc(i)=ifail_itopo_det + endif + enddo + endif endif ! Screen out land surface types by channel. Flags are set in satinfo file. do i = 1, nchanl m = ich(i) - if(iwater_det(m) > 0 .and. sea) then + if(sea .and. iwater_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iwater_det - endif - if(isnow_det(m) > 0 .and. snow) then + else if(snow .and. isnow_det(m) > 0 ) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_isnow_det - endif - if(mixed .and. imix_det(m) > 0) then + else if(mixed .and. imix_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_imix_det - endif - if(land .and. iland_det(m) > 0) then + else if(land .and. iland_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iland_det - endif - if(ice .and. iice_det(m) > 0) then + else if(ice .and. iice_det(m) > 0) then varinv(i) = zero if(id_qc(i) == igood_qc)id_qc(i)=ifail_iice_det endif @@ -1767,39 +1747,36 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif endif - do i = 1,nchanl - ! Reject radiances for single radiance test - if (lsingleradob) then + if (lsingleradob) then + do i = 1,nchanl + ! if the channels are beyond 0.01 of oblat/oblon, specified ! in gsi namelist, or aren't of type 'oneob_type', reject if ( (abs(cenlat - oblat) > one/r100 .or. & abs(cenlon - oblon) > one/r100) .or. & obstype /= oneob_type ) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range else ! if obchan <= zero, keep all footprints, if obchan > zero, ! keep only that which has channel obchan if (i /= obchan .and. obchan > zero) then varinv(i) = zero - varinv_use(i) = zero if (id_qc(i) == igood_qc) id_qc(i) = ifail_outside_range endif endif !cenlat/lon - endif !lsingleradob - enddo + enddo + endif !lsingleradob diagadd=zero account_for_corr_obs = .false. - iii=0 varinv0=zero +!$omp parallel do schedule(dynamic,1) private(ii,m,k,asum) do ii=1,nchanl m=ich(ii) if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then - iii=iii+1 varinv0(ii)=varinv(ii) raterr2(ii)=error0(ii)**2*varinv0(ii) if (l_may_be_passive .and. .not. retrieval) then @@ -1813,6 +1790,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if end if enddo + iii=0 + do ii=1,nchanl + m=ich(ii) + if (varinv(ii)>tiny_r_kind .and. iuse_rad(m)>=1) then + iii=iii+1 + end if + end do err2 = one/error0**2 tbc0=tbc tb_obs0=tb_obs @@ -1843,18 +1827,14 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& m = ich(i) if(luse(n))then - drad = tbc0(i) - dradnob = tbcnob(i) + drad = tbc0(i)*cld_rbc_idx(i) + dradnob = tbcnob(i)*cld_rbc_idx(i) varrad = tbc(i)*varinv(i) stats(1,m) = stats(1,m) + one !number of obs -! stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) -! stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 -! stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution -! stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) - stats(3,m) = stats(3,m) + drad*cld_rbc_idx(i) !obs-mod(w_biascor) - stats(4,m) = stats(4,m) + tbc0(i)*drad*cld_rbc_idx(i)!(obs-mod(w_biascor))**2 + stats(3,m) = stats(3,m) + drad !obs-mod(w_biascor) + stats(4,m) = stats(4,m) + tbc0(i)*drad !(obs-mod(w_biascor))**2 stats(5,m) = stats(5,m) + tbc(i)*varrad !penalty contribution - stats(6,m) = stats(6,m) + dradnob*cld_rbc_idx(i) !obs-mod(w/o_biascor) + stats(6,m) = stats(6,m) + dradnob !obs-mod(w/o_biascor) if (account_for_corr_obs .and. (cor_opt ==1 .or. cor_opt ==2) ) then exp_arg = -half*tbc(i)**2 @@ -1888,7 +1868,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! summation of observation number if (newpc4pred) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if end if @@ -1899,12 +1879,11 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& ! At the end of analysis, prepare for bias correction for monitored channels ! Only "good monitoring" obs are included in J_passive calculation. - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (passive_bc .and. (jiter>miter) .and. channel_passive) then + if (passive_bc .and. (jiter>miter) .and. channel_passive(m)) then ! summation of observation number, ! skip ostats accumulation for channels without coef. initialization if (newpc4pred .and. luse(n) .and. any(predx(:,m)/=zero)) then - ostats(m) = ostats(m) + one*cld_rbc_idx(i) + ostats(m) = ostats(m) + cld_rbc_idx(i) end if iccm=iccm+1 end if @@ -1950,7 +1929,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& my_head%raterr2(icc),my_head%pred(npred,icc), & my_head%dtb_dvar(nsigradjac,icc), & my_head%ich(icc),& - my_head%icx(icc)) + my_head%icx(icc),my_head%iccerr(icc)) if(luse_obsdiag)allocate(my_head%diags(icc)) call get_ij(mm1,slats,slons,my_head%ij,my_head%wij) @@ -2018,6 +1997,13 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end if ! end of newpc4pred loop end if end do + ncr=0 + do ii=1,iii + my_head%iccerr(ii) = ncr + do mm=1,ii + ncr=ncr+1 + end do + end do my_head%nchan = iii ! profile observation count my_head%use_corr_obs=.false. @@ -2112,23 +2098,28 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& allocate(my_headm%res(iccm),my_headm%err2(iccm), & my_headm%raterr2(iccm),my_headm%pred(npred,iccm), & my_headm%ich(iccm), & - my_headm%icx(iccm)) + my_headm%icx(iccm),my_headm%iccerr(iccm)) my_headm%nchan = iccm ! profile observation count my_headm%time=dtime my_headm%luse=luse(n) my_headm%ich(:)=-1 iii=0 + ncr=0 do ii=1,nchanl m=ich(ii) - channel_passive=iuse_rad(m)==-1 .or. iuse_rad(m)==0 - if (varinv(ii)>tiny_r_kind .and. channel_passive) then + if (varinv(ii)>tiny_r_kind .and. channel_passive(m)) then iii=iii+1 my_headm%res(iii)=tbc(ii) ! obs-ges innovation my_headm%err2(iii)=one/error0(ii)**2 ! 1/(obs error)**2 (original uninflated error) my_headm%raterr2(iii)=error0(ii)**2*varinv(ii) ! (original error)/(inflated error) my_headm%icx(iii)=m ! channel index + do mm=1,ii + ncr=ncr+1 + end do + + my_headm%iccerr(iii)=ncr ! channel index do k=1,npred my_headm%pred(k,iii)=pred(k,ii)*upd_pred(k)*max(cld_rbc_idx(ii),cld_rbc_idx2(ii)) end do diff --git a/src/gsi/state_vectors.f90 b/src/gsi/state_vectors.f90 index 711043fa5..ffad280bf 100644 --- a/src/gsi/state_vectors.f90 +++ b/src/gsi/state_vectors.f90 @@ -62,7 +62,7 @@ module state_vectors use GSI_BundleMod, only : GSI_GridCreate use mpeu_util, only: gettablesize -use mpeu_util, only: gettable +use mpeu_util, only: gettable,getindex implicit none @@ -83,6 +83,8 @@ module state_vectors public svars public levels public ns2d,ns3d,nsdim + public qgpresent,qspresent,qrpresent,qipresent,qlpresent + public cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! State vector definition ! Could contain model state fields plus other fields required @@ -101,6 +103,8 @@ module state_vectors character(len=max_varname_length),allocatable,dimension(:) :: svars2d integer(i_kind) ,allocatable,dimension(:) :: levels +logical qgpresent,qspresent,qrpresent,qipresent,qlpresent +logical cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent ! ---------------------------------------------------------------------- INTERFACE PRT_STATE_NORMS @@ -245,6 +249,18 @@ subroutine init_anasv write(6,*) myname_,': 3D-STATE VARIABLES ', svars3d write(6,*) myname_,': ALL STATE VARIABLES ', svars end if +qgpresent=getindex(svars3d,'qg')>0 +qspresent=getindex(svars3d,'qs')>0 +qrpresent=getindex(svars3d,'qr')>0 +qipresent=getindex(svars3d,'qi')>0 +qlpresent=getindex(svars3d,'ql')>0 +cldchpresent=getindex(svars2d,'cldch')>0 +lcbaspresent=getindex(svars2d,'lcbas')>0 +howvpresent=getindex(svars2d,'howv')>0 +wspd10mpresent=getindex(svars2d,'wspd10m')>0 +pblhpresent=getindex(svars2d,'pblh')>0 +vispresent=getindex(svars2d,'vis')>0 +gustpresent=getindex(svars2d,'gust')>0 end subroutine init_anasv subroutine final_anasv @@ -383,59 +399,32 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) zloc=zero ! Independent part of vector -! Sum - ii=0 +! Sum,Max,Min and number of points +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns3d - ii=ii+1 if(xst%r3(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%qr4,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%qr4) + zloc(2*nvars+i)= maxval(xst%r3(i)%qr4) else - zloc(ii)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(i)= sum_mask(xst%r3(i)%q,ihalo=1) + zloc(nvars+i)= minval(xst%r3(i)%q) + zloc(2*nvars+i)= maxval(xst%r3(i)%q) endif - nloc(ii) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields + nloc(i) = real((lat2-2)*(lon2-2)*levels(i), r_kind) ! dim of 3d fields enddo +!$omp parallel do schedule(dynamic,1) !private(i) do i = 1,ns2d - ii=ii+1 if(xst%r2(i)%mykind==r_single)then - zloc(ii)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(ns3d+i)= sum_mask(xst%r2(i)%qr4,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%qr4) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%qr4) else - zloc(ii)= sum_mask(xst%r2(i)%q,ihalo=1) - endif - nloc(ii) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields - enddo -! Min - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= minval(xst%r3(i)%qr4) - else - zloc(ii)= minval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= minval(xst%r2(i)%qr4) - else - zloc(ii)= minval(xst%r2(i)%q) - endif - enddo -! Max - do i = 1,ns3d - ii=ii+1 - if(xst%r3(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r3(i)%qr4) - else - zloc(ii)= maxval(xst%r3(i)%q) - endif - enddo - do i = 1,ns2d - ii=ii+1 - if(xst%r2(i)%mykind==r_single)then - zloc(ii)= maxval(xst%r2(i)%qr4) - else - zloc(ii)= maxval(xst%r2(i)%q) + zloc(ns3d+i)= sum_mask(xst%r2(i)%q,ihalo=1) + zloc(nvars+ns3d+i)= minval(xst%r2(i)%q) + zloc(2*nvars+ns3d+i)= maxval(xst%r2(i)%q) endif + nloc(ns3d+i) = real((lat2-2)*(lon2-2), r_kind) ! dim of 2d fields enddo ! Gather contributions @@ -444,20 +433,12 @@ subroutine norms_vars(xst,pmin,pmax,psum,pnum) call mpi_allgather(nloc,size(nloc),mpi_rtype, & & nall,size(nloc),mpi_rtype, mpi_comm_world,ierror) - ii=0 - do i=1,ns3d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do i=1,ns2d - ii=ii+1 - psum(ii)=SUM(zall(ii,:)) - pnum(ii)=SUM(nall(ii,:)) - enddo - do ii=1,nvars - pmin(ii)=MINVAL(zall( nvars+ii,:)) - pmax(ii)=MAXVAL(zall(2*nvars+ii,:)) +!$omp parallel do schedule(dynamic,1) !private(i) + do i=1,nvars + psum(i)=SUM(zall(i,:)) + pnum(i)=SUM(nall(i,:)) + pmin(i)=MINVAL(zall( nvars+i,:)) + pmax(i)=MAXVAL(zall(2*nvars+i,:)) enddo ! Release work space diff --git a/src/gsi/statsconv.f90 b/src/gsi/statsconv.f90 index 7ddb7dea0..a01675d8d 100644 --- a/src/gsi/statsconv.f90 +++ b/src/gsi/statsconv.f90 @@ -154,20 +154,6 @@ subroutine statsconv(mype,& ! Summary report for winds if(mype==mype_uv) then -! Open output file so as to point to correct position in output file - if(first)then - open(iout_uv) - else - open(iout_uv,position='append') - end if - - -! Compute and write counts, penalties, and ratio of penalty -! to data counts for each model level - numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) - umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; - tu=zero; tv=zero ; tuv=zero - tssm=zero ; qctssm=zero nread=0 nkeep=0 nreadspd=0 @@ -181,85 +167,92 @@ subroutine statsconv(mype,& nkeepspd=nkeepspd+ndata(i,3) end if end do - if(nkeep > 0 .or. nkeepspd > 0)then -! Write header information - mesage='current vfit of wind data, ranges in m/s$' + if(nread > 0 .or. nreadspd > 0)then +! Open output file so as to point to correct position in output file + if(first)then + open(iout_uv) + else + open(iout_uv,position='append') + end if -! Call routine to compute and write count, rms, and penalty information - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) - numlow = nint(awork(2,i_uv)) - numhgh = nint(awork(3,i_uv)) - write(iout_uv,900) 'wind',numhgh,numlow - numfailqc=nint(awork(21,i_uv)) -! keep a seperate record of numfailqc for ssmi wind speeds - numfailqc_ssmi=nint(awork(61,i_uv)) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat2=zero - if(num(k) > 0)then - rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) - rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + +! Compute and write counts, penalties, and ratio of penalty +! to data counts for each model level + numssm=nint(awork(6,i_uv)); numgross=nint(awork(4,i_uv)) + umplty=zero; vmplty=zero; uvqcplty=zero ; ntot=0; + tu=zero; tv=zero ; tuv=zero + tssm=zero ; qctssm=zero + if(nkeep > 0 .or. nkeepspd > 0)then +! Write header information + mesage='current vfit of wind data, ranges in m/s$' + +! Call routine to compute and write count, rms, and penalty information + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'spd' .or. trim(ioctype(j)) == 'uv' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_uv,pflag) + numlow = nint(awork(2,i_uv)) + numhgh = nint(awork(3,i_uv)) + write(iout_uv,900) 'wind',numhgh,numlow + numfailqc=nint(awork(21,i_uv)) +! keep a seperate record of numfailqc for ssmi wind speeds + numfailqc_ssmi=nint(awork(61,i_uv)) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat2=zero + if(num(k) > 0)then + rat1=awork(4*nsig+k+100,i_uv)/float(num(k)) + rat2=awork(5*nsig+k+100,i_uv)/float(num(k)) + end if + umplty=umplty+awork(4*nsig+k+100,i_uv) + vmplty=vmplty+awork(5*nsig+k+100,i_uv) + ntot=ntot+num(k) + write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& + awork(5*nsig+k+100,i_uv),rat1,rat2 + end do + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_uv)) + rat1=zero + rat3=zero + if(num(k) > 0)then + rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) + rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + end if + uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) + write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & + awork(3*nsig+k+100,i_uv),rat1,rat3 + end do + +! Write statistics gross checks + write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi + write(iout_uv,925) 'wind',numgross,numfailqc +! Write statistics regarding penalties + if(ntot > 0)then + tu=umplty/float(ntot) + tv=vmplty/float(ntot) + tuv=uvqcplty/float(ntot) end if - umplty=umplty+awork(4*nsig+k+100,i_uv) - vmplty=vmplty+awork(5*nsig+k+100,i_uv) - ntot=ntot+num(k) - write(iout_uv,241) 'w',num(k),k,awork(4*nsig+k+100,i_uv),& - awork(5*nsig+k+100,i_uv),rat1,rat2 - end do - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_uv)) - rat1=zero - rat3=zero - if(num(k) > 0)then - rat1=(awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv))/float(num(k)) - rat3=awork(3*nsig+k+100,i_uv)/float(num(k)) + if(numssm > 0)then + tssm=awork(5,i_uv)/awork(6,i_uv) + qctssm=awork(22,i_uv)/awork(6,i_uv) end if - uvqcplty=uvqcplty+awork(3*nsig+k+100,i_uv) - write(iout_uv,240) 'w',num(k),k,awork(4*nsig+k+100,i_uv)+awork(5*nsig+k+100,i_uv), & - awork(3*nsig+k+100,i_uv),rat1,rat3 - end do - -! Write statistics gross checks - write(iout_uv,920)' number ssm/i winds that fail nonlinear qc =',numfailqc_ssmi - write(iout_uv,925) 'wind',numgross,numfailqc -! Write statistics regarding penalties - if(ntot > 0)then - tu=umplty/float(ntot) - tv=vmplty/float(ntot) - tuv=uvqcplty/float(ntot) end if - if(numssm > 0)then - tssm=awork(5,i_uv)/awork(6,i_uv) - qctssm=awork(22,i_uv)/awork(6,i_uv) - end if - end if - write(iout_uv,949) 'u',ntot,umplty,tu - write(iout_uv,949) 'v',ntot,vmplty,tv - write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 - write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv - write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm - write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm + write(iout_uv,949) 'u',ntot,umplty,tu + write(iout_uv,949) 'v',ntot,vmplty,tv + write(iout_uv,950) 'uv',jiter,nread,nkeep,ntot*2 + write(iout_uv,951) 'uv',umplty+vmplty,uvqcplty,tu+tv,tuv + write(iout_uv,950) 'spd',jiter,nreadspd,nkeepspd,numssm + write(iout_uv,951) 'spd',awork(5,i_uv),awork(22,i_uv),tssm,qctssm ! Close unit receiving summary output - close(iout_uv) + close(iout_uv) + end if end if ! Summary report for gps if (mype==mype_gps)then - if(first)then - open(iout_gps) - else - open(iout_gps,position='append') - end if - - - gpsmplty=zero; gpsqcplty=zero ; ntot=0 - tgps=zero ; qctgps=zero nread=0 nkeep=0 ctype=' ' @@ -270,67 +263,64 @@ subroutine statsconv(mype,& ctype=dtype(i) end if end do - if(nkeep > 0)then - mesage='current fit of gps data in fractional difference$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gps' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_gps)) - rat=zero - rat3=zero - if(num(k)>0) then - rat=awork(6*nsig+k+100,i_gps)/float(num(k)) - rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) - end if - ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) - gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) - write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & - awork(3*nsig+k+100,i_gps),rat,rat3 - end do - numgross=nint(awork(4,i_gps)) - numfailqc=nint(awork(21,i_gps)) - numfail1_gps=nint(awork(22,i_gps)) - numfail2_gps=nint(awork(23,i_gps)) - numfail3_gps=nint(awork(24,i_gps)) - write(iout_gps,925)'gps',numgross,numfailqc - write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps - write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps - write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps - - numlow = nint(awork(2,i_gps)) - numhgh = nint(awork(3,i_gps)) - write(iout_gps,900) 'gps',numhgh,numlow - if(ntot > 0) then - tgps=gpsmplty/ntot - qctgps=gpsqcplty/ntot - endif - end if + if(nread > 0)then + if(first)then + open(iout_gps) + else + open(iout_gps,position='append') + end if - write(iout_gps,950) ctype,jiter,nread,nkeep,ntot - write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps - close(iout_gps) - endif + gpsmplty=zero; gpsqcplty=zero ; ntot=0 + tgps=zero ; qctgps=zero + if(nkeep > 0)then + mesage='current fit of gps data in fractional difference$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gps' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_gps,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_gps)) + rat=zero + rat3=zero + if(num(k)>0) then + rat=awork(6*nsig+k+100,i_gps)/float(num(k)) + rat3=awork(3*nsig+k+100,i_gps)/float(num(k)) + end if + ntot=ntot+num(k); gpsmplty=gpsmplty+awork(6*nsig+k+100,i_gps) + gpsqcplty=gpsqcplty+awork(3*nsig+k+100,i_gps) + write(iout_gps,240)'gps',num(k),k,awork(6*nsig+k+100,i_gps), & + awork(3*nsig+k+100,i_gps),rat,rat3 + end do + numgross=nint(awork(4,i_gps)) + numfailqc=nint(awork(21,i_gps)) + numfail1_gps=nint(awork(22,i_gps)) + numfail2_gps=nint(awork(23,i_gps)) + numfail3_gps=nint(awork(24,i_gps)) + write(iout_gps,925)'gps',numgross,numfailqc + write(iout_gps,920)' number of gps obs failed stats qc in NH =',numfail1_gps + write(iout_gps,920)' number of gps obs failed stats qc in SH =',numfail2_gps + write(iout_gps,920)' number of gps obs failed stats qc in TR =',numfail3_gps + + numlow = nint(awork(2,i_gps)) + numhgh = nint(awork(3,i_gps)) + write(iout_gps,900) 'gps',numhgh,numlow + if(ntot > 0) then + tgps=gpsmplty/ntot + qctgps=gpsqcplty/ntot + endif + end if + write(iout_gps,950) ctype,jiter,nread,nkeep,ntot + write(iout_gps,951) ctype,gpsmplty,gpsqcplty,tgps,qctgps -! Summary report for specific humidity - if(mype==mype_q) then - if(first)then - open(iout_q) - else - open(iout_q,position='append') + close(iout_gps) end if + endif - mesage='current fit of q data, units in per-cent of guess q-sat$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'q' - end do - call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) - qmplty=zero; qqcplty=zero ; ntot=0 - tq=zero ; qctq=zero +! Summary report for specific humidity + if(mype==mype_q) then nread=0 nkeep=0 do i=1,ndat @@ -339,53 +329,61 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - do k=1,nsig - num(k)=nint(awork(k+6*nsig+100,i_q)) - rat=zero - rat3=zero - if(num(k) > 0)then - rat=awork(5*nsig+k+100,i_q)/float(num(k)) - rat3=awork(3*nsig+k+100,i_q)/float(num(k)) - end if - qmplty=qmplty+awork(5*nsig+k+100,i_q) - qqcplty=qqcplty+awork(3*nsig+k+100,i_q) - ntot=ntot+num(k) - write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & - awork(3*nsig+k+100,i_q),rat,rat3 + if(nread > 0)then + if(first)then + open(iout_q) + else + open(iout_q,position='append') + end if + + mesage='current fit of q data, units in per-cent of guess q-sat$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'q' end do - grsmlt=five - numgrsq=nint(awork(4,i_q)) - numfailqc=nint(awork(21,i_q)) - write(iout_q,924)' (scaled as precent of guess specific humidity)' - write(iout_q,925) 'q',numgrsq,numfailqc - write(iout_q,975) grsmlt,'q',awork(5,i_q) - numlow = nint(awork(2,i_q)) - numhgh = nint(awork(3,i_q)) - write(iout_q,900) 'q',numhgh,numlow - if(ntot > 0) then - tq=qmplty/float(ntot) - qctq=qqcplty/float(ntot) + call dtast(bwork,npres_print,pbotq,ptopq,mesage,jiter,iout_q,pflag) + + qmplty=zero; qqcplty=zero ; ntot=0 + tq=zero ; qctq=zero + if(nkeep > 0)then + do k=1,nsig + num(k)=nint(awork(k+6*nsig+100,i_q)) + rat=zero + rat3=zero + if(num(k) > 0)then + rat=awork(5*nsig+k+100,i_q)/float(num(k)) + rat3=awork(3*nsig+k+100,i_q)/float(num(k)) + end if + qmplty=qmplty+awork(5*nsig+k+100,i_q) + qqcplty=qqcplty+awork(3*nsig+k+100,i_q) + ntot=ntot+num(k) + write(iout_q,240) 'q',num(k),k,awork(5*nsig+k+100,i_q), & + awork(3*nsig+k+100,i_q),rat,rat3 + end do + grsmlt=five + numgrsq=nint(awork(4,i_q)) + numfailqc=nint(awork(21,i_q)) + write(iout_q,924)' (scaled as precent of guess specific humidity)' + write(iout_q,925) 'q',numgrsq,numfailqc + write(iout_q,975) grsmlt,'q',awork(5,i_q) + numlow = nint(awork(2,i_q)) + numhgh = nint(awork(3,i_q)) + write(iout_q,900) 'q',numhgh,numlow + if(ntot > 0) then + tq=qmplty/float(ntot) + qctq=qqcplty/float(ntot) + end if end if - end if - write(iout_q,950) 'q',jiter,nread,nkeep,ntot - write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq + write(iout_q,950) 'q',jiter,nread,nkeep,ntot + write(iout_q,951) 'q',qmplty,qqcplty,tq,qctq - close(iout_q) + close(iout_q) + end if end if ! Summary report for surface pressure if(mype==mype_ps) then - if(first)then - open(iout_ps) - else - open(iout_ps,position='append') - end if - - nump=nint(awork(5,i_ps)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -394,40 +392,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'ps' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) + if(nread > 0)then + if(first)then + open(iout_ps) + else + open(iout_ps,position='append') + end if + + nump=nint(awork(5,i_ps)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'ps' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_ps,pflag) - numgross=nint(awork(6,i_ps)) - numfailqc=nint(awork(21,i_ps)) - write(iout_ps,925) 'psfc',numgross,numfailqc - if(nump > 0)then - pw=awork(4,i_ps)/float(nump) - pw3=awork(22,i_ps)/float(nump) + numgross=nint(awork(6,i_ps)) + numfailqc=nint(awork(21,i_ps)) + write(iout_ps,925) 'psfc',numgross,numfailqc + if(nump > 0)then + pw=awork(4,i_ps)/float(nump) + pw3=awork(22,i_ps)/float(nump) + end if end if - end if - write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump - write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 + write(iout_ps,950) 'psfc',jiter,nread,nkeep,nump + write(iout_ps,951) 'psfc',awork(4,i_ps),awork(22,i_ps),pw,pw3 - close(iout_ps) + close(iout_ps) + end if end if ! Summary report for total precipitable water if(mype==mype_pw) then - if(first)then - open(iout_pw) - else - open(iout_pw,position='append') - end if - - nsuperp=nint(awork(4,i_pw)) - tpw=zero ; tpw3=zero nread=0 nkeep=0 do i=1,ndat @@ -436,41 +436,42 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of precip. water data, ranges in mm$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pw' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) - - numgrspw=nint(awork(6,i_pw)) - numfailqc=nint(awork(21,i_pw)) - grsmlt=three - tpw=zero - tpw3=zero - if(nsuperp > 0)then - tpw=awork(5,i_pw)/nsuperp - tpw3=awork(22,i_pw)/nsuperp - end if - write(iout_pw,925) 'p.w.',numgrspw,numfailqc - write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) - end if - write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp - write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 + if(nread > 0)then + if(first)then + open(iout_pw) + else + open(iout_pw,position='append') + end if + tpw=zero ; tpw3=zero + if(nkeep > 0)then + mesage='current fit of precip. water data, ranges in mm$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pw' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pw,pflag) + + numgrspw=nint(awork(6,i_pw)) + numfailqc=nint(awork(21,i_pw)) + grsmlt=three + tpw=zero + tpw3=zero + nsuperp=nint(awork(4,i_pw)) + if(nsuperp > 0)then + tpw=awork(5,i_pw)/nsuperp + tpw3=awork(22,i_pw)/nsuperp + end if + write(iout_pw,925) 'p.w.',numgrspw,numfailqc + write(iout_pw,975) grsmlt,'p.w.',awork(7,i_pw) + end if + write(iout_pw,950) 'pw',jiter,nread,nkeep,nsuperp + write(iout_pw,951) 'pw',awork(5,i_pw),awork(22,i_pw),tpw,tpw3 - close(iout_pw) + close(iout_pw) + end if end if ! Summary report for conventional sst if(mype==mype_sst) then - if(first)then - open(iout_sst) - else - open(iout_sst,position='append') - end if - - numsst=nint(awork(5,i_sst)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -479,37 +480,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional sst data, ranges in C$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'sst' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + if(nread > 0)then + if(first)then + open(iout_sst) + else + open(iout_sst,position='append') + end if - numgross=nint(awork(6,i_sst)) - numfailqc=nint(awork(21,i_sst)) - if(numsst > 0)then - pw=awork(4,i_sst)/numsst - pw3=awork(22,i_sst)/numsst + numsst=nint(awork(5,i_sst)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional sst data, ranges in C$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'sst' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_sst,pflag) + + numgross=nint(awork(6,i_sst)) + numfailqc=nint(awork(21,i_sst)) + if(numsst > 0)then + pw=awork(4,i_sst)/numsst + pw3=awork(22,i_sst)/numsst + end if + write(iout_sst,925) 'sst',numgross,numfailqc end if - write(iout_sst,925) 'sst',numgross,numfailqc - end if - write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst - write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 + write(iout_sst,950) 'sst',jiter,nread,nkeep,numsst + write(iout_sst,951) 'sst',awork(4,i_sst),awork(22,i_sst),pw,pw3 - close(iout_sst) + close(iout_sst) + end if end if ! Summary report for conventional gust if(mype==mype_gust) then - if(first)then - open(iout_gust) - else - open(iout_gust,position='append') - end if - - numgust=nint(awork(5,i_gust)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -518,37 +521,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional gust data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'gust' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + if(nread > 0)then + if(first)then + open(iout_gust) + else + open(iout_gust,position='append') + end if - numgross=nint(awork(6,i_gust)) - numfailqc=nint(awork(21,i_gust)) - if(numgust > 0)then - pw=awork(4,i_gust)/numgust - pw3=awork(22,i_gust)/numgust + numgust=nint(awork(5,i_gust)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional gust data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'gust' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_gust,pflag) + + numgross=nint(awork(6,i_gust)) + numfailqc=nint(awork(21,i_gust)) + if(numgust > 0)then + pw=awork(4,i_gust)/numgust + pw3=awork(22,i_gust)/numgust + end if + write(iout_gust,925) 'gust',numgross,numfailqc end if - write(iout_gust,925) 'gust',numgross,numfailqc - end if - write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust - write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 + write(iout_gust,950) 'gust',jiter,nread,nkeep,numgust + write(iout_gust,951) 'gust',awork(4,i_gust),awork(22,i_gust),pw,pw3 - close(iout_gust) + close(iout_gust) + end if end if ! Summary report for conventional vis if(mype==mype_vis) then - if(first)then - open(iout_vis) - else - open(iout_vis,position='append') - end if - - numvis=nint(awork(5,i_vis)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -557,37 +562,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vis data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vis' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + if(nread > 0)then + if(first)then + open(iout_vis) + else + open(iout_vis,position='append') + end if - numgross=nint(awork(6,i_vis)) - numfailqc=nint(awork(21,i_vis)) - if(numvis > 0)then - pw=awork(4,i_vis)/numvis - pw3=awork(22,i_vis)/numvis + numvis=nint(awork(5,i_vis)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vis data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vis' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vis,pflag) + + numgross=nint(awork(6,i_vis)) + numfailqc=nint(awork(21,i_vis)) + if(numvis > 0)then + pw=awork(4,i_vis)/numvis + pw3=awork(22,i_vis)/numvis + end if + write(iout_vis,925) 'vis',numgross,numfailqc end if - write(iout_vis,925) 'vis',numgross,numfailqc - end if - write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis - write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 + write(iout_vis,950) 'vis',jiter,nread,nkeep,numvis + write(iout_vis,951) 'vis',awork(4,i_vis),awork(22,i_vis),pw,pw3 - close(iout_vis) + close(iout_vis) + end if end if ! Summary report for conventional pblh if(mype==mype_pblh) then - if(first)then - open(iout_pblh) - else - open(iout_pblh,position='append') - end if - - numpblh=nint(awork(5,i_pblh)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -596,37 +603,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pblh data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pblh' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + if(nread > 0)then + if(first)then + open(iout_pblh) + else + open(iout_pblh,position='append') + end if - numgross=nint(awork(6,i_pblh)) - numfailqc=nint(awork(21,i_pblh)) - if(numpblh > 0)then - pw=awork(4,i_pblh)/numpblh - pw3=awork(22,i_pblh)/numpblh + numpblh=nint(awork(5,i_pblh)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pblh data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pblh' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pblh,pflag) + + numgross=nint(awork(6,i_pblh)) + numfailqc=nint(awork(21,i_pblh)) + if(numpblh > 0)then + pw=awork(4,i_pblh)/numpblh + pw3=awork(22,i_pblh)/numpblh + end if + write(iout_pblh,925) 'pblh',numgross,numfailqc end if - write(iout_pblh,925) 'pblh',numgross,numfailqc - end if - write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh - write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 + write(iout_pblh,950) 'pblh',jiter,nread,nkeep,numpblh + write(iout_pblh,951) 'pblh',awork(4,i_pblh),awork(22,i_pblh),pw,pw3 - close(iout_pblh) + close(iout_pblh) + end if end if ! Summary report for conventional wspd10m if(mype==mype_wspd10m) then - if(first)then - open(iout_wspd10m) - else - open(iout_wspd10m,position='append') - end if - - numwspd10m=nint(awork(5,i_wspd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -635,37 +644,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional wspd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'wspd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_wspd10m) + else + open(iout_wspd10m,position='append') + end if - numgross=nint(awork(6,i_wspd10m)) - numfailqc=nint(awork(21,i_wspd10m)) - if(numwspd10m > 0)then - pw=awork(4,i_wspd10m)/numwspd10m - pw3=awork(22,i_wspd10m)/numwspd10m + numwspd10m=nint(awork(5,i_wspd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional wspd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'wspd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_wspd10m,pflag) + + numgross=nint(awork(6,i_wspd10m)) + numfailqc=nint(awork(21,i_wspd10m)) + if(numwspd10m > 0)then + pw=awork(4,i_wspd10m)/numwspd10m + pw3=awork(22,i_wspd10m)/numwspd10m + end if + write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc end if - write(iout_wspd10m,925) 'wspd10m',numgross,numfailqc - end if - write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m - write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 + write(iout_wspd10m,950) 'wspd10m',jiter,nread,nkeep,numwspd10m + write(iout_wspd10m,951) 'wspd10m',awork(4,i_wspd10m),awork(22,i_wspd10m),pw,pw3 - close(iout_wspd10m) + close(iout_wspd10m) + end if end if ! Summary report for conventional td2m if(mype==mype_td2m) then - if(first)then - open(iout_td2m) - else - open(iout_td2m,position='append') - end if - - numtd2m=nint(awork(5,i_td2m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -674,37 +685,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional td2m data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'td2m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + if(nread > 0)then + if(first)then + open(iout_td2m) + else + open(iout_td2m,position='append') + end if - numgross=nint(awork(6,i_td2m)) - numfailqc=nint(awork(21,i_td2m)) - if(numtd2m > 0)then - pw=awork(4,i_td2m)/numtd2m - pw3=awork(22,i_td2m)/numtd2m + numtd2m=nint(awork(5,i_td2m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional td2m data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'td2m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_td2m,pflag) + + numgross=nint(awork(6,i_td2m)) + numfailqc=nint(awork(21,i_td2m)) + if(numtd2m > 0)then + pw=awork(4,i_td2m)/numtd2m + pw3=awork(22,i_td2m)/numtd2m + end if + write(iout_td2m,925) 'td2m',numgross,numfailqc end if - write(iout_td2m,925) 'td2m',numgross,numfailqc - end if - write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m - write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 + write(iout_td2m,950) 'td2m',jiter,nread,nkeep,numtd2m + write(iout_td2m,951) 'td2m',awork(4,i_td2m),awork(22,i_td2m),pw,pw3 - close(iout_td2m) + close(iout_td2m) + end if end if ! Summary report for conventional mxtm if(mype==mype_mxtm) then - if(first)then - open(iout_mxtm) - else - open(iout_mxtm,position='append') - end if - - nummxtm=nint(awork(5,i_mxtm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -713,37 +726,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mxtm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mxtm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + if(nread > 0)then + if(first)then + open(iout_mxtm) + else + open(iout_mxtm,position='append') + end if - numgross=nint(awork(6,i_mxtm)) - numfailqc=nint(awork(21,i_mxtm)) - if(nummxtm > 0)then - pw=awork(4,i_mxtm)/nummxtm - pw3=awork(22,i_mxtm)/nummxtm + nummxtm=nint(awork(5,i_mxtm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mxtm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mxtm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mxtm,pflag) + + numgross=nint(awork(6,i_mxtm)) + numfailqc=nint(awork(21,i_mxtm)) + if(nummxtm > 0)then + pw=awork(4,i_mxtm)/nummxtm + pw3=awork(22,i_mxtm)/nummxtm + end if + write(iout_mxtm,925) 'mxtm',numgross,numfailqc end if - write(iout_mxtm,925) 'mxtm',numgross,numfailqc - end if - write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm - write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 + write(iout_mxtm,950) 'mxtm',jiter,nread,nkeep,nummxtm + write(iout_mxtm,951) 'mxtm',awork(4,i_mxtm),awork(22,i_mxtm),pw,pw3 - close(iout_mxtm) + close(iout_mxtm) + end if end if ! Summary report for conventional mitm if(mype==mype_mitm) then - if(first)then - open(iout_mitm) - else - open(iout_mitm,position='append') - end if - - nummitm=nint(awork(5,i_mitm)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -752,37 +767,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional mitm data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'mitm' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + if(nread > 0)then + if(first)then + open(iout_mitm) + else + open(iout_mitm,position='append') + end if - numgross=nint(awork(6,i_mitm)) - numfailqc=nint(awork(21,i_mitm)) - if(nummitm > 0)then - pw=awork(4,i_mitm)/nummitm - pw3=awork(22,i_mitm)/nummitm + nummitm=nint(awork(5,i_mitm)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional mitm data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'mitm' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_mitm,pflag) + + numgross=nint(awork(6,i_mitm)) + numfailqc=nint(awork(21,i_mitm)) + if(nummitm > 0)then + pw=awork(4,i_mitm)/nummitm + pw3=awork(22,i_mitm)/nummitm + end if + write(iout_mitm,925) 'mitm',numgross,numfailqc end if - write(iout_mitm,925) 'mitm',numgross,numfailqc - end if - write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm - write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 + write(iout_mitm,950) 'mitm',jiter,nread,nkeep,nummitm + write(iout_mitm,951) 'mitm',awork(4,i_mitm),awork(22,i_mitm),pw,pw3 - close(iout_mitm) + close(iout_mitm) + end if end if ! Summary report for conventional pmsl if(mype==mype_pmsl) then - if(first)then - open(iout_pmsl) - else - open(iout_pmsl,position='append') - end if - - numpmsl=nint(awork(5,i_pmsl)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -791,37 +808,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional pmsl data, ranges in hPa $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'pmsl' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + if(nread > 0)then + if(first)then + open(iout_pmsl) + else + open(iout_pmsl,position='append') + end if - numgross=nint(awork(6,i_pmsl)) - numfailqc=nint(awork(21,i_pmsl)) - if(numpmsl > 0)then - pw=awork(4,i_pmsl)/numpmsl - pw3=awork(22,i_pmsl)/numpmsl + numpmsl=nint(awork(5,i_pmsl)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional pmsl data, ranges in hPa $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'pmsl' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_pmsl,pflag) + + numgross=nint(awork(6,i_pmsl)) + numfailqc=nint(awork(21,i_pmsl)) + if(numpmsl > 0)then + pw=awork(4,i_pmsl)/numpmsl + pw3=awork(22,i_pmsl)/numpmsl + end if + write(iout_pmsl,925) 'pmsl',numgross,numfailqc end if - write(iout_pmsl,925) 'pmsl',numgross,numfailqc - end if - write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl - write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 + write(iout_pmsl,950) 'pmsl',jiter,nread,nkeep,numpmsl + write(iout_pmsl,951) 'pmsl',awork(4,i_pmsl),awork(22,i_pmsl),pw,pw3 - close(iout_pmsl) + close(iout_pmsl) + end if end if ! Summary report for conventional howv if(mype==mype_howv) then - if(first)then - open(iout_howv) - else - open(iout_howv,position='append') - end if - - numhowv=nint(awork(5,i_howv)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -830,37 +849,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional howv data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'howv' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + if(nread > 0)then + if(first)then + open(iout_howv) + else + open(iout_howv,position='append') + end if - numgross=nint(awork(6,i_howv)) - numfailqc=nint(awork(21,i_howv)) - if(numhowv > 0)then - pw=awork(4,i_howv)/numhowv - pw3=awork(22,i_howv)/numhowv + numhowv=nint(awork(5,i_howv)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional howv data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'howv' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_howv,pflag) + + numgross=nint(awork(6,i_howv)) + numfailqc=nint(awork(21,i_howv)) + if(numhowv > 0)then + pw=awork(4,i_howv)/numhowv + pw3=awork(22,i_howv)/numhowv + end if + write(iout_howv,925) 'howv',numgross,numfailqc end if - write(iout_howv,925) 'howv',numgross,numfailqc - end if - write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv - write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 + write(iout_howv,950) 'howv',jiter,nread,nkeep,numhowv + write(iout_howv,951) 'howv',awork(4,i_howv),awork(22,i_howv),pw,pw3 - close(iout_howv) + close(iout_howv) + end if end if ! Summary report for tcamt if(mype==mype_tcamt) then - if(first)then - open(iout_tcamt) - else - open(iout_tcamt,position='append') - end if - - numtcamt=nint(awork(5,i_tcamt)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -869,37 +890,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional tcamt data, ranges in %$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcamt' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + if(nread > 0)then + if(first)then + open(iout_tcamt) + else + open(iout_tcamt,position='append') + end if - numgross=nint(awork(6,i_tcamt)) - numfailqc=nint(awork(21,i_tcamt)) - if(numtcamt > 0)then - pw=awork(4,i_tcamt)/numtcamt - pw3=awork(22,i_tcamt)/numtcamt + numtcamt=nint(awork(5,i_tcamt)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional tcamt data, ranges in %$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcamt' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcamt,pflag) + + numgross=nint(awork(6,i_tcamt)) + numfailqc=nint(awork(21,i_tcamt)) + if(numtcamt > 0)then + pw=awork(4,i_tcamt)/numtcamt + pw3=awork(22,i_tcamt)/numtcamt + end if + write(iout_tcamt,925) 'tcamt',numgross,numfailqc end if - write(iout_tcamt,925) 'tcamt',numgross,numfailqc - end if - write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt - write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 + write(iout_tcamt,950) 'tcamt',jiter,nread,nkeep,numtcamt + write(iout_tcamt,951) 'tcamt',awork(4,i_tcamt),awork(22,i_tcamt),pw,pw3 - close(iout_tcamt) + close(iout_tcamt) + end if end if ! Summary report for lcbas if(mype==mype_lcbas) then - if(first)then - open(iout_lcbas) - else - open(iout_lcbas,position='append') - end if - - numlcbas=nint(awork(5,i_lcbas)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -908,37 +931,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional lcbas data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lcbas' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + if(nread > 0)then + if(first)then + open(iout_lcbas) + else + open(iout_lcbas,position='append') + end if - numgross=nint(awork(6,i_lcbas)) - numfailqc=nint(awork(21,i_lcbas)) - if(numlcbas > 0)then - pw=awork(4,i_lcbas)/numlcbas - pw3=awork(22,i_lcbas)/numlcbas + numlcbas=nint(awork(5,i_lcbas)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional lcbas data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lcbas' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lcbas,pflag) + + numgross=nint(awork(6,i_lcbas)) + numfailqc=nint(awork(21,i_lcbas)) + if(numlcbas > 0)then + pw=awork(4,i_lcbas)/numlcbas + pw3=awork(22,i_lcbas)/numlcbas + end if + write(iout_lcbas,925) 'lcbas',numgross,numfailqc end if - write(iout_lcbas,925) 'lcbas',numgross,numfailqc - end if - write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas - write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 + write(iout_lcbas,950) 'lcbas',jiter,nread,nkeep,numlcbas + write(iout_lcbas,951) 'lcbas',awork(4,i_lcbas),awork(22,i_lcbas),pw,pw3 - close(iout_lcbas) + close(iout_lcbas) + end if end if ! Summary report for conventional cldch if(mype==mype_cldch) then - if(first)then - open(iout_cldch) - else - open(iout_cldch,position='append') - end if - - numcldch=nint(awork(5,i_cldch)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -947,37 +972,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional cldch data, ranges in m$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'cldch' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + if(nread > 0)then + if(first)then + open(iout_cldch) + else + open(iout_cldch,position='append') + end if - numgross=nint(awork(6,i_cldch)) - numfailqc=nint(awork(21,i_cldch)) - if(numcldch > 0)then - pw=awork(4,i_cldch)/numcldch - pw3=awork(22,i_cldch)/numcldch + numcldch=nint(awork(5,i_cldch)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional cldch data, ranges in m$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'cldch' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_cldch,pflag) + + numgross=nint(awork(6,i_cldch)) + numfailqc=nint(awork(21,i_cldch)) + if(numcldch > 0)then + pw=awork(4,i_cldch)/numcldch + pw3=awork(22,i_cldch)/numcldch + end if + write(iout_cldch,925) 'cldch',numgross,numfailqc end if - write(iout_cldch,925) 'cldch',numgross,numfailqc - end if - write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch - write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 + write(iout_cldch,950) 'cldch',jiter,nread,nkeep,numcldch + write(iout_cldch,951) 'cldch',awork(4,i_cldch),awork(22,i_cldch),pw,pw3 - close(iout_cldch) + close(iout_cldch) + end if end if ! Summary report for conventional uwnd10m if(mype==mype_uwnd10m) then - if(first)then - open(iout_uwnd10m) - else - open(iout_uwnd10m,position='append') - end if - - numuwnd10m=nint(awork(5,i_uwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -986,37 +1013,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional uwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'uwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_uwnd10m) + else + open(iout_uwnd10m,position='append') + end if - numgross=nint(awork(6,i_uwnd10m)) - numfailqc=nint(awork(21,i_uwnd10m)) - if(numuwnd10m > 0)then - pw=awork(4,i_uwnd10m)/numuwnd10m - pw3=awork(22,i_uwnd10m)/numuwnd10m + numuwnd10m=nint(awork(5,i_uwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional uwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'uwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_uwnd10m,pflag) + + numgross=nint(awork(6,i_uwnd10m)) + numfailqc=nint(awork(21,i_uwnd10m)) + if(numuwnd10m > 0)then + pw=awork(4,i_uwnd10m)/numuwnd10m + pw3=awork(22,i_uwnd10m)/numuwnd10m + end if + write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc end if - write(iout_uwnd10m,925) 'uwnd10m',numgross,numfailqc - end if - write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m - write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 + write(iout_uwnd10m,950) 'uwnd10m',jiter,nread,nkeep,numuwnd10m + write(iout_uwnd10m,951) 'uwnd10m',awork(4,i_uwnd10m),awork(22,i_uwnd10m),pw,pw3 - close(iout_uwnd10m) + close(iout_uwnd10m) + end if end if ! Summary report for conventional vwnd10m if(mype==mype_vwnd10m) then - if(first)then - open(iout_vwnd10m) - else - open(iout_vwnd10m,position='append') - end if - - numvwnd10m=nint(awork(5,i_vwnd10m)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1025,37 +1054,39 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of conventional vwnd10m data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'vwnd10m' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + if(nread > 0)then + if(first)then + open(iout_vwnd10m) + else + open(iout_vwnd10m,position='append') + end if - numgross=nint(awork(6,i_vwnd10m)) - numfailqc=nint(awork(21,i_vwnd10m)) - if(numvwnd10m > 0)then - pw=awork(4,i_vwnd10m)/numvwnd10m - pw3=awork(22,i_vwnd10m)/numvwnd10m + numvwnd10m=nint(awork(5,i_vwnd10m)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of conventional vwnd10m data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'vwnd10m' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_vwnd10m,pflag) + + numgross=nint(awork(6,i_vwnd10m)) + numfailqc=nint(awork(21,i_vwnd10m)) + if(numvwnd10m > 0)then + pw=awork(4,i_vwnd10m)/numvwnd10m + pw3=awork(22,i_vwnd10m)/numvwnd10m + end if + write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc end if - write(iout_vwnd10m,925) 'vwnd10m',numgross,numfailqc - end if - write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m - write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 + write(iout_vwnd10m,950) 'vwnd10m',jiter,nread,nkeep,numvwnd10m + write(iout_vwnd10m,951) 'vwnd10m',awork(4,i_vwnd10m),awork(22,i_vwnd10m),pw,pw3 - close(iout_vwnd10m) + close(iout_vwnd10m) + end if end if ! Summary report for temperature if (mype==mype_t)then - if(first)then - open(iout_t) - else - open(iout_t,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1064,54 +1095,56 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of temperature data, ranges in K $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 't' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) - do k=1,nsig - num(k)=nint(awork(5*nsig+k+100,i_t)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_t)/float(num(k)) - rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_t) + else + open(iout_t,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of temperature data, ranges in K $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 't' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_t,pflag) + do k=1,nsig + num(k)=nint(awork(5*nsig+k+100,i_t)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_t)/float(num(k)) + rat3=awork(3*nsig+k+100,i_t)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) + tqcplty=tqcplty+awork(3*nsig+k+100,i_t) + write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & + awork(3*nsig+k+100,i_t),rat,rat3 + end do + numgross=nint(awork(4,i_t)) + numfailqc=nint(awork(21,i_t)) + write(iout_t,925) 'temp',numgross,numfailqc + numlow = nint(awork(2,i_t)) + numhgh = nint(awork(3,i_t)) + write(iout_t,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(6*nsig+k+100,i_t) - tqcplty=tqcplty+awork(3*nsig+k+100,i_t) - write(iout_t,240) 't',num(k),k,awork(6*nsig+k+100,i_t), & - awork(3*nsig+k+100,i_t),rat,rat3 - end do - numgross=nint(awork(4,i_t)) - numfailqc=nint(awork(21,i_t)) - write(iout_t,925) 'temp',numgross,numfailqc - numlow = nint(awork(2,i_t)) - numhgh = nint(awork(3,i_t)) - write(iout_t,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_t,950) 't',jiter,nread,nkeep,ntot - write(iout_t,951) 't',tmplty,tqcplty,tt,qctt + write(iout_t,950) 't',jiter,nread,nkeep,ntot + write(iout_t,951) 't',tmplty,tqcplty,tt,qctt - close(iout_t) + close(iout_t) + end if endif ! Summary report for doppler lidar winds if(mype==mype_dw) then - if(first)then - open(iout_dw) - else - open(iout_dw,position='append') - end if - - dwmplty=zero; dwqcplty=zero ; ntot=0 - tdw=zero ; qctdw=zero nread=0 nkeep=0 do i=1,ndat @@ -1120,56 +1153,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of lidar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) + if(nread > 0)then + if(first)then + open(iout_dw) + else + open(iout_dw,position='append') + end if + + dwmplty=zero; dwqcplty=zero ; ntot=0 + tdw=zero ; qctdw=zero + if(nkeep > 0)then + mesage='current vfit of lidar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dw,pflag) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dw)/float(num(k)) + end if + ntot=ntot+num(k) + dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) + dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) + write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & + awork(3*nsig+k+100,i_dw),rat,rat3 + end do + numgross=nint(awork(4,i_dw)) + numfailqc=nint(awork(21,i_dw)) + if(ntot > 0) then + tdw=dwmplty/float(ntot) + qctdw=dwqcplty/float(ntot) end if - ntot=ntot+num(k) - dwmplty=dwmplty+awork(6*nsig+k+100,i_dw) - dwqcplty=dwqcplty+awork(3*nsig+k+100,i_dw) - write(iout_dw,240) 'r',num(k),k,awork(6*nsig+k+100,i_dw), & - awork(3*nsig+k+100,i_dw),rat,rat3 - end do - numgross=nint(awork(4,i_dw)) - numfailqc=nint(awork(21,i_dw)) - if(ntot > 0) then - tdw=dwmplty/float(ntot) - qctdw=dwqcplty/float(ntot) - end if - write(iout_dw,925) 'dw',numgross,numfailqc - numlow = nint(awork(2,i_dw)) - numhgh = nint(awork(3,i_dw)) - write(iout_dw,900) 'dw',numhgh,numlow - end if + write(iout_dw,925) 'dw',numgross,numfailqc + numlow = nint(awork(2,i_dw)) + numhgh = nint(awork(3,i_dw)) + write(iout_dw,900) 'dw',numhgh,numlow + end if - write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot - write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw + write(iout_dw,950) 'dw',jiter,nread,nkeep,ntot + write(iout_dw,951) 'dw',dwmplty,dwqcplty,tdw,qctdw - close(iout_dw) + close(iout_dw) + end if end if ! Summary report for radar radial winds if(mype==mype_rw) then - if(first)then - open(iout_rw) - else - open(iout_rw,position='append') - end if - - rwmplty=zero; rwqcplty=zero ; ntot=0 - trw=zero ; qctrw=zero nread=0 nkeep=0 do i=1,ndat @@ -1178,57 +1213,59 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar wind data, ranges in m/s$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'rw' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) + if(nread > 0)then + if(first)then + open(iout_rw) + else + open(iout_rw,position='append') + end if + + rwmplty=zero; rwqcplty=zero ; ntot=0 + trw=zero ; qctrw=zero + if(nkeep > 0)then + mesage='current vfit of radar wind data, ranges in m/s$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'rw' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_rw,pflag) - numgross=nint(awork(4,i_rw)) - numfailqc=nint(awork(21,i_rw)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_rw)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_rw)/float(num(k)) - rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + numgross=nint(awork(4,i_rw)) + numfailqc=nint(awork(21,i_rw)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_rw)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_rw)/float(num(k)) + rat3=awork(3*nsig+k+100,i_rw)/float(num(k)) + end if + ntot=ntot+num(k) + rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) + rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) + write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & + awork(3*nsig+k+100,i_rw),rat,rat3 + end do + if(ntot > 0) then + trw=rwmplty/float(ntot) + qctrw=rwqcplty/float(ntot) end if - ntot=ntot+num(k) - rwmplty=rwmplty+awork(6*nsig+k+100,i_rw) - rwqcplty=rwqcplty+awork(3*nsig+k+100,i_rw) - write(iout_rw,240) 'r',num(k),k,awork(6*nsig+k+100,i_rw), & - awork(3*nsig+k+100,i_rw),rat,rat3 - end do - if(ntot > 0) then - trw=rwmplty/float(ntot) - qctrw=rwqcplty/float(ntot) - end if - write(iout_rw,925) 'rw',numgross,numfailqc - numlow = nint(awork(2,i_rw)) - numhgh = nint(awork(3,i_rw)) - nhitopo = nint(awork(5,i_rw)) - ntoodif = nint(awork(6,i_rw)) - write(iout_rw,900) 'rw',numhgh,numlow - write(iout_rw,905) 'rw',nhitopo,ntoodif - end if - write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot - write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw + write(iout_rw,925) 'rw',numgross,numfailqc + numlow = nint(awork(2,i_rw)) + numhgh = nint(awork(3,i_rw)) + nhitopo = nint(awork(5,i_rw)) + ntoodif = nint(awork(6,i_rw)) + write(iout_rw,900) 'rw',numhgh,numlow + write(iout_rw,905) 'rw',nhitopo,ntoodif + end if + write(iout_rw,950) 'rw',jiter,nread,nkeep,ntot + write(iout_rw,951) 'rw',rwmplty,rwqcplty,trw,qctrw - close(iout_rw) + close(iout_rw) + end if end if ! Summary report for radar reflectivity if(mype==mype_dbz) then - if(first)then - open(iout_dbz) - else - open(iout_dbz,position='append') - end if - - dbzmplty=zero; dbzqcplty=zero ; ntot=0 - tdbz=zero ; qctdbz=zero nread=0 nkeep=0 do i=1,ndat @@ -1237,56 +1274,58 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current vfit of radar reflectivity data, ranges in dBZ$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'dbz' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) - - numgross=nint(awork(4,i_dbz)) - numfailqc=nint(awork(21,i_dbz)) - do k=1,nsig - num(k)=nint(awork(k+5*nsig+100,i_dbz)) - rat=zero - rat3=zero - if(num(k) > 0) then - rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) - rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_dbz) + else + open(iout_dbz,position='append') + end if + + dbzmplty=zero; dbzqcplty=zero ; ntot=0 + tdbz=zero ; qctdbz=zero + if(nkeep > 0)then + mesage='current vfit of radar reflectivity data, ranges in dBZ$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'dbz' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_dbz,pflag) + + numgross=nint(awork(4,i_dbz)) + numfailqc=nint(awork(21,i_dbz)) + do k=1,nsig + num(k)=nint(awork(k+5*nsig+100,i_dbz)) + rat=zero + rat3=zero + if(num(k) > 0) then + rat=awork(6*nsig+k+100,i_dbz)/float(num(k)) + rat3=awork(3*nsig+k+100,i_dbz)/float(num(k)) + end if + ntot=ntot+num(k) + dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) + dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) + write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & + awork(3*nsig+k+100,i_dbz),rat,rat3 + end do + if(ntot > 0) then + tdbz=dbzmplty/float(ntot) + qctdbz=dbzqcplty/float(ntot) end if - ntot=ntot+num(k) - dbzmplty=dbzmplty+awork(6*nsig+k+100,i_dbz) - dbzqcplty=dbzqcplty+awork(3*nsig+k+100,i_dbz) - write(iout_dbz,240) 'r',num(k),k,awork(6*nsig+k+100,i_dbz), & - awork(3*nsig+k+100,i_dbz),rat,rat3 - end do - if(ntot > 0) then - tdbz=dbzmplty/float(ntot) - qctdbz=dbzqcplty/float(ntot) - end if - write(iout_dbz,925) 'dbz',numgross,numfailqc - numlow = nint(awork(2,i_dbz)) - numhgh = nint(awork(3,i_dbz)) - nhitopo = nint(awork(5,i_dbz)) - ntoodif = nint(awork(6,i_dbz)) - write(iout_dbz,900) 'dbz',numhgh,numlow - write(iout_dbz,905) 'dbz',nhitopo,ntoodif - end if - write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot - write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz + write(iout_dbz,925) 'dbz',numgross,numfailqc + numlow = nint(awork(2,i_dbz)) + numhgh = nint(awork(3,i_dbz)) + nhitopo = nint(awork(5,i_dbz)) + ntoodif = nint(awork(6,i_dbz)) + write(iout_dbz,900) 'dbz',numhgh,numlow + write(iout_dbz,905) 'dbz',nhitopo,ntoodif + end if + write(iout_dbz,950) 'dbz',jiter,nread,nkeep,ntot + write(iout_dbz,951) 'dbz',dbzmplty,dbzqcplty,tdbz,qctdbz - close(iout_dbz) + close(iout_dbz) + end if end if if(mype==mype_tcp) then - if(first)then - open(iout_tcp) - else - open(iout_tcp,position='append') - end if - - nump=nint(awork(5,i_tcp)) - pw=zero ; pw3=zero nread=0 nkeep=0 do i=1,ndat @@ -1295,39 +1334,41 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of surface pressure data, ranges in mb$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'tcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) - - numgross=nint(awork(6,i_tcp)) - numfailqc=nint(awork(21,i_tcp)) - write(iout_tcp,925) 'psfc',numgross,numfailqc + if(nread > 0)then + if(first)then + open(iout_tcp) + else + open(iout_tcp,position='append') + end if - if(nump > 0)then - pw=awork(4,i_tcp)/float(nump) - pw3=awork(22,i_tcp)/float(nump) + nump=nint(awork(5,i_tcp)) + pw=zero ; pw3=zero + if(nkeep > 0)then + mesage='current fit of surface pressure data, ranges in mb$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'tcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_tcp,pflag) + + numgross=nint(awork(6,i_tcp)) + numfailqc=nint(awork(21,i_tcp)) + write(iout_tcp,925) 'psfc',numgross,numfailqc + + if(nump > 0)then + pw=awork(4,i_tcp)/float(nump) + pw3=awork(22,i_tcp)/float(nump) + end if end if - end if - write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump - write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 + write(iout_tcp,950) 'psfc',jiter,nread,nkeep,nump + write(iout_tcp,951) 'psfc',awork(4,i_tcp),awork(22,i_tcp),pw,pw3 - close(iout_tcp) + close(iout_tcp) + end if end if ! Summary report for lagrangian if (mype==mype_lag)then - if(first)then - open(iout_lag) - else - open(iout_lag,position='append') - end if - - tmplty=zero; tqcplty=zero ; ntot=0 - tt=zero ; qctt=zero nread=0 nkeep=0 do i=1,ndat @@ -1336,53 +1377,54 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lagangian data, ranges in m $' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lag' - end do - call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) - do k=1,nsig - num(k)=nint(awork(6*nsig+k+100,i_lag)) - rat=zero ; rat3=zero - if(num(k) > 0) then - rat=awork(4*nsig+k+100,i_lag)/float(num(k)) - rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + if(nread > 0)then + if(first)then + open(iout_lag) + else + open(iout_lag,position='append') + end if + + tmplty=zero; tqcplty=zero ; ntot=0 + tt=zero ; qctt=zero + if(nkeep > 0)then + mesage='current fit of lagangian data, ranges in m $' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lag' + end do + call dtast(bwork,npres_print,pbot,ptop,mesage,jiter,iout_lag,pflag) + do k=1,nsig + num(k)=nint(awork(6*nsig+k+100,i_lag)) + rat=zero ; rat3=zero + if(num(k) > 0) then + rat=awork(4*nsig+k+100,i_lag)/float(num(k)) + rat3=awork(3*nsig+k+100,i_lag)/float(num(k)) + end if + ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) + tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) + write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & + awork(3*nsig+k+100,i_lag),rat,rat3 + end do + numgross=nint(awork(4,i_lag)) + numfailqc=nint(awork(21,i_lag)) + write(iout_lag,925) 'lag',numgross,numfailqc + ! numlow = nint(awork(2,i_t)) + ! numhgh = nint(awork(3,i_t)) + ! write(iout_lag,900) 't',numhgh,numlow + if(ntot > 0) then + tt=tmplty/ntot + qctt=tqcplty/ntot end if - ntot=ntot+num(k); tmplty=tmplty+awork(4*nsig+k+100,i_lag) - tqcplty=tqcplty+awork(3*nsig+k+100,i_lag) - write(iout_lag,240) 'lag',num(k),k,awork(4*nsig+k+100,i_lag), & - awork(3*nsig+k+100,i_lag),rat,rat3 - end do - numgross=nint(awork(4,i_lag)) - numfailqc=nint(awork(21,i_lag)) - write(iout_lag,925) 'lag',numgross,numfailqc - ! numlow = nint(awork(2,i_t)) - ! numhgh = nint(awork(3,i_t)) - ! write(iout_lag,900) 't',numhgh,numlow - if(ntot > 0) then - tt=tmplty/ntot - qctt=tqcplty/ntot end if - end if - write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot - write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt + write(iout_lag,950) 'lag',jiter,nread,nkeep,ntot + write(iout_lag,951) 'lag',tmplty,tqcplty,tt,qctt - close(iout_lag) + close(iout_lag) + end if endif ! Summary report for solid-water content path if(mype==mype_swcp) then - if(first)then - open(iout_swcp) - else - open(iout_swcp,position='append') - end if - - nsuperp=nint(awork(4,i_swcp)) - - tswcp=zero ; tswcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1391,42 +1433,44 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of solid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'swcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) - - numgrsswcp=nint(awork(6,i_swcp)) - numfailqc=nint(awork(21,i_swcp)) - grsmlt=three - tswcp=zero - tswcp3=zero - if(nsuperp > 0)then - tswcp=awork(5,i_swcp)/nsuperp - tswcp3=awork(22,i_swcp)/nsuperp - end if - write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc - write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) - end if - write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp - write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 + if(nread > 0)then + if(first)then + open(iout_swcp) + else + open(iout_swcp,position='append') + end if + + nsuperp=nint(awork(4,i_swcp)) + + tswcp=zero ; tswcp3=zero + if(nkeep > 0)then + mesage='current fit of solid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'swcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_swcp,pflag) + + numgrsswcp=nint(awork(6,i_swcp)) + numfailqc=nint(awork(21,i_swcp)) + grsmlt=three + tswcp=zero + tswcp3=zero + if(nsuperp > 0)then + tswcp=awork(5,i_swcp)/nsuperp + tswcp3=awork(22,i_swcp)/nsuperp + end if + write(iout_swcp,925) 'swcp',numgrsswcp,numfailqc + write(iout_swcp,975) grsmlt,'swcp',awork(7,i_swcp) + end if + write(iout_swcp,950) 'swcp',jiter,nread,nkeep,nsuperp + write(iout_swcp,951) 'swcp',awork(5,i_swcp),awork(22,i_swcp),tswcp,tswcp3 - close(iout_swcp) + close(iout_swcp) + end if end if ! Summary report for liquid-water content path if(mype==mype_lwcp) then - if(first)then - open(iout_lwcp) - else - open(iout_lwcp,position='append') - end if - - nsuperp=nint(awork(4,i_lwcp)) - - tlwcp=zero ; tlwcp3=zero nread=0 nkeep=0 do i=1,ndat @@ -1435,29 +1479,40 @@ subroutine statsconv(mype,& nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of liquid-water content path, ranges in kg/m^2$' - do j=1,nconvtype - pflag(j)=trim(ioctype(j)) == 'lwcp' - end do - call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) - - numgrslwcp=nint(awork(6,i_lwcp)) - numfailqc=nint(awork(21,i_lwcp)) - grsmlt=three - tlwcp=zero - tlwcp3=zero - if(nsuperp > 0)then - tlwcp=awork(5,i_lwcp)/nsuperp - tlwcp3=awork(22,i_lwcp)/nsuperp - end if - write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc - write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) - end if - write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp - write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + if(nread > 0)then + if(first)then + open(iout_lwcp) + else + open(iout_lwcp,position='append') + end if - close(iout_lwcp) + nsuperp=nint(awork(4,i_lwcp)) + + tlwcp=zero ; tlwcp3=zero + if(nkeep > 0)then + mesage='current fit of liquid-water content path, ranges in kg/m^2$' + do j=1,nconvtype + pflag(j)=trim(ioctype(j)) == 'lwcp' + end do + call dtast(bwork,1,pbotall,ptopall,mesage,jiter,iout_lwcp,pflag) + + numgrslwcp=nint(awork(6,i_lwcp)) + numfailqc=nint(awork(21,i_lwcp)) + grsmlt=three + tlwcp=zero + tlwcp3=zero + if(nsuperp > 0)then + tlwcp=awork(5,i_lwcp)/nsuperp + tlwcp3=awork(22,i_lwcp)/nsuperp + end if + write(iout_lwcp,925) 'lwcp',numgrslwcp,numfailqc + write(iout_lwcp,975) grsmlt,'lwcp',awork(7,i_lwcp) + end if + write(iout_lwcp,950) 'lwcp',jiter,nread,nkeep,nsuperp + write(iout_lwcp,951) 'lwcp',awork(5,i_lwcp),awork(22,i_lwcp),tlwcp,tlwcp3 + + close(iout_lwcp) + end if end if diff --git a/src/gsi/statslight.f90 b/src/gsi/statslight.f90 index ffcdef6a0..7f8e7c834 100644 --- a/src/gsi/statslight.f90 +++ b/src/gsi/statslight.f90 @@ -56,31 +56,14 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) real(r_kind) grsmlt,tlight real(r_kind) tlight3 - real(r_kind),dimension(1):: pbotall,ptopall logical,dimension(nlighttype):: pflag !********************************************************************************* -! Initialize constants and variables. - ptopall(1)=zero; pbotall(1)=2000.0_r_kind - - -! Generate summary statistics - - pflag=.FALSE. - -! Summary report for lightning flash rate +! Generate statistics Summary report for lightning flash rate if(mype==mype_light) then - if(first)then - open(iout_light) - else - open(iout_light,position='append') - end if - - nsuperl=nint(awork(4,i_light)) - tlight=zero ; tlight3=zero nread=0 nkeep=0 do i=1,ndat @@ -89,29 +72,40 @@ subroutine statslight(mype,i_light,bwork,awork,i_ref,ndata) nkeep=nkeep+ndata(i,3) end if end do - if(nkeep > 0)then - mesage='current fit of lightning data, range in #hits km-2 hr-1$' - do j=1,nlighttype - pflag(j)=trim(nulight(j)) == 'light' - enddo - - call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + if(nread > 0)then + pflag=.FALSE. + if(first)then + open(iout_light) + else + open(iout_light,position='append') + end if - numgrslight=nint(awork(6,i_light)) - numfailqc=nint(awork(21,i_light)) - grsmlt=three - tlight=zero - if(nsuperl > 0)then - tlight=awork(5,i_light)/nsuperl - tlight3=awork(22,i_light)/nsuperl + nsuperl=nint(awork(4,i_light)) + tlight=zero ; tlight3=zero + if(nkeep > 0)then + mesage='current fit of lightning data, range in #hits km-2 hr-1$' + do j=1,nlighttype + pflag(j)=trim(nulight(j)) == 'light' + enddo + + call dtast(bwork,1,pbot,ptop,mesage,jiter,iout_light,pflag) + + numgrslight=nint(awork(6,i_light)) + numfailqc=nint(awork(21,i_light)) + grsmlt=three + tlight=zero + if(nsuperl > 0)then + tlight=awork(5,i_light)/nsuperl + tlight3=awork(22,i_light)/nsuperl + end if + write(iout_light,925) 'light',numgrslight,numfailqc + write(iout_light,975) grsmlt,'light',awork(7,i_light) end if - write(iout_light,925) 'light',numgrslight,numfailqc - write(iout_light,975) grsmlt,'light',awork(7,i_light) - end if - write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl - write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 + write(iout_light,950) 'light',jiter,nread,nkeep,nsuperl + write(iout_light,951) 'light',awork(5,i_light),awork(22,i_light),tlight,tlight3 - close(iout_light) + close(iout_light) + end if end if diff --git a/src/gsi/statsrad.f90 b/src/gsi/statsrad.f90 index c6a993092..121761fa7 100644 --- a/src/gsi/statsrad.f90 +++ b/src/gsi/statsrad.f90 @@ -142,7 +142,7 @@ subroutine statsrad(aivals,stats,ndata) ! Write obs count to runtime output file write(iout_rad,1109) do i=1,ndat - if(idisplay(i))then + if(idisplay(i) .and. ndata(i,2) > 0)then iobs2 = nint(aivals(38,i)) qcpenal = aivals(39,i) rpenal = aivals(40,i) @@ -162,9 +162,9 @@ subroutine statsrad(aivals,stats,ndata) 2012 format(12x,A7,5x,8(a7,1x)) 2999 format(' Illegal satellite type ') 1102 format(1x,i4,i5,1x,a16,2i7,1x,f10.3,1x,6(f11.7,1x)) -1109 format(t5,'it',t13,'satellite',t23,'instrument',t38, & - '# read',t49,'# keep',t59,'# assim',& - t68,'penalty',t81,'qcpnlty',t95,'cpen',t105,'qccpen') +1109 format(t5,'it',t13,'satellite',t23,'instrument',t40, & + '# read',t53,'# keep',t65,'# assim',& + t75,'penalty',t88,'qcpnlty',t104,'cpen',t115,'qccpen') 1115 format('o-g',1x,i2.2,1x,'rad',2x,2A10,2x,3(i11,2x),4(g12.5,1x)) ! Close output unit diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index 80fac64d6..2d79fd3e3 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -226,17 +226,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & use stpjcmod, only: stplimq,stplimg,stplimv,stplimp,stplimw10m,& stplimhowv,stplimcldch,stpjcdfi,stpjcpdry,stpliml,stplimqc use bias_predictors, only: predictors - use control_vectors, only: control_vector,qdot_prod_sub,cvars2d,cvars3d + use control_vectors, only: control_vector,qdot_prod_sub + use state_vectors, only: qgpresent,qspresent,qrpresent,qipresent,qlpresent + use state_vectors, only: cldchpresent,lcbaspresent,howvpresent,wspd10mpresent,pblhpresent,vispresent,gustpresent use state_vectors, only: allocate_state,deallocate_state use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: assignment(=) use guess_grids, only: ntguessig,nfldsig use mpl_allreducemod, only: mpl_allreduce - use mpeu_util, only: getindex use timermod, only: timer_ini,timer_fnl use stpjomod, only: stpjo use gsi_io, only: verbose + use gridmod, only: minmype implicit none ! Declare passed variables @@ -266,20 +268,19 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & real(r_quad),dimension(4,ipen):: pbc real(r_quad),dimension(4,nobs_type):: pbcjo real(r_quad),dimension(4,nobs_type,nobs_bins):: pbcjoi - real(r_quad),dimension(4,nobs_bins):: pbcqmin,pbcqmax + real(r_quad),dimension(4):: pbcqmin,pbcqmax real(r_quad),dimension(4,nobs_bins):: pbcql,pbcqi,pbcqr,pbcqs,pbcqg real(r_quad),dimension(ipen):: pen_est real(r_quad),dimension(3,ipenlin):: pstart real(r_quad) bx,cx,ccoef,bcoef,dels,sges1,sgesj real(r_quad),dimension(0:istp_iter):: stp real(r_kind),dimension(istp_iter):: stprat - real(r_quad),dimension(ipen):: bsum,csum,bsum_save,csum_save,pen_save + real(r_quad),dimension(ipen):: bsum,csum real(r_quad),dimension(ipen,nobs_bins):: pj real(r_kind) delpen real(r_kind) outpensave real(r_kind),dimension(4)::sges real(r_kind),dimension(ioutpen):: outpen,outstp - logical :: cxterm,change_dels,ifound logical :: print_verbose,pjcalc @@ -290,7 +291,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! Initialize variable print_verbose=.false. if(verbose)print_verbose=.true. - cxterm=.false. mm1=mype+1 stp(0)=stpinout outpen = zero @@ -387,10 +387,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! there, if one has to know or to reference them explicitly. pstart=zero_quad - pbc=zero_quad if(iter == 0 .and. kprt >= 2)pjcalc=.true. + ! penalty, b and c for background terms pstart(1,1) = qdot_prod_sub(xhatsave,yhatsave) @@ -426,11 +426,11 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & dels = one_tenth_quad stepsize: do ii=1,istp_iter + pbc=zero_quad pjcalc=.false. if(iter == 0 .and. kprt >= 2 .and. ii == 1)pjcalc=.true. iis=ii ! Delta stepsize - change_dels=.true. sges(1)= stp(ii-1) sges(2)=(one_quad-dels)*stp(ii-1) @@ -448,7 +448,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if ! Calculate penalty values for linear terms - do i=1,ipenlin sges1=real(sges(1),r_quad) pbc(1,i)=pstart(1,i)-(2.0_r_quad*pstart(2,i)-pstart(3,i)*sges1)*sges1 @@ -475,60 +474,72 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & else it=ibin end if - call stplimq(dval(ibin),sval(ibin),sges,pbcqmin(1,ibin),pbcqmax(1,ibin),nstep,it) - end do - pbc(:,4)=zero_quad - pbc(:,5)=zero_quad - do ibin=1,nobs_bins + call stplimq(dval(ibin),sval(ibin),sges,pbcqmin,pbcqmax,nstep,it) do j=1,nstep - pbc(j,4) = pbc(j,4)+pbcqmin(j,ibin) - pbc(j,5) = pbc(j,5)+pbcqmax(j,ibin) + pbc(j,4) = pbc(j,4)+pbcqmin(j) + pbc(j,5) = pbc(j,5)+pbcqmax(j) end do + if(pjcalc)then + pj(4,ibin)=pj(4,ibin)+pbcqmin(1)+pbcqmin(ipenloc) + pj(5,ibin)=pj(5,ibin)+pbcqmax(1)+pbcqmax(ipenloc) + end if end do - if(pjcalc)then - do ibin=1,nobs_bins - pj(4,ibin)=pj(4,ibin)+pbcqmin(1,ibin)+pbcqmin(ipenloc,ibin) - pj(5,ibin)=pj(5,ibin)+pbcqmax(1,ibin)+pbcqmax(ipenloc,ibin) - end do - end if end if +!$omp parallel sections +!$omp section ! penalties for gust constraint - if(getindex(cvars2d,'gust')>0) & - call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) - if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + if(gustpresent) then + call stplimg(dval(1),sval(1),sges,pbc(1,6),nstep) + if(pjcalc)pj(6,1)=pbc(1,6)+pbc(ipenloc,6) + end if +!$omp section ! penalties for vis constraint - if(getindex(cvars2d,'vis')>0) & - call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) - if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + if(vispresent) then + call stplimv(dval(1),sval(1),sges,pbc(1,7),nstep) + if(pjcalc)pj(7,1)=pbc(1,7)+pbc(ipenloc,7) + end if ! penalties for pblh constraint - if(getindex(cvars2d,'pblh')>0) & - call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) - if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) +!$omp section + if(pblhpresent) then + call stplimp(dval(1),sval(1),sges,pbc(1,8),nstep) + if(pjcalc)pj(8,1)=pbc(1,8)+pbc(ipenloc,8) + end if ! penalties for wspd10m constraint - if(getindex(cvars2d,'wspd10m')>0) & - call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) - if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) +!$omp section + if(wspd10mpresent) then + call stplimw10m(dval(1),sval(1),sges,pbc(1,9),nstep) + if(pjcalc)pj(9,1)=pbc(1,9)+pbc(ipenloc,9) + end if ! penalties for howv constraint - if(getindex(cvars2d,'howv')>0) & - call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) - if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) +!$omp section + if(howvpresent) then + call stplimhowv(dval(1),sval(1),sges,pbc(1,10),nstep) + if(pjcalc)pj(10,1)=pbc(1,10)+pbc(ipenloc,10) + end if ! penalties for lcbas constraint - if(getindex(cvars2d,'lcbas')>0) & - call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) - if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) +!$omp section + if(lcbaspresent) then + call stpliml(dval(1),sval(1),sges,pbc(1,11),nstep) + if(pjcalc)pj(11,1)=pbc(1,11)+pbc(ipenloc,11) + end if ! penalties for cldch constraint - if(getindex(cvars2d,'cldch')>0) & - call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) - if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) +!$omp section + if(cldchpresent) then + call stplimcldch(dval(1),sval(1),sges,pbc(1,12),nstep) + if(pjcalc)pj(12,1)=pbc(1,12)+pbc(ipenloc,12) + end if +!$omp end parallel sections if (ljclimqc) then - if (getindex(cvars3d,'ql')>0) then +!$omp parallel sections private (ibin,it,j) +!$omp section + if (qlpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,13),nstep,ntguessig,'ql') if(pjcalc) pj(13,1)=pbc(1,13)+pbc(ipenloc,13) @@ -541,7 +552,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcql(1,ibin),nstep,it,'ql') end do - pbc(:,13)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,13) = pbc(j,13)+pbcql(j,ibin) @@ -554,7 +564,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qi')>0) then +!$omp section + if (qipresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,14),nstep,ntguessig,'qi') if(pjcalc) pj(14,1)=pbc(1,14)+pbc(ipenloc,14) @@ -567,7 +578,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqi(1,ibin),nstep,it,'qi') end do - pbc(:,14)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,14) = pbc(j,14)+pbcqi(j,ibin) @@ -580,7 +590,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qr')>0) then +!$omp section + if (qrpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,15),nstep,ntguessig,'qr') if(pjcalc) pj(15,1)=pbc(1,15)+pbc(ipenloc,15) @@ -593,7 +604,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqr(1,ibin),nstep,it,'qr') end do - pbc(:,15)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,15) = pbc(j,15)+pbcqr(j,ibin) @@ -606,7 +616,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qs')>0) then +!$omp section + if (qspresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,16),nstep,ntguessig,'qs') if(pjcalc) pj(16,1)=pbc(1,16)+pbc(ipenloc,16) @@ -619,7 +630,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqs(1,ibin),nstep,it,'qs') end do - pbc(:,16)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,16) = pbc(j,16)+pbcqs(j,ibin) @@ -632,7 +642,8 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if - if (getindex(cvars3d,'qg')>0) then +!$omp section + if (qgpresent) then if(.not.ljc4tlevs) then call stplimqc(dval(ibin_anl),sval(ibin_anl),sges,pbc(1,17),nstep,ntguessig,'qg') if(pjcalc) pj(17,1)=pbc(1,17)+pbc(ipenloc,17) @@ -645,7 +656,6 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if call stplimqc(dval(ibin),sval(ibin),sges,pbcqg(1,ibin),nstep,it,'qg') end do - pbc(:,17)=zero_quad do ibin=1,nobs_bins do j=1,nstep pbc(j,17) = pbc(j,17)+pbcqg(j,ibin) @@ -658,33 +668,35 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end if end if end if +!$omp end parallel sections end if ! ljclimqc end if + ! penalties for Jo pbcjoi=zero_quad call stpjo(dval,dbias,sval,sbias,sges,pbcjoi,nstep) pbcjo=zero_quad - do ibin=1,size(pbcjoi,3) ! == obs_bins - do j=1,size(pbcjoi,2) - do i=1,size(pbcjoi,1) + do ibin=1,nobs_bins ! == obs_bins + do j=1,nobs_type + do i=1,4 pbcjo(i,j)=pbcjo(i,j)+pbcjoi(i,j,ibin) end do end do enddo + do j=1,nobs_type + do i=1,4 + pbc(i,n0+j)=pbcjo(i,j) + end do + end do if(pjcalc)then - do ibin=1,size(pbcjoi,3) - do j=1,size(pbcjoi,2) + do ibin=1,nobs_bins + do j=1,nobs_type pj(n0+j,ibin)=pj(n0+j,ibin)+pbcjoi(ipenloc,j,ibin)+pbcjoi(1,j,ibin) end do enddo endif - do j=1,size(pbcjo,2) - do i=1,size(pbcjo,1) - pbc(i,n0+j)=pbcjo(i,j) - end do - end do ! Gather J contributions call mpl_allreduce(4,ipen,pbc) @@ -718,114 +730,91 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & ! estimate of stepsize + istp_use=ii stp(ii)=stp(ii-1) - if(cx > 1.e-20_r_kind) then - stp(ii)=stp(ii)+bx/cx ! step size estimate - else -! Check for cx <= 0. (probable error or large nonlinearity) - if(mype == 0) then - write(iout_iter,*) ' entering cx <=0 stepsize option',cx,stp(ii) - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - stp(ii)=outstp(ipenloc) - outpensave=outpen(ipenloc) - do i=1,nsteptot - if(outpen(i) < outpensave)then - stp(ii)=outstp(i) - outpensave=outpen(i) - end if - end do - if(outpensave < outpen(ipenloc))then - if(mype == 0)write(iout_iter,*) ' early termination due to cx <=0 ',cx,stp(ii) - cxterm=.true. - else -! Try different (better?) stepsize - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. - end if - end if - + if(cx > 1.e-20_r_quad) stp(ii)=stp(ii)+bx/cx ! step size estimate ! estimate various terms in penalty on first iteration if(ii == 1)then - do i=1,ipen - pen_save(i)=pbc(1,i) - bsum_save(i)=bsum(i) - csum_save(i)=csum(i) - end do - pjcost(1) = pen_save(1)+pbc(ipenloc,1) ! Jb + pjcost(1) = pbc(1,1)+pbc(ipenloc,1) ! Jb pjcost(2) = zero_quad do i=1,nobs_type - pjcost(2) = pjcost(2)+pen_save(n0+i)+pbc(ipenloc,n0+i) ! Jo + pjcost(2) = pjcost(2)+pbc(1,n0+i)+pbc(ipenloc,n0+i) ! Jo end do - pjcost(3) = pen_save(2) + pen_save(3)+pbc(ipenloc,3) ! Jc + pjcost(3) = pbc(1,2) + pbc(1,3)+pbc(ipenloc,3) ! Jc pjcost(4) = zero_quad do i=4,n0 - pjcost(4) = pjcost(4) + pen_save(i)+pbc(ipenloc,i) ! Jl + pjcost(4) = pjcost(4) + pbc(1,i)+pbc(ipenloc,i) ! Jl end do penalty=pjcost(1)+pjcost(2)+pjcost(3)+pjcost(4) ! J = Jb + Jo + Jc +Jl ! Write out detailed results to iout_iter - if(mype == 0) then - write(iout_iter,100) (pen_save(i)+pbc(ipenloc,i),i=1,ipen) - if(print_verbose)then - write(iout_iter,105) (bsum(i),i=1,ipen) - write(iout_iter,110) (csum(i),i=1,ipen) - end if - end if - endif - -! estimate of change in penalty - delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) - -! If change in penalty is very small end stepsize calculation - if(abs(delpen/penalty) < 1.e-17_r_kind) then - if(mype == 0)then - write(iout_iter,*) ' minimization has converged ' - write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + if(mype == minmype) then write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) if(print_verbose)then write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if end if - end_iter = .true. -! Finalize timer - call timer_fnl('stpcalc') - istp_use=ii - exit stepsize - end if + endif -! Check for negative stepsize (probable error or large nonlinearity) - if(stp(ii) <= zero_quad) then - if(mype == 0) then - write(iout_iter,*) ' entering negative stepsize option',stp(ii) + if(cx <= 1.e-20_r_quad .or. stp(ii) <= zero_quad)then +! Check for cx <= 0 or. stp(ii) < zero. (probable error or large nonlinearity) + if(mype == minmype) then + write(iout_iter,*) ' entering cx <=0 or stp <= 0 stepsize option',cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) end if stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - do i=1,nsteptot + do i=1,ii if(outpen(i) < outpensave)then - stp(ii)=outstp(i) outpensave=outpen(i) + istp_use=i end if end do + if(istp_use /= ii .and. stp(istp_use) > zero_quad)then + if(mype == minmype)then + write(iout_iter,*) ' early termination due to cx or stp <=0 ',cx,stp(ii) + write(iout_iter,*) ' better stepsize found',cx,stp(ii) + end if + exit stepsize + else if(ii == istp_iter)then + write(iout_iter,*) ' early termination due to no decrease in penalty ',cx,stp(ii) + stp(istp_use)=zero + end_iter = .true. + exit stepsize + else ! Try different (better?) stepsize - if(stp(ii) <= zero_quad .and. ii /= istp_iter)then - stp(ii)=max(outstp(1),1.0e-20_r_kind) - do i=2,nsteptot - if(outstp(i) < stp(ii) .and. outstp(i) > 1.0e-20_r_kind)stp(ii)=outstp(i) - end do - stp(ii)=one_tenth_quad*stp(ii) - change_dels=.false. + stp(ii)=one_tenth_quad*max(outstp(1),1.0e-20_r_kind) + end if + else + +! estimate of change in penalty + delpen = stp(ii)*(bx - 0.5_r_quad*stp(ii)*cx ) + +! If change in penalty is very small end stepsize calculation + if(abs(delpen/penalty) < 1.e-17_r_kind) then + if(mype == minmype)then + write(iout_iter,*) ' minimization has converged ' + write(iout_iter,140) ii,delpen,bx,cx,stp(ii) + write(iout_iter,100) (pbc(1,i)+pbc(ipenloc,i),i=1,ipen) + if(print_verbose)then + write(iout_iter,105) (bsum(i),i=1,ipen) + write(iout_iter,110) (csum(i),i=1,ipen) + end if + end if + end_iter = .true. +! Finalize timer + call timer_fnl('stpcalc') + exit stepsize end if +! Check for convergence in stepsize estimation + stprat(ii)=zero + if(stp(ii) > zero_quad)stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) + if(stprat(ii) < 1.e-4_r_kind) exit stepsize + dels = one_tenth_quad*dels end if 100 format(' J=',3e25.18/,(3x,3e25.18)) @@ -839,31 +828,21 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & 141 format('***WARNING*** reduced penalty not found in search direction',/, & ' - probable error',(5e25.18)) -! Check for convergence in stepsize estimation - istp_use=ii - if(cxterm) exit stepsize - stprat(ii)=zero - if(stp(ii) > zero)then - stprat(ii)=abs((stp(ii)-stp(ii-1))/stp(ii)) - end if - if(stprat(ii) < 1.e-4_r_kind) exit stepsize - if(change_dels)dels = one_tenth_quad*dels ! If stepsize estimate has not converged use best stepsize estimate or zero if( ii == istp_iter)then stp(ii)=outstp(ipenloc) outpensave=outpen(ipenloc) - ifound=.false. ! Find best stepsize to this point do i=1,nsteptot if(outpen(i) < outpensave)then stp(ii)=outstp(i) outpensave=outpen(i) - ifound=.true. + istp_use=i end if end do - if(ifound)exit stepsize + if(istp_use /= istp_iter)exit stepsize ! If no best stepsize set to zero and end minimization - if(mype == 0)then + if(mype == minmype)then write(iout_iter,141)(outpen(i),i=1,nsteptot) end if end_iter = .true. @@ -874,39 +853,41 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & end do stepsize if(kprt >= 2 .and. iter == 0)then call mpl_allreduce(ipen,nobs_bins,pj) - if(mype == 0)call prnt_j(pj,n0,ipen,kprt) + if(mype == minmype)call prnt_j(pj,n0,ipen,kprt) end if stpinout=stp(istp_use) ! Estimate terms in penalty - if(mype == 0 .and. print_verbose)then - do i=1,ipen - pen_est(i)=pen_save(i)-(stpinout-stp(0))*(2.0_r_quad*bsum_save(i)- & - (stpinout-stp(0))*csum_save(i)) + if(mype == minmype)then + if(print_verbose)then + do i=1,ipen + pen_est(i)=pbc(1,i)-(stpinout-stp(0))*(2.0_r_quad*bsum(i)- & + (stpinout-stp(0))*csum(i)) + end do + write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) + end if + pjcostnew(1) = pbc(1,1) ! Jb + pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc + pjcostnew(4)=zero + do i=4,n0 + pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl end do - write(iout_iter,101) (pbc(1,i)-pen_est(i),i=1,ipen) - end if - pjcostnew(1) = pbc(1,1) ! Jb - pjcostnew(3) = pbc(1,2)+pbc(1,3) ! Jc - pjcostnew(4)=zero - do i=4,n0 - pjcostnew(4) = pjcostnew(4) + pbc(1,i) ! Jl - end do - pjcostnew(2) = zero - do i=1,nobs_type - pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo - end do - penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) + pjcostnew(2) = zero + do i=1,nobs_type + pjcostnew(2) = pjcostnew(2)+pbc(1,n0+i) ! Jo + end do + penaltynew=pjcostnew(1)+pjcostnew(2)+pjcostnew(3)+pjcostnew(4) - if(mype == 0 .and. print_verbose)then - write(iout_iter,200) (stp(i),i=0,istp_use) - write(iout_iter,199) (stprat(ii),ii=1,istp_use) - write(iout_iter,201) (outstp(i),i=1,nsteptot) - write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + if(print_verbose)then + write(iout_iter,200) (stp(i),i=0,istp_use) + write(iout_iter,199) (stprat(ii),ii=1,istp_use) + write(iout_iter,201) (outstp(i),i=1,nsteptot) + write(iout_iter,202) (outpen(i)-outpen(4),i=1,nsteptot) + end if end if ! Check for final stepsize negative (probable error) if(stpinout <= zero)then - if(mype == 0)then + if(mype == minmype)then write(iout_iter,130) ii,bx,cx,stp(ii) write(iout_iter,105) (bsum(i),i=1,ipen) write(iout_iter,110) (csum(i),i=1,ipen) @@ -926,19 +907,22 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & endif ! Update solution - do i=1,nrclen - sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) - end do !$omp parallel do schedule(dynamic,1) private(i,ii) - do ii=1,nobs_bins - do i=1,sval(ii)%ndim - sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) - end do - end do -!DIR$ IVDEP - do i=1,nclen - xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) - yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + do ii=1,nobs_bins+2 + if(ii <= nobs_bins)then + do i=1,sval(ii)%ndim + sval(ii)%values(i)=sval(ii)%values(i)+stpinout*dval(ii)%values(i) + end do + else if(ii == nobs_bins+1)then + do i=1,nrclen + sbias%values(i)=sbias%values(i)+stpinout*dbias%values(i) + end do + else + do i=1,nclen + xhatsave%values(i)=xhatsave%values(i)+stpinout*dirx%values(i) + yhatsave%values(i)=yhatsave%values(i)+stpinout*diry%values(i) + end do + end if end do @@ -975,6 +959,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) use mpimod, only: mype use gsi_obOperTypeManager, only: nobs_type => obOper_count use gsi_obOperTypeManager, only: obOper_typeInfo + use gridmod, only: minmype real(r_quad),dimension(ipen,nobs_bins),intent(in ) :: pj integer(i_kind) ,intent(in ) :: n0,ipen,kprt @@ -986,7 +971,7 @@ subroutine prnt_j(pj,n0,ipen,kprt) integer(i_kind) :: ii,jj character(len=20) :: ctype(ipen) - if(kprt <=0 .or. mype /=0)return + if(kprt <=0 .or. mype /=minmype)return ctype(:)=".unknown." ctype(1)='background ' ctype(2)=' ' diff --git a/src/gsi/stpgps.f90 b/src/gsi/stpgps.f90 index f55e9f429..d357df1c0 100644 --- a/src/gsi/stpgps.f90 +++ b/src/gsi/stpgps.f90 @@ -107,12 +107,13 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) real(r_kind),dimension(max(1,nstep)),intent(in ) :: sges ! Declare local variables - integer(i_kind) j,kk,ier,istatus - integer(i_kind),dimension(nsig):: i1,i2,i3,i4 + integer(i_kind):: j,kk,ier,istatus + integer(i_kind):: i1,i2,i3,i4 real(r_kind) :: val,val2 real(r_kind) :: w1,w2,w3,w4 real(r_kind) :: q_TL,p_TL,t_TL real(r_kind) :: rq_TL,rp_TL,rt_TL + real(r_kind),dimension(nsig) :: valk2,valk real(r_kind),pointer,dimension(:) :: st,sq real(r_kind),pointer,dimension(:) :: rt,rq real(r_kind),pointer,dimension(:) :: sp @@ -149,34 +150,33 @@ subroutine stpgps(gpshead,rval,sval,out,sges,nstep) val2=-gpsptr%res if(nstep > 0)then - do j=1,nsig - i1(j)= gpsptr%ij(1,j) - i2(j)= gpsptr%ij(2,j) - i3(j)= gpsptr%ij(3,j) - i4(j)= gpsptr%ij(4,j) - enddo w1=gpsptr%wij(1) w2=gpsptr%wij(2) w3=gpsptr%wij(3) w4=gpsptr%wij(4) - val=zero - - +!$omp parallel do schedule(dynamic,1) private(j,t_TL,rt_TL,q_TL,rq_TL,p_TL,rp_TL,i1,i2,i3,i4) do j=1,nsig - t_TL =w1* st(i1(j))+w2* st(i2(j))+w3* st(i3(j))+w4* st(i4(j)) - rt_TL=w1* rt(i1(j))+w2* rt(i2(j))+w3* rt(i3(j))+w4* rt(i4(j)) - q_TL =w1* sq(i1(j))+w2* sq(i2(j))+w3* sq(i3(j))+w4* sq(i4(j)) - rq_TL=w1* rq(i1(j))+w2* rq(i2(j))+w3* rq(i3(j))+w4* rq(i4(j)) - p_TL =w1* sp(i1(j))+w2* sp(i2(j))+w3* sp(i3(j))+w4* sp(i4(j)) - rp_TL=w1* rp(i1(j))+w2* rp(i2(j))+w3* rp(i3(j))+w4* rp(i4(j)) - val2 = val2 + t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+p_tl*gpsptr%jac_p(j) - val = val + rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) - + i1= gpsptr%ij(1,j) + i2= gpsptr%ij(2,j) + i3= gpsptr%ij(3,j) + i4= gpsptr%ij(4,j) + t_TL =w1* st(i1)+w2* st(i2)+w3* st(i3)+w4* st(i4) + rt_TL=w1* rt(i1)+w2* rt(i2)+w3* rt(i3)+w4* rt(i4) + q_TL =w1* sq(i1)+w2* sq(i2)+w3* sq(i3)+w4* sq(i4) + rq_TL=w1* rq(i1)+w2* rq(i2)+w3* rq(i3)+w4* rq(i4) + p_TL =w1* sp(i1)+w2* sp(i2)+w3* sp(i3)+w4* sp(i4) + rp_TL=w1* rp(i1)+w2* rp(i2)+w3* rp(i3)+w4* rp(i4) + valk2(j) = t_tl*gpsptr%jac_t(j)+ q_tl*gpsptr%jac_q(j)+ p_tl*gpsptr%jac_p(j) + valk(j) = rt_tl*gpsptr%jac_t(j)+rq_tl*gpsptr%jac_q(j)+rp_tl*gpsptr%jac_p(j) enddo - + val=zero + do j=1,nsig + val2 = val2 + valk2(j) + val = val + valk(j) + enddo ! penalty and gradient do kk=1,nstep diff --git a/src/gsi/stpjo.f90 b/src/gsi/stpjo.f90 index b0ff73082..0f80d9b4a 100644 --- a/src/gsi/stpjo.f90 +++ b/src/gsi/stpjo.f90 @@ -267,8 +267,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) use m_obsdiags, only: obOper_destroy use gsi_obOperTypeManager, only: obOper_typeInfo - use intradmod, only: setrad - use mpeu_util, only: perr,die use mpeu_util, only: tell use mpeu_mpif, only: MPI_comm_world @@ -290,7 +288,6 @@ subroutine stpjo(dval,dbias,xval,xbias,sges,pbcjo,nstep) class(obOper),pointer:: it_obOper !************************************************************************************ - call setrad(xval(1)) !$omp parallel do schedule(dynamic,1) private(ll,mm,ib,it_obOper) do mm=1,stpcnt diff --git a/src/gsi/stprad.f90 b/src/gsi/stprad.f90 index 0def855d6..20fe0dd1a 100644 --- a/src/gsi/stprad.f90 +++ b/src/gsi/stprad.f90 @@ -110,7 +110,7 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) use gsi_metguess_mod, only: gsi_metguess_get use mpeu_util, only: getindex use intradmod, only: luseu,lusev,luset,luseq,lusecw,luseoz,luseqg,luseqh,luseqi,luseql, & - luseqr,luseqs + luseqr,luseqs,lusesst use intradmod, only: itsen,iqv,ioz,icw,ius,ivs,isst,iqg,iqh,iqi,iql,iqr,iqs,lgoback use m_obsNode, only: obsNode use m_radNode, only: radNode @@ -128,14 +128,15 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) type(gsi_bundle),intent(in) :: xval ! Declare local variables - integer(i_kind) istatus - integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk, mm, ic1,ncr + integer(i_kind) istatus,icx + integer(i_kind) nn,n,ic,k,nx,j1,j2,j3,j4,kk,mm,ncr real(r_kind) val2,val,w1,w2,w3,w4 real(r_kind),dimension(nsigradjac):: tdir,rdir real(r_kind) cg_rad,wgross,wnotgross integer(i_kind),dimension(nsig) :: j1n,j2n,j3n,j4n - real(r_kind),dimension(max(1,nstep)) :: term,rad + real(r_kind),dimension(max(1,nstep)) :: rad type(radNode), pointer :: radptr + real(r_kind),allocatable,dimension(:,:) :: term real(r_kind),allocatable,dimension(:) :: biasvects real(r_kind),allocatable,dimension(:) :: biasvectr real(r_kind),pointer,dimension(:) :: rt,rq,rcw,roz,ru,rv,rqg,rqh,rqi,rql,rqr,rqs @@ -150,34 +151,59 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) if(lgoback)return -! Retrieve pointers - call gsi_bundlegetpointer(xval,'u', su, istatus) - call gsi_bundlegetpointer(xval,'v', sv, istatus) - call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) - call gsi_bundlegetpointer(xval,'q', sq, istatus) - call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) - call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) - call gsi_bundlegetpointer(xval,'sst',sst,istatus) - call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) - call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) - call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) - call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) - call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) - call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) - - call gsi_bundlegetpointer(dval,'u', ru, istatus) - call gsi_bundlegetpointer(dval,'v', rv, istatus) - call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) - call gsi_bundlegetpointer(dval,'q', rq, istatus) - call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) - call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) - call gsi_bundlegetpointer(dval,'sst',rst,istatus) - call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) - call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) - call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) - call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) - call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) - call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) +! Retrieve pointers for used variables + if(luseu)then + call gsi_bundlegetpointer(dval,'u', ru, istatus) + call gsi_bundlegetpointer(xval,'u', su, istatus) + end if + if(lusev)then + call gsi_bundlegetpointer(xval,'v', sv, istatus) + call gsi_bundlegetpointer(dval,'v', rv, istatus) + end if + if(luset)then + call gsi_bundlegetpointer(xval,'tsen' ,st, istatus) + call gsi_bundlegetpointer(dval,'tsen' ,rt, istatus) + end if + if(luseq)then + call gsi_bundlegetpointer(xval,'q', sq, istatus) + call gsi_bundlegetpointer(dval,'q', rq, istatus) + end if + if(lusecw)then + call gsi_bundlegetpointer(xval,'cw' ,scw,istatus) + call gsi_bundlegetpointer(dval,'cw' ,rcw,istatus) + end if + if(luseoz)then + call gsi_bundlegetpointer(xval,'oz' ,soz,istatus) + call gsi_bundlegetpointer(dval,'oz' ,roz,istatus) + end if + if(lusesst)then + call gsi_bundlegetpointer(xval,'sst',sst,istatus) + call gsi_bundlegetpointer(dval,'sst',rst,istatus) + end if + if(luseqg)then + call gsi_bundlegetpointer(xval,'qg' ,sqg,istatus) + call gsi_bundlegetpointer(dval,'qg' ,rqg,istatus) + end if + if(luseqh)then + call gsi_bundlegetpointer(xval,'qh' ,sqh,istatus) + call gsi_bundlegetpointer(dval,'qh' ,rqh,istatus) + end if + if(luseqi)then + call gsi_bundlegetpointer(xval,'qi' ,sqi,istatus) + call gsi_bundlegetpointer(dval,'qi' ,rqi,istatus) + end if + if(luseql)then + call gsi_bundlegetpointer(xval,'ql' ,sql,istatus) + call gsi_bundlegetpointer(dval,'ql' ,rql,istatus) + end if + if(luseqr)then + call gsi_bundlegetpointer(xval,'qr' ,sqr,istatus) + call gsi_bundlegetpointer(dval,'qr' ,rqr,istatus) + end if + if(luseqs)then + call gsi_bundlegetpointer(xval,'qs' ,sqs,istatus) + call gsi_bundlegetpointer(dval,'qs' ,rqs,istatus) + end if tdir=zero @@ -187,118 +213,117 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) do while(associated(radptr)) if(radptr%luse)then if(nstep > 0)then - j1=radptr%ij(1) - j2=radptr%ij(2) - j3=radptr%ij(3) - j4=radptr%ij(4) w1=radptr%wij(1) w2=radptr%wij(2) w3=radptr%wij(3) w4=radptr%wij(4) - if(luseu)then - tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) - rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) - endif - if(lusev)then - tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) - rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) - endif - if (isst>=0) then - tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) - rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) - end if - j1n(1) = j1 - j2n(1) = j2 - j3n(1) = j3 - j4n(1) = j4 + j1n(1) = radptr%ij(1) + j2n(1) = radptr%ij(2) + j3n(1) = radptr%ij(3) + j4n(1) = radptr%ij(4) do n=2,nsig j1n(n) = j1n(n-1)+latlon11 j2n(n) = j2n(n-1)+latlon11 j3n(n) = j3n(n-1)+latlon11 j4n(n) = j4n(n-1)+latlon11 enddo - do n=1,nsig - j1 = j1n(n) - j2 = j2n(n) - j3 = j3n(n) - j4 = j4n(n) - -! Input state vector -! Input search direction vector - if(luset)then - tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) - rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) - endif - if(luseq)then - tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) - rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) - endif - if (luseoz) then - tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) - rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) - end if - if (lusecw) then - tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) - rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) - end if - if (luseqg) then - tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) - rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) - end if - if (luseqh) then - tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) - rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) - end if - if (luseqi) then - tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) - rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) - end if - if (luseql) then - tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) - rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) - end if - if (luseqr) then - tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) - rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + allocate(biasvects(radptr%nchan)) + allocate(biasvectr(radptr%nchan)) + allocate(term(max(1,nstep),radptr%nchan)) + +!$omp parallel do schedule(dynamic,1) private(n,j1,j2,j3,j4,icx,vals_quad,valr_quad,nx) + do n=1,max(nsig,radptr%nchan) + if(n <= nsig)then + j1 = j1n(n) + j2 = j2n(n) + j3 = j3n(n) + j4 = j4n(n) + if(n == 1)then + if(luseu)then + tdir(ius+1)=w1* su(j1) + w2* su(j2) + w3* su(j3) + w4* su(j4) + rdir(ius+1)=w1* ru(j1) + w2* ru(j2) + w3* ru(j3) + w4* ru(j4) + endif + if(lusev)then + tdir(ivs+1)=w1* sv(j1) + w2* sv(j2) + w3* sv(j3) + w4* sv(j4) + rdir(ivs+1)=w1* rv(j1) + w2* rv(j2) + w3* rv(j3) + w4* rv(j4) + endif + if (lusesst) then + tdir(isst+1)=w1*sst(j1) + w2*sst(j2) + w3*sst(j3) + w4*sst(j4) + rdir(isst+1)=w1*rst(j1) + w2*rst(j2) + w3*rst(j3) + w4*rst(j4) + end if + end if + +! Input state vector +! Input search direction vector + if(luset)then + tdir(itsen+n)=w1* st(j1) +w2* st(j2) + w3* st(j3) +w4* st(j4) + rdir(itsen+n)=w1* rt(j1) +w2* rt(j2) + w3* rt(j3) +w4* rt(j4) + endif + if(luseq)then + tdir(iqv+n)=w1* sq(j1) +w2* sq(j2) + w3* sq(j3) +w4* sq(j4) + rdir(iqv+n)=w1* rq(j1) +w2* rq(j2) + w3* rq(j3) +w4* rq(j4) + endif + if (luseoz) then + tdir(ioz+n)=w1*soz(j1)+w2*soz(j2)+ w3*soz(j3)+w4*soz(j4) + rdir(ioz+n)=w1*roz(j1)+w2*roz(j2)+ w3*roz(j3)+w4*roz(j4) + end if + if (lusecw) then + tdir(icw+n)=w1*scw(j1)+w2*scw(j2)+ w3*scw(j3)+w4*scw(j4) + rdir(icw+n)=w1*rcw(j1)+w2*rcw(j2)+ w3*rcw(j3)+w4*rcw(j4) + end if + if (luseqg) then + tdir(iqg+n)=w1*sqg(j1)+w2*sqg(j2)+ w3*sqg(j3)+w4*sqg(j4) + rdir(iqg+n)=w1*rqg(j1)+w2*rqg(j2)+ w3*rqg(j3)+w4*rqg(j4) + end if + if (luseqh) then + tdir(iqh+n)=w1*sqh(j1)+w2*sqh(j2)+ w3*sqh(j3)+w4*sqh(j4) + rdir(iqh+n)=w1*rqh(j1)+w2*rqh(j2)+ w3*rqh(j3)+w4*rqh(j4) + end if + if (luseqi) then + tdir(iqi+n)=w1*sqi(j1)+w2*sqi(j2)+ w3*sqi(j3)+w4*sqi(j4) + rdir(iqi+n)=w1*rqi(j1)+w2*rqi(j2)+ w3*rqi(j3)+w4*rqi(j4) + end if + if (luseql) then + tdir(iql+n)=w1*sql(j1)+w2*sql(j2)+ w3*sql(j3)+w4*sql(j4) + rdir(iql+n)=w1*rql(j1)+w2*rql(j2)+ w3*rql(j3)+w4*rql(j4) + end if + if (luseqr) then + tdir(iqr+n)=w1*sqr(j1)+w2*sqr(j2)+ w3*sqr(j3)+w4*sqr(j4) + rdir(iqr+n)=w1*rqr(j1)+w2*rqr(j2)+ w3*rqr(j3)+w4*rqr(j4) + end if + if (luseqs) then + tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) + rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + end if end if - if (luseqs) then - tdir(iqs+n)=w1*sqs(j1)+w2*sqs(j2)+ w3*sqs(j3)+w4*sqs(j4) - rdir(iqs+n)=w1*rqs(j1)+w2*rqs(j2)+ w3*rqs(j3)+w4*rqs(j4) + if(n <= radptr%nchan)then + icx=radptr%icx(n) + vals_quad = zero_quad + valr_quad = zero_quad + do nx=1,npred + vals_quad = vals_quad + spred(nx,icx)*radptr%pred(nx,n) + valr_quad = valr_quad + rpred(nx,icx)*radptr%pred(nx,n) + end do + biasvects(n) = vals_quad + biasvectr(n) = valr_quad end if - end do - end if - if(nstep > 0)then - allocate(biasvects(radptr%nchan)) - allocate(biasvectr(radptr%nchan)) - do nn=1,radptr%nchan - ic1=radptr%icx(nn) - vals_quad = zero_quad - valr_quad = zero_quad - do nx=1,npred - vals_quad = vals_quad + spred(nx,ic1)*radptr%pred(nx,nn) - valr_quad = valr_quad + rpred(nx,ic1)*radptr%pred(nx,nn) - end do - biasvects(nn) = vals_quad - biasvectr(nn) = valr_quad - end do endif - ncr=0 +!$omp parallel do schedule(dynamic,1) private(nn,ic,mm,ncr,k,kk,rad,val,val2,cg_rad,wnotgross,wgross) do nn=1,radptr%nchan - val2=-radptr%res(nn) - if(nstep > 0)then val = zero + val2=-radptr%res(nn) ! contribution from bias corection ic=radptr%icx(nn) if(radptr%use_corr_obs) then do mm=1,nn - ncr=ncr+1 + ncr=radptr%iccerr(nn)+mm val2=val2+radptr%rsqrtinv(ncr)*biasvects(mm) val =val +radptr%rsqrtinv(ncr)*biasvectr(mm) end do @@ -318,12 +343,12 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) rad(kk)=val2+sges(kk)*val end do else - rad(kk)= val2 + rad(1)= -radptr%res(nn) end if ! calculate contribution to J do kk=1,max(1,nstep) - term(kk) = radptr%err2(nn)*rad(kk)*rad(kk) + term(kk,nn) = radptr%err2(nn)*rad(kk)*rad(kk) end do ! Modify penalty term if nonlinear QC @@ -333,18 +358,23 @@ subroutine stprad(radhead,dval,xval,rpred,spred,out,sges,nstep) wnotgross= one-pg_rad(ic)*varqc_iter wgross = varqc_iter*pg_rad(ic)*cg_rad/wnotgross do kk=1,max(1,nstep) - term(kk) = -two*log((exp(-half*term(kk) ) + wgross)/(one+wgross)) + term(kk,nn) = -two*log((exp(-half*term(kk,nn) ) + wgross)/(one+wgross)) end do endif - out(1) = out(1) + term(1)*radptr%raterr2(nn) + end do + + deallocate(biasvects, biasvectr) + + do nn=1,radptr%nchan + out(1) = out(1) + term(1,nn)*radptr%raterr2(nn) do kk=2,nstep - out(kk) = out(kk) + (term(kk)-term(1))*radptr%raterr2(nn) + out(kk) = out(kk) + (term(kk,nn)-term(1,nn))*radptr%raterr2(nn) end do end do - if(nstep > 0) deallocate(biasvects, biasvectr) + deallocate(term) end if diff --git a/src/gsi/stpsst.f90 b/src/gsi/stpsst.f90 index 222b67862..765676010 100644 --- a/src/gsi/stpsst.f90 +++ b/src/gsi/stpsst.f90 @@ -101,13 +101,13 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) real(r_kind) pg_sst real(r_kind),pointer,dimension(:) :: ssst real(r_kind),pointer,dimension(:) :: rsst - real(r_kind) tdir,rdir type(sstNode), pointer :: sstptr out=zero_quad ! If no sst data return if(.not. associated(ssthead))return + if(.not. nst_gsi > 2 ) return ! Retrieve pointers ! Simply return if any pointer not found @@ -129,15 +129,12 @@ subroutine stpsst(ssthead,rval,sval,out,sges,nstep) w3=sstptr%wij(3) w4=sstptr%wij(4) - if ( nst_gsi > 2 .and. (sstptr%tz_tr > zero .and. sstptr%tz_tr <= one) ) then - tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) - rdir = w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val = sstptr%tz_tr*rdir - val2 = sstptr%tz_tr*tdir - sstptr%res - else - val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) - val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4)-sstptr%res - endif + val =w1*rsst(j1)+w2*rsst(j2)+w3*rsst(j3)+w4*rsst(j4) + val2=w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) + + val = sstptr%tz_tr*val + val2 = sstptr%tz_tr*val2 + val2=val2-sstptr%res do kk=1,nstep sst=val2+sges(kk)*val diff --git a/src/gsi/stpt.f90 b/src/gsi/stpt.f90 index 27f5385ac..5911d87b9 100644 --- a/src/gsi/stpt.f90 +++ b/src/gsi/stpt.f90 @@ -184,7 +184,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) w6=tptr%wij(6) w7=tptr%wij(7) w8=tptr%wij(8) -! Note time derivative stuff not consistent for virtual temperature if(tptr%tv_ob)then val= w1*rtv(j1)+w2*rtv(j2)+w3*rtv(j3)+w4*rtv(j4)+ & @@ -208,9 +207,6 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) end do end if - do kk=1,nstep - tt(kk)=val2+sges(kk)*val - end do if(tptr%use_sfc_model) then @@ -229,8 +225,9 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) valv2=w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4) valp =w1* rp(j1)+w2* rp(j2)+w3* rp(j3)+w4* rp(j4) valp2=w1* sp(j1)+w2* sp(j2)+w3* sp(j3)+w4* sp(j4) + do kk=1,nstep - ts_prime=tt(kk) + ts_prime=val2+sges(kk)*val tg_prime=valsst2+sges(kk)*valsst qs_prime=valq2+sges(kk)*valq us_prime=valu2+sges(kk)*valu @@ -239,14 +236,18 @@ subroutine stpt(thead,dval,xval,out,sges,nstep,rpred,spred) tt(kk)=psfc_prime*tptr%tlm_tsfc(1) + tg_prime*tptr%tlm_tsfc(2) + & ts_prime *tptr%tlm_tsfc(3) + qs_prime*tptr%tlm_tsfc(4) + & - us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) + us_prime *tptr%tlm_tsfc(5) + vs_prime*tptr%tlm_tsfc(6) - & + tptr%res + end do + + else + + do kk=1,nstep + tt(kk)=val2+sges(kk)*val-tptr%res end do end if - do kk=1,nstep - tt(kk)=tt(kk)-tptr%res - end do else tt(1)=tptr%res end if diff --git a/src/gsi/vqc_int.f90 b/src/gsi/vqc_int.f90 index 714ee23ea..12abc53b3 100644 --- a/src/gsi/vqc_int.f90 +++ b/src/gsi/vqc_int.f90 @@ -27,12 +27,12 @@ subroutine vqc_int(error2,rat_error2,t_pgv,cg_tv,var_jbv,ibv,ikv,valv,gradv) real(r_kind), intent(out) :: gradv ! Declare local variables - real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq + real(r_kind) wnotgross,wgross,g_nvqc,w_nvqc,p0,qq - if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & + if (vqc .and. nlnqc_iter .and. t_pgv > tiny_r_kind .and. & cg_tv > tiny_r_kind) then wnotgross= one-t_pgv wgross =t_pgv*cg_tv/wnotgross diff --git a/src/gsi/vqc_stp.f90 b/src/gsi/vqc_stp.f90 index 1c8f29685..04d9a9124 100644 --- a/src/gsi/vqc_stp.f90 +++ b/src/gsi/vqc_stp.f90 @@ -41,7 +41,7 @@ subroutine vqc_stp(pen_v,nstep_v,tpg_v,cgt_v,& ! Note: if wgross=0 (no gross error, then wnotgross=1 and this ! all reduces to the linear case (no qc) - if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then + if (vqc .and. nlnqc_iter .and. tpg_v > tiny_r_kind .and. cgt_v >tiny_r_kind) then wnotgross= one-tpg_v wgross =tpg_v*cgt_v/wnotgross do kk=1,max(1,nstep_v) diff --git a/src/gsi/write_incr.f90 b/src/gsi/write_incr.f90 index b22be8de3..9adb15086 100644 --- a/src/gsi/write_incr.f90 +++ b/src/gsi/write_incr.f90 @@ -26,7 +26,7 @@ module write_incr contains - subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) + subroutine write_fv3_inc_ (grd,filename,mype_out,gfs_bundle,ibin) !$$$ subprogram documentation block ! . . . @@ -94,13 +94,13 @@ subroutine write_fv3_inc_ (grd,sp_a,filename,mype_out,gfs_bundle,ibin) use state_vectors, only: svars3d use mpeu_util, only: getindex + use control2state_mod, only: control2state implicit none ! !INPUT PARAMETERS: type(sub2grid_info), intent(in) :: grd - type(spec_vars), intent(in) :: sp_a character(len=24), intent(in) :: filename ! file to open and write to integer(i_kind), intent(in) :: mype_out ! mpi task to write output file type(gsi_bundle), intent(in) :: gfs_bundle diff --git a/src/gsi/xhat_vordivmod.f90 b/src/gsi/xhat_vordivmod.f90 index bff52aa9d..e271fb9fb 100644 --- a/src/gsi/xhat_vordivmod.f90 +++ b/src/gsi/xhat_vordivmod.f90 @@ -77,6 +77,8 @@ subroutine init_ allocate(xhat_vor(lat2,lon2,nsig,nobs_bins)) allocate(xhat_div(lat2,lon2,nsig,nobs_bins)) + xhat_vor=zero + xhat_div=zero end subroutine init_ subroutine clean_ @@ -146,18 +148,6 @@ subroutine calc_(sval) !******************************************************************************* -! Initialize local arrays - do ii=1,nobs_bins - do k=1,nsig - do j=1,lon2 - do i=1,lat2 - xhat_vor(i,j,k,ii) = zero - xhat_div(i,j,k,ii) = zero - end do - end do - end do - end do - ! The GSI analyzes stream function (sf) and velocity potential (vp). ! Wind field observations are in terms of zonal (u) and meridional ! (v) wind components or wind speed. Thus, the GSI carries wind