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 constants, only: izero 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,izero) call gather_stuff2(b(1,1,k),bg(1,1,k),mype,izero) call gather_stuff2(c(1,1,k),cg(1,1,k),mype,izero) end do call gather_stuff2(d,dg,mype,izero) if (mype==izero) 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_i_kind,grdfile(1:ncfggg),iret) call wryte(22_i_kind,4*nlat*nlon*nsig,a4) call wryte(22_i_kind,4*nlat*nlon*nsig,b4) call wryte(22_i_kind,4*nlat*nlon*nsig,c4) call wryte(22_i_kind,4*nlat*nlon,d4) call baclose(22_i_kind,iret) end if return end subroutine write_bkgvars_grid subroutine load_grid2(grid_in,grid_out) !$$$ subroutine documentation block ! ! subprogram: load_grid2 ! ! prgrmmr: ! ! abstract: ! ! program history log: ! 2008-03-27 safford -- add subprogram doc block, rm unused vars ! ! input argument list: ! grid_in - input grid ! ! output argument list: ! grid_out - output grid ! ! attributes: ! language: f90 ! machine: ! !$$$ use kinds, only: i_kind,r_kind use constants, only: ione use gridmod, only: nlat,nlon implicit none real(r_kind),dimension(nlat,nlon) ,intent(in ) :: grid_in ! input grid real(r_kind),dimension(nlon,nlat-2_i_kind),intent( out) :: grid_out ! output grid integer(i_kind) i,j,nlatm1,jj,j2 ! Transfer contents of local array to output array. nlatm1=nlat-ione do j=2,nlatm1 jj=j-ione j2=nlat-j+ione do i=1,nlon grid_out(i,jj)=grid_in(j2,i) end do end do return end subroutine load_grid2 subroutine fill_ns2(grid_in,grid_out) !$$$ subroutine documentation block ! ! subprogram: fill_ns2 ! ! prgrmmr: ! ! abstract: ! ! program history log: ! 2008-03-27 safford -- add subprogram doc block, rm unused vars ! ! input argument list: ! grid_in - input grid ! ! output argument list: ! grid_out - output grid ! ! attributes: ! language: f90 ! machine: ! !$$$ use kinds, only: i_kind,r_kind use constants, only: ione,zero,one use gridmod, only: nlat,nlon implicit none real(r_kind),dimension(nlon,nlat-2_i_kind),intent(in ) :: grid_in ! input grid real(r_kind),dimension(nlat,nlon) ,intent( out) :: grid_out ! output grid ! Declare local variables integer(i_kind) i,j,jj,nlatm2 real(r_kind) rnlon,sumn,sums ! Transfer contents of input grid to local work array ! Reverse ordering in j direction from n-->s to s-->n do j=2,nlat-ione jj=nlat-j do i=1,nlon grid_out(j,i)=grid_in(i,jj) end do end do ! Compute mean along southern and northern latitudes sumn=zero sums=zero nlatm2=nlat-2_i_kind do i=1,nlon sumn=sumn+grid_in(i,1) sums=sums+grid_in(i,nlatm2) end do rnlon=one/float(nlon) sumn=sumn*rnlon sums=sums*rnlon ! Load means into local work array do i=1,nlon grid_out(1,i) =sums grid_out(nlat,i)=sumn end do return end subroutine fill_ns2