Skip to content

Commit

Permalink
code cleanup (NOAA-EMC#808)
Browse files Browse the repository at this point in the history
  • Loading branch information
@RussTreadon-NOAA
RussTreadon-NOAA committed Dec 2, 2024
1 parent 0a3bb05 commit 68d52ac
Show file tree
Hide file tree
Showing 2 changed files with 7 additions and 225 deletions.
23 changes: 7 additions & 16 deletions src/gsi/m_berror_stats.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -94,9 +94,6 @@ module m_berror_stats

logical,save :: bin_berror=.false.

!! real(r_kind),allocatable,dimension(:,:):: varq
!! real(r_kind),allocatable,dimension(:,:):: varcw

contains

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Expand All @@ -109,13 +106,11 @@ module m_berror_stats
!
! !INTERFACE:

!!subroutine get_dims(mype,msig,mlat,mlon,lunit)
subroutine get_dims(msig,mlat,mlon,lunit)

use mpimod, only: mype
implicit none

!! integer(i_kind) ,intent( in) :: mype ! proc identifier
integer(i_kind) ,intent( out) :: msig ! dimension of levels
integer(i_kind) ,intent( out) :: mlat ! dimension of latitudes
integer(i_kind),optional,intent( out) :: mlon ! dimension of longitudes
Expand Down Expand Up @@ -417,7 +412,6 @@ end subroutine read_bal
! !INTERFACE:

subroutine read_wgt(corz,corp,hwll,hwllp,vz,corsst,hsst,varq,qoption,varcw,cwoption,mype,lunit)
!! n_clouds_fwd,cloud_names_fwd,lunit)

