subroutine write_bkgvars_grid(a,b,c,d,mype) !$$$ subroutine documentation block ! ! subprogram: write_bkgvars_grid ! ! prgrmmr: ! ! abstract: modified routine to write out files to compare spectral computation ! of horizontal derivatives with the derivatives that are being ! carried around for the dynamical balance constraint ! ! program history log: ! 2008-03-27 safford -- add subprogram doc block, rm unused vars and uses ! ! input argument list: ! mype - mpi task id ! a - ! b - ! c - ! d - ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ use kinds, only: r_kind,i_kind,r_single use gridmod, only: nlat,nlon,nsig,lat2,lon2 implicit none integer(i_kind) ,intent(in ) :: mype real(r_kind),dimension(lat2,lon2,nsig),intent(in ) :: a,b,c real(r_kind),dimension(lat2,lon2) ,intent(in ) :: d character(255):: grdfile real(r_kind),dimension(nlat,nlon,nsig):: ag,bg,cg real(r_kind),dimension(nlat,nlon):: dg real(r_single),dimension(nlon,nlat,nsig):: a4,b4,c4 real(r_single),dimension(nlon,nlat):: d4 integer(i_kind) ncfggg,iret,i,j,k ! gather stuff to processor 0 do k=1,nsig call gather_stuff2(a(1,1,k),ag(1,1,k),mype,0) call gather_stuff2(b(1,1,k),bg(1,1,k),mype,0) call gather_stuff2(c(1,1,k),cg(1,1,k),mype,0) end do call gather_stuff2(d,dg,mype,0) if (mype==0) then write(6,*) 'WRITE OUT NEW VARIANCES' ! load single precision arrays do k=1,nsig do j=1,nlon do i=1,nlat a4(j,i,k)=ag(i,j,k) b4(j,i,k)=bg(i,j,k) c4(j,i,k)=cg(i,j,k) end do end do end do do j=1,nlon do i=1,nlat d4(j,i)=dg(i,j) end do end do ! Create byte-addressable binary file for grads grdfile='bkgvar_rewgt.grd' ncfggg=len_trim(grdfile) call baopenwt(22,grdfile(1:ncfggg),iret) call wryte(22,4*nlat*nlon*nsig,a4) call wryte(22,4*nlat*nlon*nsig,b4) call wryte(22,4*nlat*nlon*nsig,c4) call wryte(22,4*nlat*nlon,d4) call baclose(22,iret) end if return end subroutine write_bkgvars_grid subroutine write_bkgvars2_grid !$$$ subroutine documentation block ! ! subprogram: write_bkgvars2_grid ! ! prgrmmr: ! ! abstract: modified routine to write out files to compare spectral computation ! of horizontal derivatives with the derivatives that are being ! carried around for the dynamical balance constraint ! ! program history log: ! 2008-03-27 safford -- add subprogram doc block, rm unused vars and uses ! 2010-06-18 todling -- generalized to show all variances; create ctl ! 2010-10-20 pagowski - add cmaq ! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS ! core ! 2018-02-15 wu - add code for fv3_regional ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ use kinds, only: r_kind,i_kind,r_single use mpimod, only: mype use constants, only: zero,r1000,one_tenth,r100 use guess_grids, only: get_ref_gesprs use gridmod, only: nlat,nlon,nsig !use gridmod, only: ak5,bk5,idvc5,& !regional,wrf_nmm_regional,nems_nmmb_regional,wrf_mass_regional,& !cmaq_regional,pt_ll,fv3_regional,& !eta2_ll,pdtop_ll,eta1_ll,twodvar_regional use control_vectors, only: nc3d,nc2d,mvars use control_vectors, only: cvars3d,cvars2d,cvarsmd use berror, only: dssv,dssvs use file_utility, only : get_lun implicit none character(255):: grdfile real(r_kind),dimension(nlat,nlon,nsig,nc3d):: ag real(r_kind),dimension(nlat,nlon,nc2d+mvars):: dg real(r_single),dimension(nlon,nlat,nsig,nc3d):: a4 real(r_single),dimension(nlon,nlat,nc2d+mvars):: d4 real(r_kind) ,dimension(nsig+1)::prs integer(i_kind) ncfggg,iret,lu,i,j,k,n ! gather stuff to processor 0 do n=1,nc3d do k=1,nsig call gather_stuff2(dssv(1,1,k,n),ag(1,1,k,n),mype,0) end do end do do n=1,nc2d call gather_stuff2(dssvs(1,1,n),dg(1,1,n),mype,0) end do do n=1,mvars call gather_stuff2(dssvs(1,1,nc2d+n),dg(1,1,nc2d+n),mype,0) end do ! get some reference-like pressure levels ! do k=1,nsig+1 ! if(regional) then ! if (wrf_nmm_regional.or.nems_nmmb_regional.or.cmaq_regional) & ! prs(k)=one_tenth* & ! (eta1_ll(k)*pdtop_ll + & ! eta2_ll(k)*(r1000-pdtop_ll-pt_ll) + & ! pt_ll) ! if (twodvar_regional) & ! prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + pt_ll) ! if (fv3_regional ) & ! prs(k)=eta1_ll(k)+r100*eta2_ll(k) ! if (wrf_mass_regional) & ! prs(k)=one_tenth*(eta1_ll(k)*(r1000-pt_ll) + eta2_ll(k) + pt_ll) ! else ! if (idvc5==1 .or. idvc5==2) then ! prs(k)=ak5(k)+(bk5(k)*r1000) ! else if (idvc5==3) then ! if (k==1) then ! prs(k)=r1000 ! else if (k==nsig+1) then ! prs(k)=zero ! else ! prs(k)=ak5(k)+(bk5(k)*r1000)! +(ck5(k)*trk) ! end if ! end if ! endif ! enddo call get_ref_gesprs(prs) if (mype==0) then write(6,*) 'WRITE OUT NEW VARIANCES' ! Load single precision arrays do n=1,nc3d do k=1,nsig do j=1,nlon do i=1,nlat a4(j,i,k,n)=ag(i,j,k,n) end do end do end do end do do n=1,nc2d+mvars do j=1,nlon do i=1,nlat d4(j,i,n)=dg(i,j,n) end do end do end do ! Create byte-addressable binary file for grads grdfile='bkgvar_smooth.grd' ncfggg=len_trim(grdfile) lu=get_lun() call baopenwt(lu,grdfile(1:ncfggg),iret) ! Loop over 3d-variances do n=1,nc3d call wryte(lu,4*nlat*nlon*nsig,a4(1,1,1,n)) enddo ! Loop over 2d-variances do n=1,nc2d+mvars call wryte(lu,4*nlat*nlon,d4(1,1,n)) enddo call baclose(lu,iret) ! Now create corresponding grads table file lu=get_lun() open(lu,file='bkgvar_smooth.ctl',form='formatted') write(lu,'(2a)') 'DSET ^', trim(grdfile) write(lu,'(2a)') 'TITLE ', 'gsi berror variances' write(lu,'(a,2x,e13.6)') 'UNDEF', 1.E+15 ! any other preference for this? write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'XDEF',nlon, 'LINEAR', 0.0, 360./nlon write(lu,'(a,2x,i4,2x,a,2x,f5.1,2x,f9.6)') 'YDEF',nlat, 'LINEAR', -90.0, 180./(nlat-1.) write(lu,'(a,2x,i4,2x,a,100(1x,f10.5))') 'ZDEF',nsig, 'LEVELS', prs(1:nsig) write(lu,'(a,2x,i4,2x,a)') 'TDEF', 1, 'LINEAR 12:00Z04JUL1776 6hr' ! any date suffices write(lu,'(a,2x,i4)') 'VARS',nc3d+nc2d+mvars do n=1,nc3d write(lu,'(a,1x,2(i4,1x),a)') trim(cvars3d(n)),nsig,0,trim(cvars3d(n)) enddo do n=1,nc2d write(lu,'(a,1x,2(i4,1x),a)') trim(cvars2d(n)), 1,0,trim(cvars2d(n)) enddo do n=1,mvars write(lu,'(a,1x,2(i4,1x),a)') trim(cvarsmd(n)), 1,0,trim(cvarsmd(n)) enddo write(lu,'(a)') 'ENDVARS' close(lu) end if ! mype=0 return end subroutine write_bkgvars2_grid