Skip to content

Commit

Permalink
GitHub Issue NOAA-EMC#13. Continuing to clear through coding standard…
Browse files Browse the repository at this point in the history 
… issues in the master. Finished through src/gsi/lagmod.f90.
  • Loading branch information
@MichaelLueken
MichaelLueken committed Jun 26, 2020
1 parent 2b3a26a commit 182236c
Show file tree
Hide file tree
Showing 19 changed files with 859 additions and 859 deletions.
54 changes: 27 additions & 27 deletions src/gsi/intspd.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,8 @@ module intspdmod
! 2005-11-16 Derber - remove interfaces
! 2008-11-26 Todling - remove intspd_tl; add interface back
! 2009-08-13 lueken - update documentation
! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - implemented obs adjoint test
! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting
! 2012-09-14 Syed RH Rizvi, ncar/nesl/mmm/das - implemented obs adjoint test
! 2016-05-18 guo - replaced ob_type with polymorphic obsnode through type casting
!
! subroutines included:
! sub intspd_
Expand All @@ -25,18 +25,18 @@ module intspdmod
!
!$$$ end documentation block

use m_obsNode, only: obsNode
use m_spdNode, only: spdNode
use m_spdNode, only: spdNode_typecast
use m_spdNode, only: spdNode_nextcast
use m_obsdiagNode, only: obsdiagNode_set
use m_obsnode, only: obsnode
use m_spdnode, only: spdnode
use m_spdnode, only: spdnode_typecast
use m_spdnode, only: spdnode_nextcast
use m_obsdiagnode, only: obsdiagnode_set
implicit none

PRIVATE
PUBLIC intspd
private
public intspd

interface intspd; module procedure &
intspd_
intspd_
end interface

contains
Expand All @@ -60,16 +60,16 @@ subroutine intspd_(spdhead,rval,sval)
! 2005-08-02 derber - modify for variational qc parameters for each ob
! 2005-09-28 derber - consolidate location and weight arrays
! 2006-07-28 derber - modify to use new inner loop obs data structure
! - unify NL qc
! - unify nl qc
! 2007-03-19 tremolet - binning of observations
! 2007-06-05 tremolet - use observation diagnostics structure
! 2007-07-09 tremolet - observation sensitivity
! 2008-01-04 tremolet - Don't apply H^T if l_do_adjoint is false
! 2008-11-28 todling - turn FOTO optional; changed handling of ptr%time
! 2008-01-04 tremolet - Don't apply h^t if l_do_adjoint is false
! 2008-11-28 todling - turn foto optional; changed handling of ptr%time
! 2010-01-29 zhang,b - fix adjoint of linearization
! 2010-02-26 todling - fix for observation sensitivity
! 2010-05-13 todling - update to use gsi_bundle; udpate interface
! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs
! 2012-09-14 Syed RH Rizvi, ncar/nesl/mmm/das - introduced ladtest_obs
!
! input argument list:
! spdhead - obs type pointer to obs structure
Expand Down Expand Up @@ -100,7 +100,7 @@ subroutine intspd_(spdhead,rval,sval)
implicit none

! Declare passed variables
class(obsNode), pointer, intent(in ) :: spdhead
class(obsnode), pointer, intent(in ) :: spdhead
type(gsi_bundle), intent(in ) :: sval
type(gsi_bundle), intent(inout) :: rval

Expand All @@ -114,10 +114,10 @@ subroutine intspd_(spdhead,rval,sval)
real(r_kind) cg_spd,p0,wnotgross,wgross,pg_spd
real(r_kind),pointer,dimension(:) :: su,sv
real(r_kind),pointer,dimension(:) :: ru,rv
type(spdNode), pointer :: spdptr
type(spdnode), pointer :: spdptr
logical :: ltlint_tmp

! If no spd data return
! If no spd data return
if(.not. associated(spdhead))return

! Retrieve pointers
Expand All @@ -134,7 +134,7 @@ subroutine intspd_(spdhead,rval,sval)
ltlint = .true.
end if
!spdptr => spdhead
spdptr => spdNode_typecast(spdhead)
spdptr => spdnode_typecast(spdhead)
do while (associated(spdptr))

j1 = spdptr%ij(1)
Expand All @@ -153,7 +153,7 @@ subroutine intspd_(spdhead,rval,sval)

if (ltlint) then

