From 0b01a67c17fa13617e65b75360e6d07aa3593327 Mon Sep 17 00:00:00 2001 From: "michael.lueken" Date: Fri, 14 Aug 2020 10:24:36 +0000 Subject: [PATCH] GitHub Issue NOAA-EMC/GSI#13. Continuing to clear through coding standard issues in the master. Finished through src/gsi/m_rwnode.F90. --- src/gsi/m_rhs.F90 | 4 +- src/gsi/m_rwNode.F90 | 271 ------------------------------------------- src/gsi/m_rwnode.F90 | 271 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 273 insertions(+), 273 deletions(-) delete mode 100644 src/gsi/m_rwNode.F90 create mode 100644 src/gsi/m_rwnode.F90 diff --git a/src/gsi/m_rhs.F90 b/src/gsi/m_rhs.F90 index baee074688..b54fb64618 100644 --- a/src/gsi/m_rhs.F90 +++ b/src/gsi/m_rhs.F90 @@ -11,7 +11,7 @@ module m_rhs ! program history log: ! 2010-03-22 j guo - added this document block ! 2010-04-22 tangborn- add co knobs -! 2010-05-27 j guo - cut off GPS related variables to m_gpsrhs +! 2010-05-27 j guo - cut off gps related variables to m_gpsrhs ! 2018-08-10 j guo - moved in all type-indices from setuprhsall(). These ! type-indices are now defined from this module itself, ! through an enum block. @@ -113,7 +113,7 @@ module m_rhs real(r_kind),allocatable,dimension(:,: ),save:: rhs_stats_co real(r_kind),allocatable,dimension(: ),save:: rhs_toss_gps - enum, bind(C) + enum, bind(c) enumerator:: i_zero = 0 enumerator:: i_ps diff --git a/src/gsi/m_rwNode.F90 b/src/gsi/m_rwNode.F90 deleted file mode 100644 index 3186fa8ead..0000000000 --- a/src/gsi/m_rwNode.F90 +++ /dev/null @@ -1,271 +0,0 @@ -module m_rwNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_rwNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type rwNode (radar radial winds) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2016-06-23 lippi - add costilt and sintilt for radial wind calculations. Also, -! add cosazm_costilt and sinazm_costilt as u, v -! factors respectively. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: rwNode - - type,extends(obsNode):: rwNode - !type(rw_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! radial wind residual - real(r_kind) :: err2 ! radial wind error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: cosazm ! v factor - real(r_kind) :: sinazm ! u factor - real(r_kind) :: costilt ! u,v factor - real(r_kind) :: sintilt ! w factor - real(r_kind) :: cosazm_costilt! u factor - real(r_kind) :: sinazm_costilt! v factor - real(r_kind) :: wij(8) ! horizontal interpolation weights - integer(i_kind) :: ij(8) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - real (r_kind) :: dlev ! reference to the vertical grid - real (r_kind) :: factw ! factor of 10m wind - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type rwNode - - public:: rwNode_typecast - public:: rwNode_nextcast - interface rwNode_typecast; module procedure typecast_ ; end interface - interface rwNode_nextcast; module procedure nextcast_ ; end interface - - public:: rwNode_appendto - interface rwNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_rwNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(rwNode) - use m_obsNode, only: obsNode - implicit none - type(rwNode ),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(rwNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(rwNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(rwNode ),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(rwNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[rwNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(rwNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent( out):: istat - type(obs_diags),intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - skip_=.false. - if(present(skip)) skip_=skip - - istat=0 - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%cosazm , & - aNode%sinazm , & - aNode%sintilt , & - aNode%costilt , & - aNode%cosazm_costilt , & - aNode%sinazm_costilt , & - aNode%dlev , & - aNode%factw , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not.associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(rwNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' -_ENTRY_(myname_) - - jstat=0 - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%cosazm , & - aNode%sinazm , & - aNode%sintilt , & - aNode%costilt , & - aNode%cosazm_costilt , & - aNode%sinazm_costilt , & - aNode%dlev , & - aNode%factw , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(rwNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij) - aNode%wij(1:8) = aNode%wij(1:8)*aNode%factw -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(rwNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -_ENTRY_(myname_) - isvalid_=associated(aNode%diags) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(rwNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_rwNode diff --git a/src/gsi/m_rwnode.F90 b/src/gsi/m_rwnode.F90 new file mode 100644 index 0000000000..d9255686b5 --- /dev/null +++ b/src/gsi/m_rwnode.F90 @@ -0,0 +1,271 @@ +module m_rwnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_rwnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type rwnode (radar radial winds) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2016-06-23 lippi - add costilt and sintilt for radial wind calculations. Also, +! add cosazm_costilt and sinazm_costilt as u, v +! factors respectively. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: rwnode + + type,extends(obsnode):: rwnode + !type(rw_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! radial wind residual + real(r_kind) :: err2 ! radial wind error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: cosazm ! v factor + real(r_kind) :: sinazm ! u factor + real(r_kind) :: costilt ! u,v factor + real(r_kind) :: sintilt ! w factor + real(r_kind) :: cosazm_costilt! u factor + real(r_kind) :: sinazm_costilt! v factor + real(r_kind) :: wij(8) ! horizontal interpolation weights + integer(i_kind) :: ij(8) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + real (r_kind) :: dlev ! reference to the vertical grid + real (r_kind) :: factw ! factor of 10m wind + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type rwnode + + public:: rwnode_typecast + public:: rwnode_nextcast + interface rwnode_typecast; module procedure typecast_ ; end interface + interface rwnode_nextcast; module procedure nextcast_ ; end interface + + public:: rwnode_appendto + interface rwnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_rwnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(rwnode) + use m_obsnode, only: obsnode + implicit none + type(rwnode ),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(rwnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(rwnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(rwnode ),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(rwnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[rwnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(rwnode),intent(inout):: anode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'.obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%cosazm , & + anode%sinazm , & + anode%sintilt , & + anode%costilt , & + anode%cosazm_costilt , & + anode%sinazm_costilt , & + anode%dlev , & + anode%factw , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not.associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(rwnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'.obsnode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%cosazm , & + anode%sinazm , & + anode%sintilt , & + anode%costilt , & + anode%cosazm_costilt , & + anode%sinazm_costilt , & + anode%dlev , & + anode%factw , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(rwnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%dlev,anode%ij,anode%wij) + anode%wij(1:8) = anode%wij(1:8)*anode%factw +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(rwnode),intent(in):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(anode%diags) +_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(rwnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_rwnode