Skip to content

Update gsibec codes to fix issue with NaNs during the second outer loop #533

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
ShunLiu-NOAA merged 4 commits into from
Feb 6, 2026
Merged

Update gsibec codes to fix issue with NaNs during the second outer loop #533

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
26cf47d
update codes for masanori's fixes
Feb 5, 2026
a86636f
update compute_qvar3d.F90 too
Feb 5, 2026
8492cb9
fix srun version on Hera
SamuelDegelia-NOAA Feb 5, 2026
5f540f2
fix empty line
SamuelDegelia-NOAA Feb 5, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion modulefiles/RDAS/hera.intel.lua
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ setenv("CC","mpiicc")
setenv("FC","mpiifort")
setenv("CXX","mpiicpc")

local mpiexec = '/apps/slurm_hera/default/bin/srun'
local mpiexec = '/apps/slurm/default/bin/srun'
local mpinproc = '-n'
setenv('MPIEXEC_EXEC', mpiexec)
setenv('MPIEXEC_NPROC', mpinproc)
Expand Down
8 changes: 6 additions & 2 deletions sorc/_workaround_/gsibec/compute_qvar3d.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -134,14 +134,18 @@ subroutine compute_qvar3d

if (qoption==2) then
allocate(rhgues(lat2,lon2,nsig))

do k=1,nsig
do j=1,lon2
do i=1,lat2
rhgues(i,j,k)=qgues(i,j,k)/qsatg(i,j,k)
if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
!if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
if(regional .and. abs(ges_tsen(i,j,k,ntguessig)) > 1.0e30) then
rhgues(i,j,k)=0.5
endif
if(.not.abs(rhgues(i,j,k))<1000.) then
write(6,*)"Error: rhgues setting", rhgues(i,j,k)
call stop2(540)
endif
end do
end do
end do
Expand Down
6 changes: 4 additions & 2 deletions sorc/_workaround_/gsibec/gsi_convert_cv_mod.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,8 @@ subroutine tv_to_t_tl_(tv,tv_tl,q,q_tl,t_tl,t)
do j = 1, size(t_tl,2)
do i = 1, size(t_tl,1)

if(t(i,j,k) < rmiss_th) then
!if(t(i,j,k) < rmiss_th) then
if(abs(t(i,j,k)) > 1.0e30) then
t_tl(i,j,k) = zero
cycle
endif
Expand Down Expand Up @@ -107,7 +108,8 @@ subroutine tv_to_t_ad_(tv,tv_ad,q,q_ad,t_ad,t)
do j = 1, size(t_ad,2)
do i = 1, size(t_ad,1)