if (spdtra>EPSILON(spdtra)) then
if (spdtra>epsilon(spdtra)) then
! Forward model
uatl=w1*su(j1)+w2*su(j2)+w3*su(j3)+w4*su(j4)
vatl=w1*sv(j1)+w2*sv(j2)+w3*sv(j3)+w4*sv(j4)
Expand All @@ -164,10 +164,10 @@ subroutine intspd_(spdhead,rval,sval)
if (lsaveobsens) then
grad=spdptr%raterr2*spdptr%err2*spdatl
!-- spdptr%diags%obssen(jiter)=grad
call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=grad)
call obsdiagnode_set(spdptr%diags,jiter=jiter,obssen=grad)
else
!-- if (spdptr%luse) spdptr%diags%tldepart(jiter)=spdatl
if (spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=spdatl)
if (spdptr%luse) call obsdiagnode_set(spdptr%diags,jiter=jiter,tldepart=spdatl)
endif
endif

Expand All @@ -188,9 +188,9 @@ subroutine intspd_(spdhead,rval,sval)
else
if(luse_obsdiag)then
!-- if (spdptr%luse) spdptr%diags%tldepart(jiter)=zero
if (spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=zero)
if (spdptr%luse) call obsdiagnode_set(spdptr%diags,jiter=jiter,tldepart=zero)
!-- if (lsaveobsens) spdptr%diags%obssen(jiter)=zero
if (lsaveobsens) call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=zero)
if (lsaveobsens) call obsdiagnode_set(spdptr%diags,jiter=jiter,obssen=zero)
end if
endif

Expand All @@ -202,7 +202,7 @@ subroutine intspd_(spdhead,rval,sval)
vanl=spdptr%vges+w1* sv(j1)+w2* sv(j2)+w3* sv(j3)+w4* sv(j4)
spdanl=sqrt(uanl*uanl+vanl*vanl)
!-- if (luse_obsdiag .and. spdptr%luse) spdptr%diags%tldepart(jiter)=spdanl-spdtra
if (luse_obsdiag .and. spdptr%luse) call obsdiagNode_set(spdptr%diags,jiter=jiter,tldepart=spdanl-spdtra)
if (luse_obsdiag .and. spdptr%luse) call obsdiagnode_set(spdptr%diags,jiter=jiter,tldepart=spdanl-spdtra)

if (l_do_adjoint) then
valu=zero
Expand All @@ -212,9 +212,9 @@ subroutine intspd_(spdhead,rval,sval)