use kinds, only : r_single,r_kind
use gridmod,only : nlat,nlon,nsig
Expand All @@ -444,8 +438,6 @@ subroutine read_wgt(corz,corp,hwll,hwllp,vz,corsst,hsst,varq,qoption,varcw,cwopt

! Optionals
integer(i_kind),optional ,intent(in ) :: lunit ! an alternative unit
!! integer(i_kind), optional ,intent(in ) :: n_clouds_fwd
!! character(len=*),optional ,intent(in ) :: cloud_names_fwd(:)

! !REVISION HISTORY:
! 30Jul08 - Jing Guo <guo@gmao.gsfc.nasa.gov>
Expand Down Expand Up @@ -644,7 +636,6 @@ subroutine bin_
do i=1,nlat
corq2x=corq2(i,k)
varq(i,k)=min(max(corq2x,0.00015_r_kind),one)
!! varq_out(i,k) = varq(i,k)
enddo
enddo
do k=1,isig
Expand Down Expand Up @@ -845,7 +836,7 @@ subroutine setcoroz_(coroz,mype)
if ( ierror/=0 ) return ! nothing to do

! sanity check
if ( mype==0 ) write(6,*) myname_,'(PREWGT): mype = ',mype
if ( mype==0 ) write(6,*) myname_,'(PREWGT): enter routine'

mlat=size(coroz,1)
msig=size(coroz,2)
Expand All @@ -871,7 +862,7 @@ subroutine setcoroz_(coroz,mype)
enddo
enddo
enddo
work_oz(nsig+1,mm1)=float(lon1*lat1)
work_oz(nsig+1,mm1)=real(lon1*lat1,r_kind)

call mpi_allreduce(work_oz,work_oz1,(nsig+1)*npe,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
Expand Down Expand Up @@ -944,13 +935,13 @@ subroutine sethwlloz_(hwlloz,mype)
real(r_kind) :: fact
real(r_kind) :: s2u

if ( mype==0 ) write(6,*) myname_,'(PREWGT): mype = ',mype
if ( mype==0 ) write(6,*) myname_,'(PREWGT): enter routine'

s2u=(two*pi*rearth_equator)/nlon
do k=1,nnnn1o
k1=levs_id(k)
if ( k1>0 ) then
if(mype==0) write(6,*) myname_,'(PREWGT): mype = ',mype, k1
if(mype==0) write(6,*) myname_,'(PREWGT): k1 = ',k1
if ( k1<=nsig*3/4 ) then
! fact=1./hwl
fact=r40000/(r400*nlon)
Expand All @@ -962,7 +953,7 @@ subroutine sethwlloz_(hwlloz,mype)
endif
enddo

if ( mype==0 ) write(6,*) myname_,'(PREWGT): mype = ',mype, 'finish sethwlloz_'
if ( mype==0 ) write(6,*) myname_,'(PREWGT): finish sethwlloz_'

return
end subroutine sethwlloz_
Expand Down Expand Up @@ -1055,7 +1046,7 @@ subroutine setcorchem_(cname,corchem,rc)
rc=0

! sanity check
if ( mype==0 ) write(6,*) myname_,'(PREWGT): mype = ',mype
if ( mype==0 ) write(6,*) myname_,'(PREWGT): enter routine'

! Get information for how to use CO2
iptr=-1
Expand Down Expand Up @@ -1096,7 +1087,7 @@ subroutine setcorchem_(cname,corchem,rc)
enddo
enddo
enddo
work_chem(nsig+1,mm1)=float(lon1*lat1)
work_chem(nsig+1,mm1)=real(lon1*lat1,r_kind)

call mpi_allreduce(work_chem,work_chem1,(nsig+1)*npe,mpi_rtype,mpi_sum,&
mpi_comm_world,ierror)
Expand Down
209 changes: 0 additions & 209 deletions src/gsi/m_nc_berror.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@ module m_nc_berror
public :: nc_berror_vars
public :: nc_berror_dims
public :: nc_berror_read
public :: nc_berror_write
public :: nc_berror_getpointer

type nc_berror_vars
Expand Down Expand Up @@ -60,8 +59,6 @@ module m_nc_berror
read_dims_ ; end interface
interface nc_berror_read; module procedure &
read_berror_ ; end interface
interface nc_berror_write; module procedure &
write_berror_ ; end interface
interface nc_berror_vars_init; module procedure &
init_berror_vars_ ; end interface
interface nc_berror_vars_final; module procedure &
Expand Down Expand Up @@ -185,15 +182,6 @@ subroutine read_berror_ (fname,bvars,rc, myid,root)
call check_( nf90_open(fname, NF90_NOWRITE, ncid), rc, mype_, root_ )
if(rc/=0) return

! Read global attributes
! call check_( nf90_inquire(ncid, ndims_, nvars_, ngatts_, unlimdimid_), rc, mype_, root_ )
! call check_( nf90_inq_dimid(ncid, "lon", varid), rc, mype_, root_ )
! call check_( nf90_inquire_dimension(ncid, varid, len=nlon_), rc, mype_, root_ )
! call check_( nf90_inq_dimid(ncid, "lat", varid), rc, mype_, root_ )
! call check_( nf90_inquire_dimension(ncid, varid, len=nlat_), rc, mype_, root_ )
! call check_( nf90_inq_dimid(ncid, "lev", varid), rc, mype_, root_ )
! call check_( nf90_inquire_dimension(ncid, varid, len=nlev_), rc, mype_, root_ )

! Read data to file
allocate(data_in(1,nlat,1))
do nv = 1, nv1d
Expand Down Expand Up @@ -290,203 +278,6 @@ subroutine read_berror_ (fname,bvars,rc, myid,root)

end subroutine read_berror_

subroutine write_berror_ (fname,bvars,plevs,lats,lons,rc, myid,root)
implicit none
character(len=*), intent(in) :: fname ! input filename
type(nc_berror_vars),intent(in) :: bvars ! background error variables
real(4), intent(in) :: lats(:) ! latitudes per GSI: increase index from South to North Pole
real(4), intent(in) :: lons(:) ! longitudea per GSI: increase index from East to West
real(4), intent(in) :: plevs(:)
integer, intent(out) :: rc
integer, intent(in), optional :: myid,root ! accommodate MPI calling programs

character(len=*), parameter :: myname_ = myname//"::write_"
integer, parameter :: NDIMS = 3

! When we create netCDF files, variables and dimensions, we get back
! an ID for each one.
character(len=4) :: cindx
integer :: ncid, dimids(NDIMS)
integer :: x_dimid, y_dimid, z_dimid
integer :: lon_varid, lat_varid, lev_varid
integer :: ii,jj,nl,nv,nn,nlat,nlon,nlev
integer :: mype_,root_
integer, allocatable :: varid1d(:), varid2d(:), varid2dx(:), varidMLL(:)
logical :: verbose

! This is the data array we will write. It will just be filled with
! a progression of integers for this example.
real(4), allocatable :: data_out(:,:,:)

! Return code (status)
rc=0; mype_=0; root_=0
verbose=.true.
if(present(myid).and.present(root) )then
if(myid/=root) verbose=.false.
mype_ = myid
root_ = root
endif

! Set dims
nlat=bvars%nlat
nlon=bvars%nlon
nlev=bvars%nsig

! Always check the return code of every netCDF function call. In
! this example program, wrapping netCDF calls with "call check()"
! makes sure that any return which is not equal to nf90_noerr (0)
! will print a netCDF error message and exit.

! Create the netCDF file. The nf90_clobber parameter tells netCDF to
! overwrite this file, if it already exists.
call check_( nf90_create(fname, NF90_CLOBBER, ncid), rc, mype_, root_ )
if(rc/=0) return

! Define the dimensions. NetCDF will hand back an ID for each.
call check_( nf90_def_dim(ncid, "lon", nlon, x_dimid), rc, mype_, root_ )
call check_( nf90_def_dim(ncid, "lat", nlat, y_dimid), rc, mype_, root_ )
call check_( nf90_def_dim(ncid, "lev", nlev, z_dimid), rc, mype_, root_ )

call check_( nf90_def_var(ncid, "lon", NF90_REAL, x_dimid, lon_varid), rc, mype_, root_ )
call check_( nf90_def_var(ncid, "lat", NF90_REAL, y_dimid, lat_varid), rc, mype_, root_ )
call check_( nf90_def_var(ncid, "lev", NF90_REAL, z_dimid, lev_varid), rc, mype_, root_ )

call check_( nf90_put_att(ncid, lon_varid, "units", "degress"), rc, mype_, root_ )
call check_( nf90_put_att(ncid, lat_varid, "units", "degress"), rc, mype_, root_ )
call check_( nf90_put_att(ncid, lev_varid, "units", "hPa"), rc, mype_, root_ )

! The dimids array is used to pass the IDs of the dimensions of
! the variables. Note that in fortran arrays are stored in
! column-major format.
dimids = (/ x_dimid, y_dimid, z_dimid /)

! Define variables.
allocate(varid1d(nv1d))
do nv = 1, nv1d
call check_( nf90_def_var(ncid, trim(cvars1d(nv)), NF90_REAL, (/ y_dimid /), varid1d(nv)), rc, mype_, root_ )
enddo
allocate(varid2d(nv2d))
do nv = 1, nv2d
call check_( nf90_def_var(ncid, trim(cvars2d(nv)), NF90_REAL, (/ y_dimid, z_dimid /), varid2d(nv)), rc, mype_, root_ )
enddo
allocate(varidMLL(nlev*nvmll))
nn=0
do nv = 1, nvmll
do nl = 1, nlev
nn=nn+1
write(cindx,'(i4.4)') nl
call check_( nf90_def_var(ncid, trim(cvarsMLL(nv))//cindx, NF90_REAL, (/ y_dimid, z_dimid /), varidMLL(nn)), rc, &
mype_, root_ )
enddo
enddo
allocate(varid2dx(nv2dx))
do nv = 1, nv2dx
call check_( nf90_def_var(ncid, trim(cvars2dx(nv)), NF90_REAL, (/ x_dimid, y_dimid /), varid2dx(nv)), rc, mype_, root_ )
enddo

! End define mode. This tells netCDF we are done defining metadata.
call check_( nf90_enddef(ncid), rc, mype_, root_ )

! Write coordinate variables data
call check_( nf90_put_var(ncid, lon_varid, lons ), rc, mype_, root_ )
call check_( nf90_put_var(ncid, lat_varid, lats ), rc, mype_, root_ )
call check_( nf90_put_var(ncid, lev_varid, plevs), rc, mype_, root_ )

! Write data to file
allocate(data_out(1,nlat,1))
do nv = 1, nv1d
if(trim(cvars1d(nv))=="ps" ) data_out(1,:,1) = bvars%psvar
if(trim(cvars1d(nv))=="hps" ) data_out(1,:,1) = bvars%pshln
call check_( nf90_put_var(ncid, varid1d(nv), data_out(1,:,1)), rc, mype_, root_)
enddo
deallocate(data_out)
allocate(data_out(1,nlat,nlev))
do nv = 1, nv2d
if(trim(cvars2d(nv))=="sf" ) data_out(1,:,:) = bvars%sfvar
if(trim(cvars2d(nv))=="hsf") data_out(1,:,:) = bvars%sfhln
if(trim(cvars2d(nv))=="vsf") data_out(1,:,:) = bvars%sfvln
!
if(trim(cvars2d(nv))=="vp" ) data_out(1,:,:) = bvars%vpvar
if(trim(cvars2d(nv))=="hvp") data_out(1,:,:) = bvars%vphln
if(trim(cvars2d(nv))=="vvp") data_out(1,:,:) = bvars%vpvln
!
if(trim(cvars2d(nv))=="t" ) data_out(1,:,:) = bvars%tvar
if(trim(cvars2d(nv))=="ht" ) data_out(1,:,:) = bvars%thln
if(trim(cvars2d(nv))=="vt" ) data_out(1,:,:) = bvars%tvln
!
if(trim(cvars2d(nv))=="q" ) data_out(1,:,:) = bvars%qvar
if(trim(cvars2d(nv))=="hq" ) data_out(1,:,:) = bvars%qhln
if(trim(cvars2d(nv))=="vq" ) data_out(1,:,:) = bvars%qvln
!
if(trim(cvars2d(nv))=="qi" ) data_out(1,:,:) = bvars%qivar
if(trim(cvars2d(nv))=="hqi") data_out(1,:,:) = bvars%qihln
if(trim(cvars2d(nv))=="vqi") data_out(1,:,:) = bvars%qivln
!
if(trim(cvars2d(nv))=="ql" ) data_out(1,:,:) = bvars%qlvar
if(trim(cvars2d(nv))=="hql") data_out(1,:,:) = bvars%qlhln
if(trim(cvars2d(nv))=="vql") data_out(1,:,:) = bvars%qlvln
!
if(trim(cvars2d(nv))=="qr" ) data_out(1,:,:) = bvars%qrvar
if(trim(cvars2d(nv))=="hqr") data_out(1,:,:) = bvars%qrhln
if(trim(cvars2d(nv))=="vqr") data_out(1,:,:) = bvars%qrvln
!
if(trim(cvars2d(nv))=="nrh") data_out(1,:,:) = bvars%nrhvar
if(trim(cvars2d(nv))=="qs" ) data_out(1,:,:) = bvars%qsvar
if(trim(cvars2d(nv))=="hqs") data_out(1,:,:) = bvars%qshln
if(trim(cvars2d(nv))=="vqs") data_out(1,:,:) = bvars%qsvln
!
if(trim(cvars2d(nv))=="cw" ) data_out(1,:,:) = bvars%cvar
if(trim(cvars2d(nv))=="hcw") data_out(1,:,:) = bvars%chln
if(trim(cvars2d(nv))=="vcw") data_out(1,:,:) = bvars%cvln
!
if(trim(cvars2d(nv))=="oz" ) data_out(1,:,:) = bvars%ozvar
if(trim(cvars2d(nv))=="hoz") data_out(1,:,:) = bvars%ozhln
if(trim(cvars2d(nv))=="voz") data_out(1,:,:) = bvars%ozvln
!
if(trim(cvars2d(nv))=="pscon") data_out(1,:,:) = bvars%pscon
if(trim(cvars2d(nv))=="vpcon") data_out(1,:,:) = bvars%vpcon
!
call check_( nf90_put_var(ncid, varid2d(nv), data_out(1,:,:)), rc, mype_, root_ )
enddo

! Choose to write out NLATxNLEVxNLEV vars as to facilitate visualization
nn=0
do nv = 1, nvmll
do nl = 1, nlev
nn = nn + 1
write(cindx,'(i4.4)') nl
if(trim(cvarsMLL(nv))=="tcon") data_out(1,:,:) = bvars%tcon(:,:,nl)
call check_( nf90_put_var(ncid, varidMLL(nn), data_out(1,:,:)), rc, mype_, root_ )
enddo
enddo
deallocate(data_out)

! Write out lat/lon fields
allocate(data_out(nlon,nlat,1))
do nv = 1, nv2dx
if(trim(cvars2dx(nv))=="sst" ) then
data_out(:,:,1) = transpose(bvars%varsst)
endif
if(trim(cvars2dx(nv))=="hsst" ) then
data_out(:,:,1) = transpose(bvars%corlsst)
endif
call check_( nf90_put_var(ncid, varid2dx(nv), data_out(:,:,1)), rc, mype_, root_ )
enddo
deallocate(data_out)

! Close file
call check_( nf90_close(ncid), rc, mype_, root_ )

deallocate(varidMLL)
deallocate(varid2d)
deallocate(varid1d)

if(verbose) print *,"*** Finish writing file: ", trim(fname)

return

end subroutine write_berror_

subroutine init_berror_vars_(vr,nlon,nlat,nsig)

integer,intent(in) :: nlon,nlat,nsig
Expand Down

0 comments on commit 68d52ac

Please sign in to comment.