module m_swcpNode !$$$ subprogram documentation block ! . . . . ! subprogram: module m_swcpNode ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2016-05-18 ! ! abstract: class-module of obs-type swcpNode (solid-water content path) ! ! 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:: swcpNode type,extends(obsNode):: swcpNode !type(swcp_ob_type),pointer :: llpoint => NULL() type(obs_diag), pointer :: diags => NULL() real(r_kind) :: res ! solid-water content path residual real(r_kind) :: err2 ! solid-water content path 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),dimension(:),pointer :: jac_t => NULL() ! t jacobian real(r_kind),dimension(:),pointer :: jac_p => NULL() ! p jacobian real(r_kind),dimension(:),pointer :: jac_q => NULL() ! q jacobian real(r_kind),dimension(:),pointer :: jac_qi => NULL() ! qi jacobian real(r_kind),dimension(:),pointer :: jac_qs => NULL() ! qs jacobian real(r_kind),dimension(:),pointer :: jac_qg => NULL() ! qg jacobian real(r_kind),dimension(:),pointer :: jac_qh => NULL() ! qh jacobian ! real(r_kind),dimension(:),pointer :: dp => NULL() ! ! delta pressure at mid layers at obs locations integer(i_kind),dimension(:,:),pointer :: ij => NULL() !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 swcpNode public:: swcpNode_typecast public:: swcpNode_nextcast interface swcpNode_typecast; module procedure typecast_ ; end interface interface swcpNode_nextcast; module procedure nextcast_ ; end interface public:: swcpNode_appendto interface swcpNode_appendto; module procedure appendto_ ; end interface character(len=*),parameter:: MYNAME="m_swcpNode" #include "myassert.H" #include "mytrace.H" contains function typecast_(aNode) result(ptr_) !-- cast a class(obsNode) to a type(swcpNode) use m_obsNode, only: obsNode implicit none type(swcpNode),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(swcpNode) ptr_ => aNode end select return end function typecast_ function nextcast_(aNode) result(ptr_) !-- cast an obsNode_next(obsNode) to a type(swcpNode) use m_obsNode, only: obsNode,obsNode_next implicit none type(swcpNode),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(swcpNode),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="[swcpNode]" end function mytype subroutine obsHeader_read_(iunit,mobs,jread,istat) use gridmod, only: nsig implicit none integer(i_kind),intent(in ):: iunit integer(i_kind),intent(out):: mobs integer(i_kind),intent(out):: jread integer(i_kind),intent(out):: istat character(len=*),parameter:: myname_=myname//".obsHeader_read_" integer(i_kind):: msig _ENTRY_(myname_) read(iunit,iostat=istat) mobs,jread, msig if(istat==0 .and. nsig/=msig) then call perr(myname_,'unexpected dimension information, nsig =',nsig) call perr(myname_,' but read msig =',msig) call die(myname_) endif _EXIT_(myname_) return end subroutine obsHeader_read_ subroutine obsHeader_write_(junit,mobs,jwrite,jstat) use gridmod, only: nsig implicit none integer(i_kind),intent(in ):: junit integer(i_kind),intent(in ):: mobs integer(i_kind),intent(in ):: jwrite integer(i_kind),intent(out):: jstat character(len=*),parameter:: myname_=myname//".obsHeader_write_" _ENTRY_(myname_) write(junit,iostat=jstat) mobs,jwrite, nsig _EXIT_(myname_) return end subroutine obsHeader_write_ subroutine obsNode_init_(aNode) use gridmod, only: nsig implicit none class(swcpNode),intent(out):: aNode character(len=*),parameter:: myname_=MYNAME//'.obsNode_init_' _ENTRY_(myname_) aNode%llpoint => null() aNode%luse = .false. aNode%elat = 0._r_kind aNode%elon = 0._r_kind aNode%time = 0._r_kind aNode%idv =-1 aNode%iob =-1 allocate(aNode%jac_t(nsig ), & aNode%jac_p(nsig+1), & aNode%jac_q(nsig ), & aNode%jac_qi(nsig ), & aNode%jac_qs(nsig ), & aNode%jac_qg(nsig ), & aNode%jac_qh(nsig ), & aNode%ij(4, nsig ) ) ! allocate(aNode%dp(nsig)) _EXIT_(myname_) return end subroutine obsNode_init_ subroutine obsNode_clean_(aNode) implicit none class(swcpNode),intent(inout):: aNode character(len=*),parameter:: myname_=MYNAME//'.obsNode_clean_' _ENTRY_(myname_) !_TRACEV_(myname_,'%mytype() =',aNode%mytype()) if(associated(aNode%jac_t )) deallocate(aNode%jac_t ) if(associated(aNode%jac_p )) deallocate(aNode%jac_p ) if(associated(aNode%jac_q )) deallocate(aNode%jac_q ) if(associated(aNode%jac_qi)) deallocate(aNode%jac_qi) if(associated(aNode%jac_qs)) deallocate(aNode%jac_qs) if(associated(aNode%jac_qg)) deallocate(aNode%jac_qg) if(associated(aNode%jac_qh)) deallocate(aNode%jac_qh) ! if(associated(aNode%dp )) deallocate(aNode%dp ) if(associated(aNode%ij )) deallocate(aNode%ij ) _EXIT_(myname_) return end subroutine obsNode_clean_ subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) use m_obsdiagNode, only: obsdiagLookup_locate implicit none class(swcpNode) , 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%wij , & !(4) aNode%jac_t , & !( nsig) aNode%jac_p , & !( nsig) aNode%jac_q , & !( nsig) aNode%jac_qi , & !( nsig) aNode%jac_qs , & !( nsig) aNode%jac_qg , & !( nsig) aNode%jac_qh , & !(4,nsig) aNode%ij ! aNode%dp 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(swcpNode),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%wij , & aNode%jac_t , & aNode%jac_p , & aNode%jac_q , & aNode%jac_qi , & aNode%jac_qs , & aNode%jac_qg , & aNode%jac_qh , & aNode%ij ! aNode%dp 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 use gridmod, only: nsig,latlon11 implicit none class(swcpNode),intent(inout):: aNode character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' integer(i_kind):: k _ENTRY_(myname_) ASSERT(size(aNode%ij,2)==nsig) ASSERT(nsig>0) call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij(:,1),aNode%wij) do k=2,nsig aNode%ij(:,k) = aNode%ij(:,1)+(k-1)*latlon11 enddo _EXIT_(myname_) return end subroutine obsNode_setHop_ function obsNode_isvalid_(aNode) result(isvalid_) implicit none logical:: isvalid_ class(swcpNode),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(swcpNode), 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_swcpNode