Skip to content

Replace EXTERNAL declarations with INTERFACE and CONTAINS for safer procedure referencing in WW3 and operational workflow #1521

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
merged 8 commits into from
Nov 17, 2025
Merged

Replace EXTERNAL declarations with INTERFACE and CONTAINS for safer procedure referencing in WW3 and operational workflow #1521

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
e2677f9
replace EXTERNAL declaration by interface in serv_xnl4v5.f90
mingchen-NOAA Oct 30, 2025
15ff1ba
replace EXTERNAL declaration in w3profsmd
mingchen-NOAA Oct 30, 2025
297e6e2
fix pgmres linker errors in debug build
mingchen-NOAA Nov 2, 2025
844050e
Merge branch 'NOAA-EMC:develop' into ww3/replaceExternalDeclarations
mingchen-NOAA Nov 2, 2025
e2e54ce
Merge branch 'NOAA-EMC:develop' into ww3/replaceExternalDeclarations
mingchen-NOAA Nov 12, 2025
dc22eef
Merge branch 'NOAA-EMC:develop' into ww3/replaceExternalDeclarations
mingchen-NOAA Nov 13, 2025
642d06a
fix non-b4b in ww3_ts4 using pointer remap
mingchen-NOAA Nov 14, 2025
e8c64cb
set moved subroutines and functions private
mingchen-NOAA Nov 14, 2025
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
9 changes: 7 additions & 2 deletions model/src/serv_xnl4v5.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -497,7 +497,13 @@ real function z_root2(func,x1,x2,xacc,iprint,ierr)
!
implicit none
!
real func ! external function
abstract interface
real function func_proto(x)
real, intent(in) :: x
end function func_proto
end interface
procedure(func_proto) :: func
!
real, intent (in) :: x1 ! x-value at one side of interval
real, intent (in) :: x2 ! x-value at other side of interval
real, intent (in) :: xacc ! requested accuracy
Expand All @@ -512,7 +518,6 @@ real function z_root2(func,x1,x2,xacc,iprint,ierr)
logical lopen ! check if a file is opened

parameter (maxit = 20)
external func
!
integer iter ! counter for number of iterations
real fh ! function value FUNC(xh)
Expand Down
76 changes: 53 additions & 23 deletions model/src/w3profsmd.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,12 @@ MODULE W3PROFSMD
!/ ------------------------------------------------------------------- /
!/
PUBLIC

PRIVATE :: bcgstab, implu, uppdir, givens, stopbis, tidycg, brkdn, &
bisinit, mgsro, amux, amuxms, atmux, atmuxr, amuxe, amuxd, &
amuxj, vbrmv, lsol, ldsol, lsolc, ldsolc, ldsoll, usol, &
udsol, usolc, udsolc, lusol, lutsol, qsplit, runrc, ilut, &
ilu0, pgmres, DNRM2, DLASSQ, ddot, daxpy
!/
CONTAINS
!/ ------------------------------------------------------------------- /
Expand Down Expand Up @@ -1105,8 +1111,6 @@ SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC)
REAL*8 :: AU(NNZ+1)
REAL*8 :: INIU(NX)

external bcgstab

POS_TRICK(1,1) = 2
POS_TRICK(1,2) = 3
POS_TRICK(2,1) = 3
Expand Down Expand Up @@ -1664,11 +1668,6 @@ SUBROUTINE SETDEPTH

END SUBROUTINE SETDEPTH

!/ ------------------------------------------------------------------- /

END MODULE W3PROFSMD


