Skip to content

Commit

Permalink
Merge branch 'czender/elm_mali/interpinic_netcdf_boz_fixes' (PR #6614)
Browse files Browse the repository at this point in the history 
This new feature allows `interpinic` to interpolate an ELM initial conditions file
that require storage in `NC_FORMAT_64BIT_DATA` and other netCDF4 formats.

[BFB] [Bugfix]
  • Loading branch information
@bishtgautam
bishtgautam committed Sep 24, 2024
2 parents 83eaa7e + ece56d1 commit 3d4085f
Show file tree
Hide file tree
Showing 3 changed files with 81 additions and 57 deletions.
2 changes: 1 addition & 1 deletion components/elm/tools/interpinic/src/fmain.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ program fmain
character(len= 256) :: arg
integer :: n !index
integer :: nargs !number of arguments
integer, external :: iargc !number of arguments function
integer :: iargc !number of arguments function
character(len=256) :: finidati !input initial dataset to read
character(len=256) :: finidato !output initial dataset to create
character(len=256) :: cmdline !input command line
Expand Down
48 changes: 36 additions & 12 deletions components/elm/tools/interpinic/src/interpinic.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -146,9 +146,19 @@ subroutine interp_filei (fin, fout, cmdline)
call check_ret (nf90_open(fin, NF90_NOWRITE, ncidi ))
call check_ret (nf90_open(fout, NF90_NOWRITE, ncido ))
call check_ret (nf_inq_format( ncido, ncformat ))
if ( ncformat /= NF_FORMAT_64BIT )then
write (6,*) 'error: output file is NOT in NetCDF large-file format!'
stop

! Allow any format for output dataset

if ( ncformat == NF_FORMAT_CLASSIC )then
write (6,*) 'info: output file is NF_FORMAT_CLASSIC'
else if ( ncformat == NF_FORMAT_64BIT_OFFSET )then
write (6,*) 'info: output file is NF_FORMAT_64BIT_OFFSET'
else if ( ncformat == NF_FORMAT_64BIT_DATA )then
write (6,*) 'info: output file is NF_FORMAT_64BIT_DATA'
else if ( ncformat == NF_FORMAT_NETCDF4 )then
write (6,*) 'info: output file is NF_FORMAT_NETCDF4'
else if ( ncformat == NF_FORMAT_NETCDF4_CLASSIC )then
write (6,*) 'info: output file is NF_FORMAT_NETCDF4_CLASSIC'
end if

call check_ret (nf90_inq_dimid(ncidi, "column", dimidcols ))
Expand Down Expand Up @@ -214,12 +224,25 @@ subroutine interp_filei (fin, fout, cmdline)
ret = nf90_inq_dimid(ncidi, "month", dimidmon)
if (ret == NF90_NOERR) then
call check_ret (nf90_inquire_dimension(ncidi, dimidmon, len=nlevmon))
call check_ret (nf90_inq_dimid(ncido, "month", dimid ))
call check_ret (nf90_inquire_dimension(ncido, dimid, len=dimlen))
if (dimlen/=nlevmon) then
write (6,*) 'error: input and output nlevmon values disagree'
write (6,*) 'input nlevmon = ',nlevmon,' output nlevmon = ',dimlen
stop

! Many restart files have "month" dimension in input dataset
! It is only necessary that the output dataset contains "month" dimension
! when a variable in the input dataset contains the "month" dimension
! Otherwise, the "month" dimension will never be used
! Warn rather than die when input has "month" and output does not

ret = nf90_inq_dimid(ncido, "month", dimid )
if ( ret == nf_ebaddim ) then
write (6,*) 'warning: input has "month" dimension and output does not'
write (6,*) 'warning: interpolation will fail if any input variable uses "month" dimension'
write (6,*) 'chill: many times the "month" dimension is superfluous so this might work...'
else
call check_ret (nf90_inquire_dimension(ncido, dimid, len=dimlen))
if (dimlen/=nlevmon) then
write (6,*) 'error: input and output nlevmon values disagree'
write (6,*) 'input nlevmon = ',nlevmon,' output nlevmon = ',dimlen
stop
end if
end if
else
write (6,*) 'month dimension does NOT exist on the input dataset'
Expand Down Expand Up @@ -321,7 +344,9 @@ subroutine interp_filei (fin, fout, cmdline)
! OK now, open the output file for writing
!
call check_ret(nf90_close( ncido))
call check_ret (nf90_open(fout, ior(NF90_WRITE, NF_64BIT_OFFSET), ncido ))

! Allow any format for output dataset
call check_ret (nf90_open(fout, NF90_WRITE, ncido ))

call addglobal (ncido, cmdline)

Expand Down Expand Up @@ -1503,8 +1528,7 @@ subroutine addglobal (ncid, cmdline)
character(len=10) :: time
character(len= 5) :: zone
character(len=18) :: datetime
character(len=256):: version = &
"$HeadURL: https://svn-ccsm-models.cgd.ucar.edu/clm2/trunk_tags/clm4_5_1_r085/models/lnd/clm/tools/clm4_5/interpinic/src/interpinic.F90 $"
character(len=256):: version = ""
character(len=256) :: revision_id = "$Id: interpinic.F90 54953 2013-11-06 16:29:45Z sacks $"
character(len=16) :: logname
character(len=16) :: hostname
Expand Down
88 changes: 44 additions & 44 deletions components/elm/tools/interpinic/src/shr_infnan_mod.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,11 +2,11 @@

module shr_infnan_mod

!! Inf_NaN_Detection module
!! Inf_NaN_Detection module
!! Copyright(c) 2003, Lahey Computer Systems, Inc.
!! Copies of this source code, or standalone compiled files
!! Copies of this source code, or standalone compiled files
!! derived from this source may not be sold without permission
!! from Lahey Computers Systems. All or part of this module may be
!! from Lahey Computers Systems. All or part of this module may be
!! freely incorporated into executable programs which are offered
!! for sale. Otherwise, distribution of all or part of this file is
!! permitted, provided this copyright notice and header are included.
Expand All @@ -22,12 +22,12 @@ module shr_infnan_mod
!! isneginf(x) - test for a negative "infinite" value
!!
!! Each function accepts a single or double precision real argument, and
!! returns a true or false value to indicate the presence of the value
!! returns a true or false value to indicate the presence of the value
!! being tested for. If the argument is array valued, the function returns
!! a conformable logical array, suitable for use with the ANY function, or
!! as a logical mask.
!!
!! Each function operates by transferring the bit pattern from a real
!! Each function operates by transferring the bit pattern from a real
!! variable to an integer container. Unless testing for + or - infinity,
!! the sign bit is cleared to zero. The value is exclusive ORed with
!! the value being tested for. The integer result of the IEOR function is
Expand All @@ -48,14 +48,14 @@ module shr_infnan_mod
integer, parameter :: Double = selected_int_kind(precision(1.0_r8))

! Single precision IEEE values
integer(Single), parameter :: sNaN = Z"7FC00000"
integer(Single), parameter :: sPosInf = Z"7F800000"
integer(Single), parameter :: sNegInf = Z"FF800000"
integer(Single), parameter :: sNaN = int(Z"7FC00000")
integer(Single), parameter :: sPosInf = int(Z"7F800000")
integer(Single), parameter :: sNegInf = int(Z"FF800000")

! Double precision IEEE values
integer(Double), parameter :: dNaN = Z"7FF8000000000000"
integer(Double), parameter :: dPosInf = Z"7FF0000000000000"
integer(Double), parameter :: dNegInf = Z"FFF0000000000000"
integer(Double), parameter :: dNaN = int(Z"7FF8000000000000")
integer(Double), parameter :: dPosInf = int(Z"7FF0000000000000")
integer(Double), parameter :: dNegInf = int(Z"FFF0000000000000")

! Locatation of single and double precision sign bit (Intel)
! Subtract one because bit numbering starts at zero
Expand Down Expand Up @@ -84,30 +84,30 @@ module shr_infnan_mod
module procedure sisnan
module procedure disnan
#endif
end interface
end interface

interface shr_infnan_isinf
module procedure sisinf
module procedure disinf
end interface
end interface

interface shr_infnan_isposinf
module procedure sisposinf
module procedure disposinf
end interface
end interface

interface shr_infnan_isneginf
module procedure sisneginf
module procedure disneginf
end interface
end interface


integer :: shr_sisnan
external :: shr_sisnan
integer :: shr_disnan
external :: shr_disnan

contains
contains

!
! If FORTRAN intrinsic's exist use them
Expand All @@ -134,7 +134,7 @@ elemental function sisnan(x) result(res)
res = isnan(x)
#endif

end function
end function

! Double precision test for NaN
elemental function disnan(d) result(res)
Expand All @@ -156,7 +156,7 @@ elemental function disnan(d) result(res)
res = isnan(d)
#endif

end function
end function

!
! Otherwise link to a C function call that either uses the C90 isnan function or a x != x check
Expand All @@ -176,13 +176,13 @@ function c_sisnan_1D(x) result(res)
real(r4), intent(in) :: x(:)
logical :: res(size(x))

integer :: i
integer :: i

do i = 1, size(x)
res(i) = (shr_sisnan(x(i)) /= 0)
end do
end function c_sisnan_1D

function c_sisnan_2D(x) result(res)
real(r4), intent(in) :: x(:,:)
logical :: res(size(x,1),size(x,2))
Expand All @@ -195,7 +195,7 @@ function c_sisnan_2D(x) result(res)
end do
end do
end function c_sisnan_2D

function c_sisnan_3D(x) result(res)
real(r4), intent(in) :: x(:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3))
Expand All @@ -210,7 +210,7 @@ function c_sisnan_3D(x) result(res)
end do
end do
end function c_sisnan_3D