! Adjoint
! if(spdanl > tiny_r_kind*100._r_kind) then
if (spdanl>EPSILON(spdanl)) then
if (spdanl>epsilon(spdanl)) then
!-- if (luse_obsdiag .and. lsaveobsens) spdptr%diags%obssen(jiter)=grad
if (luse_obsdiag .and. lsaveobsens) call obsdiagNode_set(spdptr%diags,jiter=jiter,obssen=grad)
if (luse_obsdiag .and. lsaveobsens) call obsdiagnode_set(spdptr%diags,jiter=jiter,obssen=grad)
valu=uanl/spdanl
valv=vanl/spdanl
if (nlnqc_iter .and. spdptr%pg > tiny_r_kind .and. &
Expand Down Expand Up @@ -249,7 +249,7 @@ subroutine intspd_(spdhead,rval,sval)
endif

!spdptr => spdptr%llpoint
spdptr => spdNode_nextcast(spdptr)
spdptr => spdnode_nextcast(spdptr)

end do
if( ladtest_obs) ltlint = ltlint_tmp
Expand Down
72 changes: 36 additions & 36 deletions src/gsi/intsst.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,9 +11,9 @@ module intsstmod
! 2005-11-16 Derber - remove interfaces
! 2008-11-26 Todling - remove intsst_tl
! 2009-08-13 lueken - update documentation
! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - implemented obs adjoint test
! 2012-09-14 Syed RH Rizvi, ncar/nesl/mmm/das - implemented obs adjoint test
! 2014-12-03 derber - modify so that use of obsdiags can be turned off
! 2016-05-18 guo - replaced ob_type with polymorphic obsNode through type casting
! 2016-05-18 guo - replaced ob_type with polymorphic obsnode through type casting
!
! subroutines included:
! sub intsst
Expand All @@ -26,15 +26,15 @@ module intsstmod
!
!$$$ end documentation block

use m_obsNode, only: obsNode
use m_sstNode, only: sstNode
use m_sstNode, only: sstNode_typecast
use m_sstNode, only: sstNode_nextcast
use m_obsdiagNode, only: obsdiagNode_set
use m_obsnode, only: obsnode
use m_sstnode, only: sstnode
use m_sstnode, only: sstnode_typecast
use m_sstnode, only: sstnode_nextcast
use m_obsdiagnode, only: obsdiagnode_set
implicit none

PRIVATE
PUBLIC intsst
private
public intsst

contains

Expand All @@ -56,14 +56,14 @@ subroutine intsst(ssthead,rval,sval)
! 2005-08-02 derber - modify for variational qc parameters for each ob
! 2005-09-28 derber - consolidate location and weight arrays
! 2006-07-28 derber - modify to use new inner loop obs data structure
! - unify NL qc
! - unify nl qc
! 2007-03-19 tremolet - binning of observations
! 2007-06-05 tremolet - use observation diagnostics structure
! 2007-07-09 tremolet - observation sensitivity
! 2008-01-04 tremolet - Don't apply H^T if l_do_adjoint is false
! 2008-01-04 tremolet - Don't apply h^t if l_do_adjoint is false
! 2010-05-13 todling - update to use gsi_bundle; update interface
! 2011-04-01 li - modify to include Tr analysis
! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs
! 2011-04-01 li - modify to include tr analysis
! 2012-09-14 Syed RH Rizvi, ncar/nesl/mmm/das - introduced ladtest_obs
!
! input argument list:
! ssthead
Expand All @@ -90,7 +90,7 @@ subroutine intsst(ssthead,rval,sval)
implicit none

! Declare passed variables
class(obsNode), pointer, intent(in ) :: ssthead
class(obsnode), pointer, intent(in ) :: ssthead
type(gsi_bundle), intent(in ) :: sval
type(gsi_bundle), intent(inout) :: rval

Expand All @@ -104,9 +104,9 @@ subroutine intsst(ssthead,rval,sval)
real(r_kind) cg_sst,p0,grad,wnotgross,wgross,pg_sst
real(r_kind),pointer,dimension(:) :: ssst
real(r_kind),pointer,dimension(:) :: rsst
type(sstNode), pointer :: sstptr
type(sstnode), pointer :: sstptr

! If no sst data return
! If no sst data return
if(.not. associated(ssthead))return

! Retrieve pointers
Expand All @@ -117,7 +117,7 @@ subroutine intsst(ssthead,rval,sval)
if(ier/=0)return

!sstptr => ssthead
sstptr => sstNode_typecast(ssthead)
sstptr => sstnode_typecast(ssthead)
do while (associated(sstptr))
j1=sstptr%ij(1)
j2=sstptr%ij(2)
Expand All @@ -133,21 +133,21 @@ subroutine intsst(ssthead,rval,sval)
+w3*ssst(j3)+w4*ssst(j4)

if ( nst_gsi > 2 ) then
tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
val = tdir*sstptr%tz_tr ! Include contributions from Tz jacobian
tdir = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
val = tdir*sstptr%tz_tr ! Include contributions from tz jacobian
else
val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
val = w1*ssst(j1)+w2*ssst(j2)+w3*ssst(j3)+w4*ssst(j4) ! Forward
endif


if(luse_obsdiag)then
if (lsaveobsens) then
grad = val*sstptr%raterr2*sstptr%err2
!-- sstptr%diags%obssen(jiter) = grad
call obsdiagNode_set(sstptr%diags,jiter=jiter,obssen=grad)
call obsdiagnode_set(sstptr%diags,jiter=jiter,obssen=grad)
else
!-- if (sstptr%luse) sstptr%diags%tldepart(jiter)=val
if (sstptr%luse) call obsdiagNode_set(sstptr%diags,jiter=jiter,tldepart=val)
if (sstptr%luse) call obsdiagnode_set(sstptr%diags,jiter=jiter,tldepart=val)
endif
endif

Expand All @@ -172,24 +172,24 @@ subroutine intsst(ssthead,rval,sval)
end if
endif

! Adjoint
if ( nst_gsi > 2 ) then
tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian
rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points
rsst(j2)=rsst(j2)+w2*tval
rsst(j3)=rsst(j3)+w3*tval
rsst(j4)=rsst(j4)+w4*tval
else
rsst(j1)=rsst(j1)+w1*grad
rsst(j2)=rsst(j2)+w2*grad
rsst(j3)=rsst(j3)+w3*grad
rsst(j4)=rsst(j4)+w4*grad
endif
! Adjoint
if ( nst_gsi > 2 ) then
tval = sstptr%tz_tr*grad ! Extract contributions from surface jacobian
rsst(j1)=rsst(j1)+w1*tval ! Distribute adjoint contributions over surrounding grid points
rsst(j2)=rsst(j2)+w2*tval
rsst(j3)=rsst(j3)+w3*tval
rsst(j4)=rsst(j4)+w4*tval
else
rsst(j1)=rsst(j1)+w1*grad
rsst(j2)=rsst(j2)+w2*grad
rsst(j3)=rsst(j3)+w3*grad
rsst(j4)=rsst(j4)+w4*grad
endif

endif ! if (l_do_adjoint) then

!sstptr => sstptr%llpoint
sstptr => sstNode_nextcast(sstptr)
sstptr => sstnode_nextcast(sstptr)

end do

Expand Down
Loading

0 comments on commit 182236c

Please sign in to comment.