!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
Expand Down Expand Up @@ -2083,12 +2082,6 @@ subroutine bcgstab(n, rhs, sol, ipar, fpar, w)
! here, so that the right-preconditioning may be applied
! at the end
!-----------------------------------------------------------------------
! external routines used
!
real*8 ddot
logical stopbis, brkdn
external ddot, stopbis, brkdn
!
real*8 one
parameter(one=1.0D0)
!
Expand Down Expand Up @@ -2368,6 +2361,7 @@ subroutine bcgstab(n, rhs, sol, ipar, fpar, w)
end subroutine bcgstab
!-----------------------------------------------------------------------
subroutine implu(np,umm,beta,ypiv,u,permut,full)
implicit none
real*8 umm,beta,ypiv(*),u(*),x, xpiv
logical full, perm, permut(*)
integer np,k,npm1
Expand Down Expand Up @@ -2500,8 +2494,7 @@ end subroutine givens
logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx)
implicit none
integer n,mvpi,ipar(16)
real*8 fpar(16), r(n), delx(n), sx, ddot
external ddot
real*8 fpar(16), r(n), delx(n), sx
!-----------------------------------------------------------------------
! function for determining the stopping criteria. return value of
! true if the stopbis criteria is satisfied.
Expand Down Expand Up @@ -2732,9 +2725,8 @@ subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr)
! External routines used: real*8 ddot
!-----------------------------------------------------------------------
integer i,k
real*8 nrm0, nrm1, fct, thr, ddot, zero, one, reorth
real*8 nrm0, nrm1, fct, thr, zero, one, reorth
parameter (zero=0.0D0, one=1.0D0, reorth=0.98D0)
external ddot
!
! compute the norm of the input vector
!
Expand Down Expand Up @@ -2853,6 +2845,7 @@ end subroutine mgsro
! 1) M A T R I X B Y V E C T O R P R O D U C T S c
!----------------------------------------------------------------------c
subroutine amux (n, x, y, a,ja,ia)
implicit none
real*8 x(*), y(*), a(*)
integer n, ja(*), ia(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -2899,6 +2892,7 @@ subroutine amux (n, x, y, a,ja,ia)
end subroutine amux
!-----------------------------------------------------------------------
subroutine amuxms (n, x, y, a,ja)
implicit none
real*8 x(*), y(*), a(*)
integer n, ja(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -2941,6 +2935,7 @@ subroutine amuxms (n, x, y, a,ja)
end subroutine amuxms
!-----------------------------------------------------------------------
subroutine atmux (n, x, y, a, ja, ia)
implicit none
real*8 x(*), y(*), a(*)
integer n, ia(*), ja(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -2990,6 +2985,7 @@ subroutine atmux (n, x, y, a, ja, ia)
end subroutine atmux
!-----------------------------------------------------------------------
subroutine atmuxr (m, n, x, y, a, ja, ia)
implicit none
real*8 x(*), y(*), a(*)
integer m, n, ia(*), ja(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3088,6 +3084,7 @@ subroutine amuxe (n,x,y,na,ncol,a,ja)
end subroutine amuxe
!-----------------------------------------------------------------------
subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff)
implicit none
integer n, ndiag, idiag, ioff(idiag)
real*8 x(n), y(n), diag(ndiag,idiag)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3140,6 +3137,7 @@ subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff)
end subroutine amuxd
!-----------------------------------------------------------------------
subroutine amuxj (n, x, y, jdiag, a, ja, ia)
implicit none
integer n, jdiag, ja(*), ia(*)
real*8 x(n), y(n), a(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3195,6 +3193,7 @@ end subroutine amuxj
!-----------------------------------------------------------------------
subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b)
!-----------------------------------------------------------------------
implicit none
integer nr, nc, ia(nr+1), ja(*), ka(*), kvstr(nr+1), kvstc(*)
real*8 a(*), x(*), b(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3248,6 +3247,7 @@ end subroutine vbrmv
! 2) T R I A N G U L A R S Y S T E M S O L U T I O N S c
!----------------------------------------------------------------------c
subroutine lsol (n,x,y,al,jal,ial)
implicit none
integer n, jal(*),ial(n+1)
real*8 x(n), y(n), al(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3291,6 +3291,7 @@ subroutine lsol (n,x,y,al,jal,ial)
end subroutine lsol
!-----------------------------------------------------------------------
subroutine ldsol (n,x,y,al,jal)
implicit none
integer n, jal(*)
real*8 x(n), y(n), al(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3334,6 +3335,7 @@ subroutine ldsol (n,x,y,al,jal)
end subroutine ldsol
!-----------------------------------------------------------------------
subroutine lsolc (n,x,y,al,jal,ial)
implicit none
integer n, jal(*),ial(*)
real*8 x(n), y(n), al(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3378,6 +3380,7 @@ subroutine lsolc (n,x,y,al,jal,ial)
end subroutine lsolc
!-----------------------------------------------------------------------
subroutine ldsolc (n,x,y,al,jal)
implicit none
integer n, jal(*)
real*8 x(n), y(n), al(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3425,6 +3428,7 @@ subroutine ldsolc (n,x,y,al,jal)
end subroutine ldsolc
!-----------------------------------------------------------------------
subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev)
implicit none
integer n, nlev, jal(*), ilev(nlev+1), lev(n)
real*8 x(n), y(n), al(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3477,6 +3481,7 @@ subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev)
end subroutine ldsoll
!-----------------------------------------------------------------------
subroutine usol (n,x,y,au,jau,iau)
implicit none
integer n, jau(*),iau(n+1)
real*8 x(n), y(n), au(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3520,6 +3525,7 @@ subroutine usol (n,x,y,au,jau,iau)
end subroutine usol
!-----------------------------------------------------------------------
subroutine udsol (n,x,y,au,jau)
implicit none
integer n, jau(*)
real*8 x(n), y(n),au(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3564,6 +3570,7 @@ subroutine udsol (n,x,y,au,jau)
end subroutine udsol
!-----------------------------------------------------------------------
subroutine usolc (n,x,y,au,jau,iau)
implicit none
real*8 x(*), y(*), au(*)
integer n, jau(*),iau(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3608,6 +3615,7 @@ subroutine usolc (n,x,y,au,jau,iau)
end subroutine usolc
!-----------------------------------------------------------------------
subroutine udsolc (n,x,y,au,jau)
implicit none
integer n, jau(*)
real*8 x(n), y(n), au(*)
!-----------------------------------------------------------------------
Expand Down Expand Up @@ -3784,8 +3792,20 @@ end subroutine qsplit
subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver)
implicit none
integer n,ipar(16),ia(n+1),ja(*),ju(*),jau(*)
real*8 fpar(16),rhs(n),sol(n),guess(n),wk(*),a(*),au(*)
external solver
real*8 fpar(16),rhs(n),sol(n),guess(n),a(*),au(*)
real*8, target :: wk(*)
!
abstract interface
subroutine solver_proto(n,rhs,sol,ipar,fpar,w)
implicit none
integer n
real*8 rhs(n), sol(n), w(n,8)
integer ipar(16)
real*8 fpar(16)
end subroutine solver_proto
end interface
procedure(solver_proto) :: solver
!
!-----------------------------------------------------------------------
! the actual tester. It starts the iterative linear system solvers
! with a initial guess suppied by the user.
Expand All @@ -3797,6 +3817,7 @@ subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver)
! local variables
!
integer :: i, its
real*8, pointer :: w_2d(:,:)
! real :: dtime, dt(2), time
! external dtime
save its
Expand All @@ -3816,9 +3837,10 @@ subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver)
!
ipar(1) = 0
! time = dtime(dt)

w_2d(1:n,1:8) => wk(1:n*8)

do
call solver(n,rhs,sol,ipar,fpar,wk)
call solver(n,rhs,sol,ipar,fpar,w_2d)

if (ipar(7).ne.its) then
its = ipar(7)
Expand Down Expand Up @@ -4208,7 +4230,7 @@ end subroutine ilut
!----------------------------------------------------------------------
! subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ipoint1, ipoint2, ierr)
subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr)

implicit none
!implicit real*8 (a-h,o-z)
real*8 a(*), alu(*), tl
integer n, ju0, ii, jj, i, j, jcol, js, jf, jm, jrow, jw, ierr
Expand Down Expand Up @@ -4285,7 +4307,7 @@ subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, nnz, ia, ja, alu, jlu, ju
real*8 :: rhs(*), sol(*)

real*8 :: eps
real*8 :: eps1, epsmac, gam, t, ddot, dnrm2, ro, tl
real*8 :: eps1, epsmac, gam, t, ro, tl

integer :: i,i1,j,jj,k,k1,iii,ii,ju0
integer :: its,jrow,jcol,jf,jm,js,jw
Expand Down Expand Up @@ -4535,6 +4557,7 @@ end subroutine pgmres
! subroutine from blas1.f90
!-----------------------------------------------------------------------
DOUBLE PRECISION FUNCTION DNRM2(N,X)
implicit none
! .. Scalar Arguments ..
INTEGER N
! ..
Expand Down Expand Up @@ -4608,6 +4631,7 @@ SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ )
! -- LAPACK auxiliary routine (version 3.1) --
! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
! November 2006
implicit none
INTEGER N
DOUBLE PRECISION SCALE, SUMSQ
DOUBLE PRECISION X( * )
Expand Down Expand Up @@ -4654,6 +4678,7 @@ double precision function ddot(n,dx,dy)
! uses unrolled loops for increments equal to one.
! jack dongarra, linpack, 3/11/78.
!
implicit none
double precision dx(*),dy(*)
integer i,m,mp1,n
!
Expand Down Expand Up @@ -4681,6 +4706,7 @@ subroutine daxpy(n,da,dx,incx,dy,incy)
! uses unrolled loops for increments equal to one.
! jack dongarra, linpack, 3/11/78.
!
implicit none
double precision dx(1),dy(1),da
integer i,incx,incy,ix,iy,m,mp1,n
!
Expand Down Expand Up @@ -4724,3 +4750,7 @@ subroutine daxpy(n,da,dx,incx,dy,incy)
end do
return
end subroutine daxpy

!/ ------------------------------------------------------------------- /

END MODULE W3PROFSMD