From 856d5f8661191ed7ec653b5990a3e714f1e941a4 Mon Sep 17 00:00:00 2001 From: "michael.lueken" Date: Fri, 14 Aug 2020 18:22:09 +0000 Subject: [PATCH] GitHub Issue NOAA-EMC/GSI#13. Continuing to clear through coding standard issues in the master. Finished through src/gsi/m_sstnode.F90. --- src/gsi/m_sortind.f90 | 87 ++++++++------- src/gsi/m_spdNode.F90 | 253 ------------------------------------------ src/gsi/m_spdnode.F90 | 253 ++++++++++++++++++++++++++++++++++++++++++ src/gsi/m_sstNode.F90 | 249 ----------------------------------------- src/gsi/m_sstnode.F90 | 249 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 548 insertions(+), 543 deletions(-) delete mode 100644 src/gsi/m_spdNode.F90 create mode 100644 src/gsi/m_spdnode.F90 delete mode 100644 src/gsi/m_sstNode.F90 create mode 100644 src/gsi/m_sstnode.F90 diff --git a/src/gsi/m_sortind.f90 b/src/gsi/m_sortind.f90 index 8aeacbbf61..cffc4d67a9 100644 --- a/src/gsi/m_sortind.f90 +++ b/src/gsi/m_sortind.f90 @@ -9,8 +9,8 @@ module m_sortind ! assimilation ! ! program history log: -! 1996-10-01 Joiner/Karki - initial coding from NASA/GMAO -! 2012-02-15 eliu - reformat to use in GSI +! 1996-10-01 Joiner/Karki - initial coding from nasa/gmao +! 2012-02-15 eliu - reformat to use in gsi ! ! subroutines included: ! @@ -24,8 +24,8 @@ module m_sortind use kinds,only : i_kind, r_kind interface sortind - module procedure r_sortind - module procedure i_sortind + module procedure r_sortind + module procedure i_sortind end interface contains @@ -53,13 +53,15 @@ function i_sortind(arr) result(arr2) end function i_sortind - SUBROUTINE indexx(n,arr,indx) + subroutine indexx(n,arr,indx) - INTEGER(i_kind):: n,indx(n),M,NSTACK - REAL(r_kind) :: arr(n) - PARAMETER (M=7,NSTACK=50) - INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL(r_kind) :: a + implicit none + + integer(i_kind):: n,indx(n),m,nstack + real(r_kind) :: arr(n) + parameter (m=7,nstack=50) + integer(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(nstack) + real(r_kind) :: a do 11 j=1,n indx(j)=j 11 continue @@ -67,12 +69,12 @@ SUBROUTINE indexx(n,arr,indx) l=1 ir=n loop2: do - if(ir-l.lt.M)then + if(ir-lnstack)pause 'NSTACK too small in indexx' + if(ir-i+1>=j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 @@ -136,14 +138,17 @@ SUBROUTINE indexx(n,arr,indx) endif endif end do loop2 - END subroutine indexx - - SUBROUTINE iindexx(n,arr,indx) - INTEGER(i_kind):: n,indx(n),M,NSTACK - INTEGER(i_kind):: arr(n) - PARAMETER (M=7,NSTACK=50) - INTEGER(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - INTEGER(i_kind):: a + end subroutine indexx + + subroutine iindexx(n,arr,indx) + + implicit none + + integer(i_kind):: n,indx(n),m,nstack + integer(i_kind):: arr(n) + parameter (m=7,nstack=50) + integer(i_kind):: i,indxt,ir,itemp,j,jstack,k,l,istack(nstack) + integer(i_kind):: a do 11 j=1,n indx(j)=j 11 continue @@ -151,20 +156,20 @@ SUBROUTINE iindexx(n,arr,indx) l=1 ir=n loop2: do - if(ir-l.lt.M)then + if(ir-larr(indx(ir)))then itemp=indx(l+1) indx(l+1)=indx(ir) indx(ir)=itemp endif - if(arr(indx(l)).gt.arr(indx(ir)))then + if(arr(indx(l))>arr(indx(ir)))then itemp=indx(l) indx(l)=indx(ir) indx(ir)=itemp endif - if(arr(indx(l+1)).gt.arr(indx(l)))then + if(arr(indx(l+1))>arr(indx(l)))then itemp=indx(l+1) indx(l+1)=indx(l) indx(l)=itemp @@ -201,16 +206,16 @@ SUBROUTINE iindexx(n,arr,indx) j=j-1 if(arr(indx(j))<=a)exit end do - if(j.lt.i)exit loop1 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp + if(jnstack)pause 'NSTACK too small in indexx' + if(ir-i+1>=j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 @@ -221,6 +226,6 @@ SUBROUTINE iindexx(n,arr,indx) endif endif end do loop2 - END subroutine iindexx + end subroutine iindexx end module m_sortind diff --git a/src/gsi/m_spdNode.F90 b/src/gsi/m_spdNode.F90 deleted file mode 100644 index c46ad60a58..0000000000 --- a/src/gsi/m_spdNode.F90 +++ /dev/null @@ -1,253 +0,0 @@ -module m_spdNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_spdNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type spdNode (wind speed) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! -! 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:: spdNode - - type,extends(obsNode):: spdNode - !type(spd_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! speed observation - real(r_kind) :: err2 ! speed 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) :: wij(4) ! horizontal interpolation weights - real(r_kind) :: uges ! guess u value - real(r_kind) :: vges ! guess v value - integer(i_kind) :: ij(4) ! 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) :: 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 spdNode - - public:: spdNode_typecast - public:: spdNode_nextcast - interface spdNode_typecast; module procedure typecast_ ; end interface - interface spdNode_nextcast; module procedure nextcast_ ; end interface - - public:: spdNode_appendto - interface spdNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_spdNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(spdNode) - use m_obsNode, only: obsNode - implicit none - type(spdNode ),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(spdNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(spdNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(spdNode ),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(spdNode),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="[spdNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(spdNode),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%uges , & - aNode%vges , & - 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(spdNode),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%uges , & - aNode%vges , & - 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(spdNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) - aNode%wij(1:4) = aNode%wij(1:4)*aNode%factw -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(spdNode),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(spdNode), 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_spdNode diff --git a/src/gsi/m_spdnode.F90 b/src/gsi/m_spdnode.F90 new file mode 100644 index 0000000000..49e56e8505 --- /dev/null +++ b/src/gsi/m_spdnode.F90 @@ -0,0 +1,253 @@ +module m_spdnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_spdnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type spdnode (wind speed) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! 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:: spdnode + + type,extends(obsnode):: spdnode + !type(spd_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! speed observation + real(r_kind) :: err2 ! speed 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) :: wij(4) ! horizontal interpolation weights + real(r_kind) :: uges ! guess u value + real(r_kind) :: vges ! guess v value + integer(i_kind) :: ij(4) ! 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) :: 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 spdnode + + public:: spdnode_typecast + public:: spdnode_nextcast + interface spdnode_typecast; module procedure typecast_ ; end interface + interface spdnode_nextcast; module procedure nextcast_ ; end interface + + public:: spdnode_appendto + interface spdnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_spdnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(spdnode) + use m_obsnode, only: obsnode + implicit none + type(spdnode ),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(spdnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(spdnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(spdnode ),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(spdnode),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="[spdnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(spdnode),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%uges , & + anode%vges , & + 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(spdnode),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%uges , & + anode%vges , & + 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(spdnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) + anode%wij(1:4) = anode%wij(1:4)*anode%factw +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(spdnode),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(spdnode), 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_spdnode diff --git a/src/gsi/m_sstNode.F90 b/src/gsi/m_sstNode.F90 deleted file mode 100644 index 9afb24aaf4..0000000000 --- a/src/gsi/m_sstNode.F90 +++ /dev/null @@ -1,249 +0,0 @@ -module m_sstNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_sstNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type sstNode (sea surface temperature) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! -! 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:: sstNode - - type,extends(obsNode):: sstNode - !type(sst_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! sst residual - real(r_kind) :: err2 ! sst 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) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - real(r_kind) :: zob ! observation depth in meter - real(r_kind) :: tz_tr ! sensitivity of tob to tref : d(Tz)/d(Tr) - !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 - 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 sstNode - - public:: sstNode_typecast - public:: sstNode_nextcast - interface sstNode_typecast; module procedure typecast_ ; end interface - interface sstNode_nextcast; module procedure nextcast_ ; end interface - - public:: sstNode_appendto - interface sstNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_sstNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(sstNode) - use m_obsNode, only: obsNode - implicit none - type(sstNode ),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(sstNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(sstNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(sstNode ),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(sstNode),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="[sstNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(sstNode),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%zob , & - aNode%tz_tr , & - 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(sstNode),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%zob , & - aNode%tz_tr , & - 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(sstNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(sstNode),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(sstNode), 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_sstNode diff --git a/src/gsi/m_sstnode.F90 b/src/gsi/m_sstnode.F90 new file mode 100644 index 0000000000..3aaee33212 --- /dev/null +++ b/src/gsi/m_sstnode.F90 @@ -0,0 +1,249 @@ +module m_sstnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_sstnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type sstnode (sea surface temperature) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! 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:: sstnode + + type,extends(obsnode):: sstnode + !type(sst_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! sst residual + real(r_kind) :: err2 ! sst 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) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + real(r_kind) :: zob ! observation depth in meter + real(r_kind) :: tz_tr ! sensitivity of tob to tref : d(Tz)/d(Tr) + !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 + 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 sstnode + + public:: sstnode_typecast + public:: sstnode_nextcast + interface sstnode_typecast; module procedure typecast_ ; end interface + interface sstnode_nextcast; module procedure nextcast_ ; end interface + + public:: sstnode_appendto + interface sstnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_sstnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(sstnode) + use m_obsnode, only: obsnode + implicit none + type(sstnode ),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(sstnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(sstnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(sstnode ),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(sstnode),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="[sstnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(sstnode),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%zob , & + anode%tz_tr , & + 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(sstnode),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%zob , & + anode%tz_tr , & + 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(sstnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(sstnode),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(sstnode), 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_sstnode