function c_sisnan_4D(x) result(res)
real(r4), intent(in) :: x(:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4))
Expand All @@ -227,7 +227,7 @@ function c_sisnan_4D(x) result(res)
end do
end do
end function c_sisnan_4D

function c_sisnan_5D(x) result(res)
real(r4), intent(in) :: x(:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5))
Expand All @@ -246,7 +246,7 @@ function c_sisnan_5D(x) result(res)
end do
end do
end function c_sisnan_5D

function c_sisnan_6D(x) result(res)
real(r4), intent(in) :: x(:,:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5),size(x,6))
Expand All @@ -267,7 +267,7 @@ function c_sisnan_6D(x) result(res)
end do
end do
end function c_sisnan_6D

function c_sisnan_7D(x) result(res)
real(r4), intent(in) :: x(:,:,:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5),size(x,6),size(x,7))
Expand All @@ -290,7 +290,7 @@ function c_sisnan_7D(x) result(res)
end do
end do
end function c_sisnan_7D

function c_disnan_scalar(x) result(res)
real(r8), intent(in) :: x
logical :: res
Expand All @@ -302,13 +302,13 @@ function c_disnan_1D(x) result(res)
real(r8), intent(in) :: x(:)
logical :: res(size(x))

integer :: i
integer :: i

do i = 1, size(x)
res(i) = (shr_disnan(x(i)) /= 0)
end do
end function c_disnan_1D