if(t(i,j,k) < rmiss_th) then
!if(t(i,j,k) < rmiss_th) then
if(abs(t(i,j,k)) > 1.0e30) then
tv_ad(i,j,k) = zero
q_ad(i,j,k) = zero
t_ad(i,j,k) = zero
Expand Down
245 changes: 0 additions & 245 deletions sorc/_workaround_/gsibec/guess_grids.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1114,76 +1114,6 @@ subroutine guess_basics2_(vname,islot,var)
if (ier/=0) then
call die(myname_,'pointer to '//trim(vname)//" not found",ier)
endif

if(mype == 0) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d(var(:,i))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d(var(j,:))
enddo
!$omp end parallel do
else if(mype == nxpe-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d(var(:,i))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d_rev(var(j,:))
enddo
!$omp end parallel do
else if(mype == nxpe*(nype-1)) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d_rev(var(:,i))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d(var(j,:))
enddo
!$omp end parallel do
else if(mype == nxpe*nype-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d_rev(var(:,i))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d_rev(var(j,:))
enddo
!$omp end parallel do
else if(mype>0 .and. mype<nxpe-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d(var(:,i))
enddo
!$omp end parallel do
else if(mype>nxpe*(nype-1) .and. mype<nxpe*nype-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_1d_rev(var(:,i))
enddo
!$omp end parallel do
else if(mod(mype,nxpe)==0 .and. mype>0 .and. mype<nxpe*(nype-1)) then
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d(var(j,:))
enddo
!$omp end parallel do
else if(mod(mype,nxpe)==nxpe-1 .and. mype>nxpe-1 .and. mype<nxpe*nype-1) then
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_1d_rev(var(j,:))
enddo
!$omp end parallel do
endif
ptr=var
if ( trim(vname) == 'ps' ) ptr=kPa_per_Pa*ptr ! RT_TBD: is this the best place for this?
if ( trim(vname) == 'z' ) ptr=ptr/grav ! RT_TBD: is this the best place for this?
Expand All @@ -1203,76 +1133,6 @@ subroutine guess_basics3_(vname,islot,var)
if (ier/=0) then
call die(myname_,'pointer to '//trim(vname)//" not found",ier)
endif

if(mype == 0) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d(var(:,i,:))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d(var(j,:,:))
enddo
!$omp end parallel do
else if(mype == nxpe-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d(var(:,i,:))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d_rev(var(j,:,:))
enddo
!$omp end parallel do
else if(mype == nxpe*(nype-1)) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d_rev(var(:,i,:))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d(var(j,:,:))
enddo
!$omp end parallel do
else if(mype == nxpe*nype-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d_rev(var(:,i,:))
enddo
!$omp end parallel do
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d_rev(var(j,:,:))
enddo
!$omp end parallel do
else if(mype>0 .and. mype<nxpe-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d(var(:,i,:))
enddo
!$omp end parallel do
else if(mype>nxpe*(nype-1) .and. mype<nxpe*nype-1) then
!$omp parallel do default(shared) private(i)
do i = 1, size(var,2)
call put_data_2d_rev(var(:,i,:))
enddo
!$omp end parallel do
else if(mod(mype,nxpe)==0 .and. mype>0 .and. mype<nxpe*(nype-1)) then
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d(var(j,:,:))
enddo
!$omp end parallel do
else if(mod(mype,nxpe)==nxpe-1 .and. mype>nxpe-1 .and. mype<nxpe*nype-1) then
!$omp parallel do default(shared) private(j)
do j = 1, size(var,1)
call put_data_2d_rev(var(j,:,:))
enddo
!$omp end parallel do
endif
ptr=var
if ( trim(vname) == 'oz' ) then
call gsi_metguess_get ( 'usrvar::o3ppmv', uvar, ier )
Expand All @@ -1282,109 +1142,4 @@ subroutine guess_basics3_(vname,islot,var)
endif

end subroutine guess_basics3_
!--------------------------------------------------------
subroutine put_data_1d(x)
implicit none
real(r_kind), intent(inout) :: x(:)
real(r_kind), parameter :: rmiss = -3.334767057904812e38
real(r_kind), parameter :: rmiss_th = -1.0e30
integer :: n, k, first_valid

n = size(x)

first_valid = 0
do k = 1, n
if (x(k) > rmiss_th) then
first_valid = k
exit
end if
end do

if (first_valid <= 0) return

if (first_valid > 1) then
x(1:first_valid-1) = x(first_valid)
end if

end subroutine put_data_1d
!--------------------------------------------------------
subroutine put_data_1d_rev(x)
implicit none
real(r_kind), intent(inout) :: x(:)
real(r_kind), parameter :: rmiss = -3.334767057904812e38
real(r_kind), parameter :: rmiss_th = -1.0e30
integer :: n, k, first_valid

n = size(x)

first_valid = 0
do k = n, 1, -1
if (x(k) > rmiss_th) then
first_valid = k
exit
end if
end do

if (first_valid <= 0) return

if (first_valid > 1) then
x(first_valid+1:n) = x(first_valid)
end if

end subroutine put_data_1d_rev
!--------------------------------------------------------
subroutine put_data_2d(x)
implicit none
real(r_kind), intent(inout) :: x(:,:)
real(r_kind), parameter :: rmiss = -3.334767057904812e38
real(r_kind), parameter :: rmiss_th = -1.0e30
integer :: n, k, first_valid, i

n = size(x,1)

first_valid = 0
do k = 1, n
if (x(k,1) > rmiss_th) then
first_valid = k
exit
end if
end do

if (first_valid <= 0) return

if (first_valid > 1) then
do i = 1, first_valid-1
x(i,:) = x(first_valid,:)
enddo
end if

end subroutine put_data_2d
!--------------------------------------------------------
subroutine put_data_2d_rev(x)
implicit none
real(r_kind), intent(inout) :: x(:,:)
real(r_kind), parameter :: rmiss = -3.334767057904812e38
real(r_kind), parameter :: rmiss_th = -1.0e30
integer :: n, k, first_valid, i

n = size(x,1)

first_valid = 0
do k = n, 1, -1
if (x(k,1) > rmiss_th) then
first_valid = k
exit
end if
end do

if (first_valid <= 0) return

if (first_valid > 1) then
do i = first_valid+1, n
x(i,:) = x(first_valid,:)
enddo
end if

end subroutine put_data_2d_rev
!--------------------------------------------------------
end module guess_grids
42 changes: 37 additions & 5 deletions sorc/_workaround_/gsibec/normal_rh_to_q.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -50,7 +50,8 @@ subroutine normal_rh_to_q(rhnorm,t,p,q)
do k=1,nsig
do j=1,lon2
do i=1,lat2
if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
!if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
if(regional .and. abs(ges_tsen(i,j,k,ntguessig)) > 1.0e30) then
q(i,j,k) = zero
cycle
endif
Expand Down Expand Up @@ -124,18 +125,49 @@ subroutine normal_rh_to_q_ad(rhnorm,t,p,q)
do k=1,nsig
do j=1,lon2
do i=1,lat2
if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
!if(regional .and. ges_tsen(i,j,k,ntguessig) < rmiss_th) then
if(regional .and. abs(ges_tsen(i,j,k,ntguessig)) > 1.0e30) then
rhnorm(i,j,k) = zero
t(i,j,k ) = zero
p(i,j,k ) = zero
p(i,j,k+1) = zero
if ( qoption == 2 ) then
t(i,j,k ) = zero
p(i,j,k ) = zero
p(i,j,k+1) = zero
endif
q(i,j,k) = zero
cycle
!else if(regional .and. ges_tsen(i,j,k,ntguessig) >= rmiss_th .and. .not.abs(ges_tsen(i,j,k,ntguessig))<1000.) then
else if(regional .and. .not.abs(ges_tsen(i,j,k,ntguessig))<1000.) then
write(6,*)"Error: not abs(ges_tsen(i,j,k,ntguessig)) < 1000.",ges_tsen(i,j,k,ntguessig)
call stop2(541)
endif
if(.not.abs(dqdrh(i,j,k))< 1000.) then
write(6,*)"Error: not abs(dqdrh(i,j,k))< 1000.",dqdrh(i,j,k)
call stop2(542)
endif
if(.not.abs(dqdt(i,j,k))< 1000.) then
write(6,*)"Error: not abs(dqdt(i,j,k))< 1000.",dqdt(i,j,k)
call stop2(543)
endif
if(.not.abs(dqdp(i,j,k))< 1000.) then
write(6,*)"Error: not abs(dqdp(i,j,k))< 1000.",dqdp(i,j,k)
call stop2(544)
endif
rhnorm(i,j,k) = rhnorm(i,j,k) + dqdrh(i,j,k)*q(i,j,k)
if(.not.abs(rhnorm(i,j,k))< 1000.) then
write(6,*)"Error: not abs(rhnorm(i,j,k))< 1000.",rhnorm(i,j,k)
call stop2(545)
endif
if ( qoption == 2 ) then
t(i,j,k ) = t(i,j,k ) + dqdt(i,j,k)*q(i,j,k)
if(.not.abs(t(i,j,k))< 1000.) then
write(6,*)"Error: not abs(t(i,j,k))< 1000.",t(i,j,k)
call stop2(546)
endif
p(i,j,k ) = p(i,j,k ) - dqdp(i,j,k)*q(i,j,k)
if(.not.abs(p(i,j,k))< 1000.) then
write(6,*)"Error: not abs(p(i,j,k))< 1000.",p(i,j,k)
call stop2(547)
endif
p(i,j,k+1) = p(i,j,k+1) - dqdp(i,j,k)*q(i,j,k)
endif
q(i,j,k) = zero
Expand Down