function c_disnan_2D(x) result(res)
real(r8), intent(in) :: x(:,:)
logical :: res(size(x,1),size(x,2))
Expand All @@ -321,7 +321,7 @@ function c_disnan_2D(x) result(res)
end do
end do
end function c_disnan_2D

function c_disnan_3D(x) result(res)
real(r8), intent(in) :: x(:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3))
Expand All @@ -336,7 +336,7 @@ function c_disnan_3D(x) result(res)
end do
end do
end function c_disnan_3D

function c_disnan_4D(x) result(res)
real(r8), intent(in) :: x(:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4))
Expand All @@ -353,7 +353,7 @@ function c_disnan_4D(x) result(res)
end do
end do
end function c_disnan_4D

function c_disnan_5D(x) result(res)
real(r8), intent(in) :: x(:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5))
Expand All @@ -372,7 +372,7 @@ function c_disnan_5D(x) result(res)
end do
end do
end function c_disnan_5D

function c_disnan_6D(x) result(res)
real(r8), intent(in) :: x(:,:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5),size(x,6))
Expand All @@ -393,7 +393,7 @@ function c_disnan_6D(x) result(res)
end do
end do
end function c_disnan_6D

function c_disnan_7D(x) result(res)
real(r8), intent(in) :: x(:,:,:,:,:,:,:)
logical :: res(size(x,1),size(x,2),size(x,3),size(x,4),size(x,5),size(x,6),size(x,7))
Expand All @@ -418,48 +418,48 @@ function c_disnan_7D(x) result(res)
end function c_disnan_7D

#endif

! Single precision test for Inf
elemental function sisinf(x) result(res)
real(r4), intent(in) :: x
logical :: res
res = ieor(ibclr(transfer(x,sPosInf),SPSB), sPosInf) == 0
end function
end function

! Double precision test for Inf
elemental function disinf(d) result(res)
real(r8), intent(in) :: d
logical :: res
res = ieor(ibclr(transfer(d,dPosInf),DPSB), dPosInf) == 0
end function
end function

! Single precision test for +Inf
elemental function sisposinf(x) result(res)
real(r4), intent(in) :: x
logical :: res
res = ieor(transfer(x,sPosInf), sPosInf) == 0
end function
end function

! Double precision test for +Inf
elemental function disposinf(d) result(res)
real(r8), intent(in) :: d
logical :: res
res = ieor(transfer(d,dPosInf), dPosInf) == 0
end function
end function

! Single precision test for -Inf
elemental function sisneginf(x) result(res)
real(r4), intent(in) :: x
logical :: res
res = ieor(transfer(x,sNegInf), sNegInf) == 0
end function
end function

! Double precision test for -Inf
elemental function disneginf(d) result(res)
real(r8), intent(in) :: d
logical :: res
res = ieor(transfer(d,dNegInf), dNegInf) == 0
end function
end function

end module shr_infnan_mod

Expand Down

0 comments on commit 3d4085f

Please sign in to comment.