module m_obsdiagNode !$$$ subprogram documentation block ! . . . . ! subprogram: module m_obsdiagNode ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2016-05-18 ! ! abstract: module of node type obs_diag and linked-list type obs_diags. ! ! program history log: ! 2016-05-18 j guo - added this document block for the initial implementation. ! 2016-06-24 j.guo - Added support of using m_latlonRange to find a cluster ! latlonRange from (elat,elon) values of observations. ! . cleaned out some components from obsdiagNode, which ! were put in for debugging purposes. (%dlat,%dlon). ! . removed some earlier routines for debuggings and ! testings. e.g. lmock_() and obsnode_mock_(). ! . use a fixed miter size for both write_() and read_(), ! for a simpler control in the future. ! . renamed lsize_() to lcount_(). Then reimplemented a ! new lsize_() to separate different functionalities. ! ! 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 kinds , only: i_kind,r_kind use mpeu_util, only: assert_,tell,warn,perr,die implicit none private public:: obs_diag public:: obs_diags public:: fptr_obsdiagNode ! Primery behaviors: public:: obsdiagLList_reset ! destructor + initializer public:: obsdiagLList_appendNode public:: obsdiagLList_rewind ! rewind an obsdiagLList public:: obsdiagLList_nextNode public:: obsdiagLList_headNode public:: obsdiagLList_tailNode public:: obsdiagLList_read ! reader, for input public:: obsdiagLList_write ! writer, for otuput public:: obsdiagLList_lsize ! size inquiry public:: obsdiagLList_lcount ! size inquiry with recount public:: obsdiagLList_lsort ! sort nodes according to their keys public:: obsdiagLList_checksum! size consistency checking public:: obsdiagLList_summary ! status report interface obsdiagLList_reset ; module procedure lreset_; end interface interface obsdiagLList_rewind; module procedure lrewind_; end interface interface obsdiagLList_read ; module procedure lread_; end interface interface obsdiagLList_checksum; module procedure & lchecksum_ , & lchecksum1_ , & lchecksum2_ ; end interface interface obsdiagLList_lsize ; module procedure lsize_ ; end interface interface obsdiagLList_lcount ; module procedure lcount_ ; end interface interface obsdiagLList_lsort ; module procedure lsort_ ; end interface interface obsdiagLList_write ; module procedure lwrite_ ; end interface interface obsdiagLList_summary; module procedure lsummary_; end interface interface obsdiagLList_appendNode; module procedure obsNode_append_; end interface interface obsdiagLList_nextNode ; module procedure & obsNode_next_, & make_or_next_; end interface interface obsdiagLList_headNode ; module procedure lheadNode_ ; end interface interface obsdiagLList_tailNode ; module procedure ltailNode_ ; end interface ! Node lookup, secondary function with its searching component public:: obsdiagLookup_build ! setup, its searching component public:: obsdiagLookup_locate ! node lookup, with the searching component public:: obsdiagLookup_clean ! clean, its searching component interface obsdiagLookup_build ; module procedure lbuild_; end interface interface obsdiagLookup_locate; module procedure locate_; end interface interface obsdiagLookup_clean ; module procedure lclean_; end interface public:: obsdiagLList_dump interface obsdiagLList_dump; module procedure ldump_; end interface !public:: obsdiagNode_append ! interface obsdiagNode_append; module procedure obsNode_append_; end interface !public:: obsdiagNode_first ! interface obsdiagNode_first ; module procedure obsNode_first_; end interface !public:: obsdiagNode_next ! interface obsdiagNode_next ; module procedure obsNode_next_; end interface public:: obsdiagNode_init public:: obsdiagNode_assert public:: obsdiagNode_set public:: obsdiagNode_get interface obsdiagNode_init ; module procedure obsNode_init_; end interface interface obsdiagNode_assert; module procedure anode_assert_; end interface interface obsdiagNode_set ; module procedure obsNode_set_ ; end interface interface obsdiagNode_get ; module procedure obsNode_get_ ; end interface type obs_diag type(obs_diag), pointer :: next => NULL() real(r_kind), pointer :: nldepart(:) => null() ! (miter+1) real(r_kind), pointer :: tldepart(:) => null() ! (miter) real(r_kind), pointer :: obssen(:) => null() ! (miter) real(r_kind) :: wgtjo real(r_kind) :: elat, elon ! earth lat-lon for redistribution integer(i_kind) :: idv,iob,ich ! device, obs., and channel indices logical, pointer :: muse(:) => null() ! (miter+1), according the setup()s logical :: luse end type obs_diag type fptr_obsdiagNode ! Fortran array element of a type(obs_diag) pointer type(obs_diag),pointer:: ptr => null() end type fptr_obsdiagNode type:: obs_diags integer(i_kind):: n_alloc=0 type(obs_diag), pointer :: head => NULL() type(obs_diag), pointer :: tail => NULL() type(fptr_obsdiagNode), allocatable, dimension(:):: lookup end type obs_diags #include "myassert.H" #include "mytrace.H" character(len=*),parameter:: myname="m_obsdiagNode" #define _obsNode_ obs_diag #define _obsLList_ obs_diags contains subroutine lgotoNode_(headLL,thisNode) ! Move the tail pointer to thisNode. ! It is assumed that given thisNode is one of nodes in the list. Otherwise ! this function would break the list. implicit none type(_obsLList_),target,intent(inout):: headLL type(_obsNode_ ),target,intent(in ):: thisNode headLL%tail => thisNode end subroutine lgotoNode_ function lheadNode_(headLL) result(here_) ! Return the head node implicit none type(_obsNode_),pointer:: here_ type(_obsLList_),target,intent(in):: headLL here_ => headLL%head end function lheadNode_ function ltailNode_(headLL) result(here_) ! Return the current tail node implicit none type(_obsNode_ ),pointer:: here_ type(_obsLList_),target,intent(in):: headLL here_ => headLL%tail end function ltailNode_ subroutine lwrite_(diagLL,iunit,luseonly,jiter,miter,jj_type,ii_bin,luseRange) use m_latlonRange , only: latlonRange use m_latlonRange , only: latlonRange_enclose use mpeu_util, only: stdout use mpeu_util, only: stdout_lead implicit none type(_obsLList_) ,intent(inout):: diagLL ! the linked list of data integer(kind=i_kind),intent(in ):: iunit ! the output unit logical ,intent(in ):: luseonly ! write only if(luse) integer(kind=i_kind),intent(in ):: jiter ! diag width for the IO (or this iter) integer(kind=i_kind),intent(in ):: miter ! diag width of the memory integer(kind=i_kind),intent(in ):: jj_type, ii_bin type(latlonRange),optional,intent(inout):: luseRange character(len=*),parameter:: myname_=myname//"::lwrite_" integer(kind=i_kind):: iobs,kobs,lobs,mobs integer(kind=i_kind):: istat type(_obsNode_), pointer:: iNode logical:: isluse_ _ENTRY_(myname_) !_TIMER_ON_(myname_) lobs=obsdiagLList_lcount(diagLL,luseonly=luseonly) mobs=lobs if(.not.luseonly) mobs=obsdiagLList_lsize(diagLL) call obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) if(istat/=0) then call perr(myname_,'obsHeader_write_(), istat =',istat) call perr(myname_,' iunit =',iunit) call perr(myname_,' ii_bin =',ii_bin) call perr(myname_,' jtype =',jj_type) call perr(myname_,' jiter =',jiter) call perr(myname_,' miter =',miter) call perr(myname_,' total-luse-node, lobs =',lobs) call perr(myname_,' total-all-node, mobs =',mobs) call perr(myname_,' luseonly =',luseonly) call die(myname_) endif _TRACE_(myname_,'looping through obshead pointers') if(lobs<=0) then !_TIMER_OFF_(myname_) _EXIT_(myname_) return endif iobs=0 kobs=0 iNode => obsNode_first_(diagLL) do while(associated(iNode)) iobs=iobs+1 isluse_=obsNode_isluse_(iNode) if(isluse_ .or. .not.luseonly) then ! Update luseRange with a luse observation, for the lat-lon- ! range on the current PE. if(isluse_ .and. present(luseRange)) & call latlonRange_enclose(luseRange,iNode%elat,iNode%elon) ! Count it, then write the node out. Use of miter suggests a ! fixed output size. kobs=kobs+1 call obsNode_write_(iNode,iunit,miter,istat) if(istat/=0) then call perr(myname_,'obsNode_write_(), istat =',istat) call perr(myname_,' iunit =',iunit) call perr(myname_,' jiter =',jiter) call perr(myname_,' miter =',miter) call perr(myname_,' ii_bin =',ii_bin) call perr(myname_,' jtype =',jj_type) call perr(myname_,'current-luse-node, kobs =',kobs) call perr(myname_,' current-all-node, iobs =',iobs) call perr(myname_,' total-luse-node, lobs =',lobs) call perr(myname_,' total-all-node, mobs =',mobs) call perr(myname_,' luseonly =',luseonly) call die(myname_) endif endif iNode => obsNode_next_(diagLL) enddo ASSERT(kobs==lobs) ASSERT(iobs==mobs) !_TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine lwrite_ subroutine ldump_(diagLL,jiter) use mpeu_util, only: stdout implicit none type(_obsLList_), intent(inout):: diagLL ! the list to dump integer(i_kind ),optional,intent(in ):: jiter ! jiter of diagLL character(len=*),parameter:: myname_=myname//"::ldump_" integer(kind=i_kind):: iobs,lobs,mobs integer(kind=i_kind):: jiter_ type(_obsNode_), pointer:: iNode logical:: isluse_,ismuse_ _ENTRY_(myname_) !_TIMER_ON_(myname_) jiter_=0 if(present(jiter)) jiter_=jiter call lbuild_(diagLL) ! create a pointer array %lookup, sorted by (idv,iob,ich) lobs=0 mobs=0 do iobs=1,size(diagLL%lookup(:)) iNode => diagLL%lookup(iobs)%ptr isluse_=obsNode_isluse_(iNode) if(isluse_) lobs=lobs+1 ismuse_=jiter_>=1.and.jiter_<=size(iNode%muse) if(ismuse_) ismuse_=iNode%muse(jiter_) if(ismuse_) mobs=mobs+1 write(stdout,'(2x,2l1,3i8,2x,2f12.4)') isluse_,ismuse_, & iNode%idv,iNode%iob,iNode%ich, iNode%elat,iNode%elon enddo write(stdout,'(2x,a,4i8)') '***',jiter_,size(diagLL%lookup(:)),lobs,mobs call lclean_(diagLL) ! destroy the pointer array %lookup. !_TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine ldump_ subroutine lread_(diagLL,iunit,redistr,jiter,miter,jj_type,ii_bin,jread,leadNode,jiter_expected) !_TIMER_USE_ implicit none type(_obsLList_),intent(inout):: diagLL integer(kind=i_kind),intent(in ):: iunit logical ,intent(in ):: redistr integer(kind=i_kind),intent(in ):: jiter integer(kind=i_kind),intent(in ):: miter integer(kind=i_kind),intent(in ):: jj_type, ii_bin integer(kind=i_kind),intent( out):: jread type(_obsNode_), pointer, intent(out):: leadNode integer(kind=i_kind),intent(in),optional:: jiter_expected character(len=*),parameter:: myname_=myname//"::lread_" integer(kind=i_kind):: ki,kj,kobs integer(kind=i_kind):: kiter,miter_read ! jiter : current iter count ! miter : maximum iter size ! kiter(read): current iter count as it was written ! miter_read : maximum iter size as it was written integer(kind=i_kind):: kk,istat type(_obsNode_), pointer:: aNode _ENTRY_(myname_) !_TIMER_ON_(myname_) !call timer_ini(myname_) call obsHeader_read_(iunit,ki,kj,kobs,kiter,miter_read,istat) if(istat/=0) then call perr(myname_,'obsHeader_read_(), istat =',istat) call perr(myname_,' iunit =',iunit) call die(myname_) endif if(ki/=ii_bin .or. kj/=jj_type .or. miter/=miter_read) then call perr(myname_,'obsHeader_read_(), unexpected header values (ii,jj,miter)') call perr(myname_,' expecting miter =',miter) call perr(myname_,' actual miter =',miter_read) call perr(myname_,' expecting ii =',ii_bin) call perr(myname_,' actual ii =',ki) call perr(myname_,' expecting jj =',jj_type) call perr(myname_,' actual jj =',kj) call die(myname_) endif if(present(jiter_expected)) then if(jiter_expected>=0) then if(kiter/=jiter_expected) then call perr(myname_,'obsHeader_read_(), unexpected input jiter =',kiter) call perr(myname_,' with input miter =',miter_read) call perr(myname_,' expecting input jiter =',jiter_expected) call perr(myname_,' miter =',miter) call perr(myname_,' jiter =',jiter) call die(myname_) endif endif endif jread=kiter !-- construct an an_obsNode leadNode => null() aNode => obsNode_alloc_(miter) do kk=1,kobs !-- initialize an_obsNode from a file (iunit). Use of miter suggests a !-- fixed input size. call obsNode_read_(aNode,iunit,miter,istat,redistr=redistr) if(istat<0) then call perr(myname_,'obsNode_read_(), istat =',istat) call perr(myname_,' redistr =',redistr) call die(myname_) endif ! istat <0: a failed read(aNode) ! ==0: passed, thus an incomplete aNode ! >0: a good aNode to keep if(istat==0) cycle if(redistr) call obsNode_setluse_(aNode) ! keep this obsNode in its linked-list, diagLL := obsdiags(jj,ii) call obsNode_append_(diagLL,aNode) !-- mark the beginning of this linked-list segment if(.not.associated(leadNode)) leadNode => aNode !-- drop this aNode, to construct a new. This _alloc_ ! ensures an aNode is not in anyway referencible to ! the one that has been appended to the linked-list. ! Then, a deep-deallocation of aNode is alwasy safe. aNode => obsNode_alloc_(miter) enddo ! < kobs > call obsNode_dealloc_(aNode,deep=.true.) ! Clean up the malloc of aNode ! ---------------------------------------------------------- !call timer_fnl(myname_) !_TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine lread_ subroutine lreset_(diagLL) implicit none type(_obsLList_), intent(inout):: diagLL character(len=*),parameter:: myname_=myname//"::lreset_" type(_obsNode_),pointer:: l_obsNode type(_obsNode_),pointer:: n_obsNode integer(kind=i_kind):: ip _ENTRY_(myname_) l_obsNode => obsNode_first_(diagLL) ip=0 do while(associated(l_obsNode)) ip=ip+1 !_TRACEV_(myname_,'deallocating at ip =',ip) !call obsNode_check_(myname_,l_obsNode) ! Steps of forward resetting, ! (1) hold the %next node, ! (2) clean (leaving the %next node untouched, ! (3) deallocate the current node, ! (4) point the starting point to the %next node. n_obsNode => obsNode_next_(diagLL) call obsNode_dealloc_(l_obsNode,deep=.true.) l_obsNode => n_obsNode enddo !n_obsNode => null() !l_obsNode => null() diagLL%n_alloc = 0 diagLL%head => null() diagLL%tail => null() if(allocated(diagLL%lookup)) deallocate(diagLL%lookup) _EXIT_(myname_) return end subroutine lreset_ subroutine lrewind_(diagLL) implicit none type(_obsLList_),target,intent(inout):: diagLL diagLL%tail => null() return end subroutine lrewind_ subroutine lchecksum_(diagLL,leadNode,itype,ibin,sorted) !$$$ subprogram documentation block ! . . . . ! subprogram: lchecksum_ ! prgmmr: J. Guo ! ! abstract: check the size values against a known counts. ! ! program history log: ! 2015-06-26 guo - ! ! input argument list: (see Fortran declarations below) ! ! output argument list: (see Fortran declarations below) ! ! attributes: ! language: f90/f95/f2003/f2008 ! machine: ! !$$$ end documentation block use mpeu_util, only: stdout use mpeu_util, only: stdout_lead implicit none type(_obsLList_), intent(in):: diagLL type(_obsNode_ ), pointer, optional, intent(in):: leadNode integer(kind=i_kind),optional,intent(in ):: itype integer(kind=i_kind),optional,intent(in ):: ibin logical ,optional,intent(out):: sorted character(len=*),parameter:: myname_=MYNAME//"::lchecksum_" integer(kind=i_kind):: jtype,jbin integer(kind=i_kind):: mcount integer(kind=i_kind):: nuse,nooo,ndup integer(kind=i_kind),dimension(3):: ksum !jtest ! logical:: lasso,lhead _ENTRY_(myname_) !jtest ! ASSERT(present(leadNode)) ! lasso=associated(leadNode) ! lhead=associated(diagLL%head,leadNode) mcount=lcount_(diagLL,recount=.true.,nuse=nuse,nooo=nooo,ndup=ndup,ksum=ksum,leadNode=leadNode) if(present(sorted)) sorted = nooo==0.and.ndup==0 !jtest ! if(mcount/=diagLL%n_alloc) then ! call perr(myname_,'checksum failed, mcount =',mcount) ! call perr(myname_,' diagLList%n_alloc =',diagLL%n_alloc) ! if(present(itype)) & ! call perr(myname_,' itype =',itype) ! if(present(ibin)) & ! call perr(myname_,' ibin =',ibin) ! call die(myname_) ! endif if(present(itype)) jtype=itype if(present(ibin)) jbin =ibin _EXIT_(myname_) return end subroutine lchecksum_ subroutine lchecksum1_(diagLL,leadNode,itype) !$$$ subprogram documentation block ! . . . . ! subprogram: lchecksum_ ! prgmmr: J. Guo ! ! abstract: check the size values against a known counts. ! ! program history log: ! 2015-06-26 guo - ! ! input argument list: (see Fortran declarations below) ! ! output argument list: (see Fortran declarations below) ! ! attributes: ! language: f90/f95/f2003/f2008 ! machine: ! !$$$ end documentation block implicit none type(_obsLList_), dimension(:),intent(in):: diagLL integer(kind=i_kind),optional,intent(in):: itype type(fptr_obsdiagNode),optional,dimension(:),intent(in):: leadNode character(len=*),parameter:: myname_=MYNAME//"::lchecksum1_" integer(kind=i_kind):: i _ENTRY_(myname_) if(present(leadNode)) then ASSERT(size(diagLL)==size(leadNode)) do i=1,size(diagLL) call lchecksum_(diagLL(i),itype=itype,ibin=i,leadNode=leadNode(i)%ptr) enddo else do i=1,size(diagLL) call lchecksum_(diagLL(i),itype=itype,ibin=i) enddo endif _EXIT_(myname_) return end subroutine lchecksum1_ subroutine lchecksum2_(diagLL) !$$$ subprogram documentation block ! . . . . ! subprogram: lchecksum_ ! prgmmr: J. Guo ! ! abstract: check the size values against a known counts. ! ! program history log: ! 2015-06-26 guo - ! ! input argument list: (see Fortran declarations below) ! ! output argument list: (see Fortran declarations below) ! ! attributes: ! language: f90/f95/f2003/f2008 ! machine: ! !$$$ end documentation block implicit none type(_obsLList_), dimension(:,:),intent(in):: diagLL character(len=*),parameter:: myname_=MYNAME//"::lchecksum2_" integer(kind=i_kind):: it,ib _ENTRY_(myname_) do it=1,size(diagLL,1) do ib=1,size(diagLL,2) call lchecksum_(diagLL(it,ib),itype=it,ibin=ib) enddo enddo _EXIT_(myname_) return end subroutine lchecksum2_ subroutine lsummary_(diagLL,verbose) implicit none type(_obsLList_), intent(in):: diagLL logical,optional, intent(in):: verbose character(len=*),parameter:: myname_=MYNAME//"::lsummary_" type(_obsNode_ ), pointer:: iNode type(_obsLList_), target :: tempLL integer(kind=i_kind):: iobs_ logical:: verbose_ verbose_=.false. if(present(verbose)) verbose_=verbose _ENTRY_(myname_) if(verbose_) then tempLL = diagLL iobs_ = 0 iNode => obsNode_first_(tempLL) do while(associated(iNode)) iobs_=iobs_+1 call obsNode_show_(iNode,iobs_) iNode => obsNode_next_(tempLL) enddo endif _EXIT_(myname_) return end subroutine lsummary_ function lsize_(diagLL) result(lobs_) implicit none integer(kind=i_kind):: lobs_ type(_obsLList_), target, intent(in):: diagLL lobs_=diagLL%n_alloc end function lsize_ function lcount_(diagLL,luseonly,recount,nuse,nooo,ndup,ksum,leadNode) result(lobs_) use mpeu_util, only: assert_ implicit none integer(kind=i_kind):: lobs_ type(_obsLList_), target, intent(in):: diagLL logical , optional, intent(in):: luseonly logical , optional, intent(in):: recount integer(kind=i_kind),optional,intent(out):: nuse ! no. of luse integer(kind=i_kind),optional,intent(out):: nooo ! no. out-of-orders integer(kind=i_kind),optional,intent(out):: ndup ! no. duplicates integer(kind=i_kind),optional,dimension(:),intent(out):: ksum ! key value sum type(_obsNode_ ), pointer, optional, intent(in):: leadNode character(len=*),parameter:: myname_=myname//"::lcount_" type(_obsNode_ ), pointer:: iNode type(_obsLList_), target :: tempLL integer(kind=i_kind):: nuse_ integer(kind=i_kind):: k integer(kind=i_kind),dimension(3) :: kprev logical:: luseonly_,recount_,checksum_ _ENTRY_(myname_) luseonly_=.false. if(present(luseonly)) luseonly_=luseonly recount_ =.false. if(present(recount )) recount_ =recount if(present(leadNode)) recount_ =.true. checksum_= present(nuse).or.present(nooo).or.present(ndup).or.present(ksum) recount_ = recount_ .or. checksum_ !if(.not.recount_) recount_ = checksum_ if(present(ksum)) then ALWAYS_ASSERT( size(ksum)==size(kprev) ) endif if(.not.(luseonly_.or.recount_)) then lobs_=diagLL%n_alloc else ! recount through the list tempLL = diagLL ! A copy of diagLL, such that diagLL can remain intent(in) lobs_ = 0 nuse_ = 0 if(checksum_) call checksum_init_(kprev,nooo=nooo,ndup=ndup,ksum=ksum) iNode => obsNode_first_(tempLL,atNode=leadNode) do while(associated(iNode)) if(obsNode_isluse_(iNode)) nuse_=nuse_+1 if(.not.luseonly_ .or. obsNode_isluse_(iNode)) lobs_=lobs_+1 if(checksum_) call checksum_add_(kprev, & (/iNode%idv,iNode%iob,iNode%ich/),nooo=nooo,ndup=ndup,ksum=ksum) iNode => obsNode_next_(tempLL) enddo if(present(nuse)) nuse=nuse_ endif _EXIT_(myname_) return contains subroutine checksum_init_(kprev,nooo,ndup,ksum) implicit none integer(kind=i_kind),dimension(:),intent(out):: kprev integer(kind=i_kind),optional,intent(out):: nooo integer(kind=i_kind),optional,intent(out):: ndup integer(kind=i_kind),optional,dimension(:),intent(out):: ksum kprev(:)= 0 if(present(nooo)) nooo=0 if(present(ndup)) ndup=0 if(present(ksum)) ksum(:)=0 end subroutine checksum_init_ subroutine checksum_add_(kprev,knext,nooo,ndup,ksum) implicit none integer(kind=i_kind),dimension(:),intent(inout):: kprev integer(kind=i_kind),dimension(:),intent(in ):: knext integer(kind=i_kind),optional,intent(inout):: nooo integer(kind=i_kind),optional,intent(inout):: ndup integer(kind=i_kind),optional,dimension(:),intent(inout):: ksum k=compare_(kprev,knext) if(present(nooo).and.k> 0) nooo=nooo+1 if(present(ndup).and.k==0) ndup=ndup+1 if(present(ksum)) ksum(:)=ksum(:)+knext(:) kprev(:)=knext(:) end subroutine checksum_add_ end function lcount_ function obsNode_first_(diagLL,atNode) result(here_) implicit none type(_obsNode_ ), pointer :: here_ type(_obsLList_), target, intent(inout):: diagLL type(_obsNode_ ), optional, pointer,intent(in):: atNode character(len=*),parameter:: myname_=myname//"::obsNode_first_" _ENTRY_(myname_) !_TRACEV_(myname_,'%n_alloc =',diagLL%n_alloc) !_TRACEV_(myname_,'associated(%head) =',associated(diagLL%head)) here_ => diagLL%head if(present(atNode)) here_=>atNode diagLL%tail => here_ ! update the tail-node if(associated(here_)) call obsNode_check_(myname_,here_) _EXIT_(myname_) return end function obsNode_first_ function obsNode_next_(diagLL) result(next_) implicit none type(_obsNode_ ), pointer :: next_ type(_obsLList_), target, intent(inout):: diagLL character(len=*),parameter:: myname_=myname//"::obsNode_next_" _ENTRY_(myname_) next_ => diagLL%head if(associated(diagLL%tail)) next_ => diagLL%tail%next diagLL%tail => next_ ! update the tail-node _EXIT_(myname_) return end function obsNode_next_ function make_or_next_(diagLL,create,idv,iob,ich,elat,elon,luse,miter) result(next_) implicit none type(_obsNode_ ), pointer :: next_ type(_obsLList_), target, intent(inout):: diagLL logical , intent(in):: create ! make or next integer(kind=i_kind), intent(in):: idv,iob,ich real (kind=r_kind), intent(in):: elat,elon logical , intent(in):: luse integer(kind=i_kind), intent(in):: miter character(len=*),parameter:: myname_=myname//"::make_or_next_" logical:: matched _ENTRY_(myname_) if(create) then allocate(next_) call obsNode_append_(diagLL,next_) call obsNode_init_(next_,idv,iob,ich,elat,elon,luse,miter) else next_ => diagLL%head if(associated(diagLL%tail)) next_ => diagLL%tail%next diagLL%tail => next_ ! update the tail-node ! Check the next node against (idv,iob,ich) matched = associated(next_) if(matched) matched = next_%idv==idv .and. & next_%iob==iob .and. & next_%ich==ich if(.not.matched) then call perr(myname_,"unexpected node, associated(next) =", associated(next_)) call perr(myname_," expecting (idv,iob,ich) =", (/idv,iob,ich/)) call perr(myname_," elat =", elat) call perr(myname_," elon =", elon) if(associated(next_)) then call perr(myname_," next%(idv,iob,ich) =", (/next_%idv,next_%iob,next_%ich/)) call perr(myname_," next%elat =", next_%elat) call perr(myname_," next%elon =", next_%elon) call perr(myname_," next%luse =", next_%luse) call perr(myname_," size(next%muse) =", size(next_%muse)) endif call die(myname_) endif endif ! (create) _EXIT_(myname_) return end function make_or_next_ subroutine obsNode_append_(diagLL,targetNode) ! Link the next node of the list to the given targetNode. The return ! result is a pointer associated to the same targetNode. !-- use jfunc, only: miter implicit none type(_obsLList_), intent(inout):: diagLL type(_obsNode_ ), pointer, intent(in):: targetNode character(len=*),parameter:: myname_=myname//"::obsNode_append_" !-- type(_obsNode_ ),pointer:: aNode _ENTRY_(myname_) if(.not.associated(diagLL%head)) then ! this is a fresh starting -node- for this linked-list ... diagLL%n_alloc = 1 diagLL%head => targetNode diagLL%tail => diagLL%head else ! this is for a new next -node- from here ... diagLL%n_alloc = diagLL%n_alloc +1 diagLL%tail%next => targetNode diagLL%tail => diagLL%tail%next !diagLL%tail%append(next_) ! append(t,next_) ! t%next => next_ ! t => t%next endif if(associated(diagLL%tail)) diagLL%tail%next => null() !-- aNode => diagLL%tail !-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) !-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) !-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) !-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) !-- aNode => null() _EXIT_(myname_) return end subroutine obsNode_append_ subroutine obsNode_insert_(diagLL,targetNode) ! Insert targetNode to diagLL's current location, mostly %tail. At the ! return, diagLL%tail is associated to targetNode. !-- use jfunc, only: miter implicit none type(_obsLList_), intent(inout):: diagLL type(_obsNode_ ), pointer, intent(in):: targetNode character(len=*),parameter:: myname_=myname//"::obsNode_insert_" type(_obsNode_),pointer:: next_ _ENTRY_(myname_) if(.not.associated(diagLL%head)) then ! This is a fresh start case: insert a node as append diagLL%n_alloc = 1 diagLL%head => targetNode diagLL%tail => diagLL%head ! now the current node diagLL%tail%next => null() ! set %next to nothing there before elseif(.not.associated(diagLL%tail)) then ! This is a rewound case: insert a node as the new %head next_ => diagLL%head diagLL%n_alloc = diagLL%n_alloc +1 diagLL%head => targetNode diagLL%tail => diagLL%head ! now the current node diagLL%tail%next => next_ ! set %next to the original %head else ! This is a normal case: insert a node in between %tail and ! %tail%next. next_ => diagLL%tail%next diagLL%n_alloc = diagLL%n_alloc +1 diagLL%tail%next => targetNode diagLL%tail => diagLL%tail%next ! now the current node. diagLL%tail%next => next_ ! set %next to the original %tail%next ! Note in the last stateument, targetNode%next has been implicitly modifed. endif !-- associate(aNode => diagLL%tail) !-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) !-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) !-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) !-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) !-- end associate ! (aNode => diagLL%tail) _EXIT_(myname_) return end subroutine obsNode_insert_ subroutine lsort_(diagLL,itype,ibin) ! lsort_: node-sort diagLL, to line-up nodes according to their keys !_TIMER_USE_ ! use timermod , only: timer_ini,timer_fnl !use mpeu_util, only: IndexSet !use mpeu_util, only: IndexSort !use mpeu_util, only: die implicit none type(_obsLList_) , intent(inout):: diagLL integer(kind=i_kind),optional,intent(in):: itype,ibin character(len=*),parameter:: myname_=myname//'::lsort_' integer(kind=i_kind):: i,nobs,mobs logical:: sorted _ENTRY_(myname_) !_TIMER_ON_(myname_) ! call timer_ini(myname_) call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) if(sorted) then _EXIT_(myname_) return endif ! created a sorted table call lbuild_(diagLL) nobs = diagLL%n_alloc mobs = size(diagLL%lookup(:)) ASSERT(nobs==mobs) ! rebuild the linked-list diagLL%n_alloc=0 diagLL%head => null() diagLL%tail => null() ! rebuild the list according to the sorted table do i=1,mobs call obsNode_append_(diagLL,diagLL%lookup(i)%ptr) enddo ASSERT(nobs==diagLL%n_alloc) if(associated(diagLL%tail)) then ASSERT(.not.associated(diagLL%tail%next)) endif ! discard the sorted table call lclean_(diagLL) call lchecksum_(diagLL,itype=itype,ibin=ibin,sorted=sorted) if(.not.sorted) then call perr(myname_,'failed post-sorting lchecksum_(diagLL), sorted =',sorted) if(present(itype)) & call perr(myname_,' itype =',itype) if(present(ibin )) & call perr(myname_,' ibin =',ibin ) call die(myname_) endif ! call timer_fnl(myname_) !_TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine lsort_ subroutine lbuild_(diagLL,leadNode,jiter) !_TIMER_USE_ ! use timermod , only: timer_ini,timer_fnl use mpeu_util, only: IndexSet use mpeu_util, only: IndexSort !use mpeu_util, only: die implicit none type(_obsLList_), intent(inout):: diagLL type(_obsNode_ ), pointer, optional, intent(in):: leadNode integer(i_kind) , optional, intent(in):: jiter character(len=*),parameter:: myname_=myname//'::lbuild_' type(_obsNode_),pointer:: iNode,pNode integer(kind=i_kind),allocatable,dimension(:):: indx,idv_,iob_,ich_ integer(kind=i_kind):: i,m,n integer(kind=i_kind):: idum logical:: good _ENTRY_(myname_) !_TIMER_ON_(myname_) ! call timer_ini(myname_) if(present(jiter)) idum=jiter ! Mark the leading node iNode => null() if(present(leadNode)) iNode => leadNode if(.not.associated(iNode)) iNode => diagLL%head m=diagLL%n_alloc if(m<0) call die(myname_,'unexpected diagLL, %n_alloc =',m) ! Count, starting from the leading node n=0 pNode => iNode do while(associated(pNode)) n=n+1 pNode => pNode%next enddo if(n>diagLL%n_alloc) then call perr(myname_,'unexpected diagLL, %n_alloc =',m) call die(myname_,' actual count =',n) endif allocate(diagLL%lookup(n)) allocate(indx(n),idv_(n),iob_(n),ich_(n)) associate(lookup => diagLL%lookup(:)) ! Loop over the linked-list, to get keys. i=0 pNode => iNode do while(associated(pNode)) i=i+1 if(i<=n) then lookup(i)%ptr => pNode idv_(i) = pNode%idv iob_(i) = pNode%iob ich_(i) = pNode%ich !call obsNode_get(idv=idv_(i),iob=iob_(i),ich=ich_(i)) endif pNode => pNode%next enddo end associate ! sort %lookup(1:n), by its (idv,iob,ich) values call IndexSet (indx) call IndexSort(indx,ich_) call IndexSort(indx,iob_) call IndexSort(indx,idv_) associate(lookup => diagLL%lookup(:)) lookup(1:n) = lookup(indx(1:n)) end associate idv_(1:n) = idv_(indx(1:n)) iob_(1:n) = iob_(indx(1:n)) ich_(1:n) = ich_(indx(1:n)) associate(lookup => diagLL%lookup(:)) good = .true. do i=1,n good = lookup(i)%ptr%idv==idv_(i) .and. & lookup(i)%ptr%iob==iob_(i) .and. & lookup(i)%ptr%ich==ich_(i) if(.not.good) exit enddo if(.not.good) then call perr(myname_,'verification failed at %lookup(i)%ptr, i =',i) call perr(myname_,' %ptr%idv =',lookup(i)%ptr%idv) call perr(myname_,' idv_=',idv_(i)) call perr(myname_,' %ptr%iob =',lookup(i)%ptr%iob) call perr(myname_,' iob_=',iob_(i)) call perr(myname_,' %ptr%ich =',lookup(i)%ptr%ich) call perr(myname_,' ich_=',ich_(i)) call die(myname_) endif end associate deallocate(indx,idv_,iob_,ich_) ! call timer_fnl(myname_) !_TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine lbuild_ subroutine lclean_(diagLL) implicit none type(_obsLList_), intent(inout):: diagLL character(len=*),parameter:: myname_=myname//'::lclean_' integer(kind=i_kind):: ier,i _ENTRY_(myname_) associate(lookup => diagLL%lookup(:)) do i=1,size(lookup) lookup(i)%ptr => null() end do end associate deallocate(diagLL%lookup,stat=ier) if(ier/=0) call die(myname_,'deallocate(diagLL%lookup), stat =',ier) _EXIT_(myname_) return end subroutine lclean_ function locate_(diagLL,idv,iob,ich) result(here_) use timermod , only: timer_ini,timer_fnl implicit none type(_obsNode_ ), pointer:: here_ type(_obsLList_), intent(in):: diagLL integer(kind=i_kind), intent(in):: idv,iob,ich character(len=*),parameter:: myname_=myname//"::locate_" type(_obsNode_ ),pointer:: idiag integer(kind=i_kind):: m,i,lb,ub logical:: done _ENTRY_(myname_) call timer_ini(myname_) here_ => null() ! return null() if the key is not located. associate(lookup => diagLL%lookup(:)) lb=lbound(lookup,1) ub=ubound(lookup,1) done=.false. do while(.not.done) i=(lb+ub)/2 idiag => lookup(i)%ptr m=compare_((/idiag%idv,idiag%iob,idiag%ich/),(/idv,iob,ich/)) done = m==0 if(done) exit ! We are searching for EQUAL, so skip the i-th point if not equal. if(m<0) then ! if idiag%(idv,iob,ich) < (/idv,iob,ich/), move the lower range (lb) up ! to continue the search above i lb=i+1 else ! if idiag%(idv,iob,ich) > (/idv,iob,ich/), move the upper range (ub) down ! to continue the search below i. ub=i-1 endif if(ub idiag endif call timer_fnl(myname_) _EXIT_(myname_) return end function locate_ function compare_(key1,key2) result (m) implicit none integer(kind=i_kind):: m integer(kind=i_kind),dimension(:),intent(in):: key1,key2 integer(kind=i_kind):: n,i m=0 n=min(size(key1),size(key2)) do i=1,n if (key1(i)key2(i)) then m=+1; exit endif enddo end function compare_ !------------------- function obsNode_islocal_(aNode) result(islocal_) use mpimod, only: myPE use m_cvgridLookup, only: cvgridLookup_islocal implicit none logical:: islocal_ type(_obsNode_),intent(in):: aNode character(len=*),parameter:: myname_=myname//"::obsNode_islocal_" _ENTRY_(myname_) islocal_=cvgridLookup_islocal(aNode%elat,aNode%elon,myPE) _EXIT_(myname_) return end function obsNode_islocal_ function obsNode_isluse_(aNode) result(isluse_) implicit none logical:: isluse_ type(_obsNode_),intent(in):: aNode character(len=*),parameter:: myname_=myname//"::obsNode_isluse_" _ENTRY_(myname_) isluse_=aNode%luse _EXIT_(myname_) return end function obsNode_isluse_ subroutine obsNode_setluse_(aNode) use mpimod, only: myPE use m_cvgridLookup, only: cvgridLookup_isluse implicit none type(_obsNode_),intent(inout):: aNode character(len=*),parameter:: myname_=myname//"::obsNode_setluse_" _ENTRY_(myname_) aNode%luse=cvgridLookup_isluse(aNode%elat, aNode%elon, myPE) ! call obstype_setluse(aNode%luse, aNode%elat, aNode%elon, myPE) _EXIT_(myname_) return end subroutine obsNode_setluse_ subroutine obsHeader_read_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) implicit none integer(kind=i_kind),intent(in ):: iunit integer(kind=i_kind),intent(out):: ii_bin,jj_type,lobs,jiter,miter integer(kind=i_kind),intent(out):: istat character(len=*),parameter:: myname_=myname//"::obsHeader_read_" _ENTRY_(myname_) read(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter _EXIT_(myname_) return end subroutine obsHeader_read_ subroutine obsHeader_write_(iunit,ii_bin,jj_type,lobs,jiter,miter,istat) implicit none integer(kind=i_kind),intent(in ):: iunit integer(kind=i_kind),intent(in ):: ii_bin,jj_type,lobs,jiter,miter integer(kind=i_kind),intent(out):: istat character(len=*),parameter:: myname_=myname//"::obsHeader_write_" _ENTRY_(myname_) write(iunit,iostat=istat) ii_bin,jj_type,lobs,jiter,miter _EXIT_(myname_) return end subroutine obsHeader_write_ subroutine obsNode_check_(who,aNode) !-- use jfunc, only: miter ! for debugging implicit none character(len=*),intent(in):: who type(_obsNode_),intent(in):: aNode logical:: equival character(len=256)::mywho mywho=who !_TRACEV_(who,'associated(aNode%muse ) =',associated(aNode%muse )) !_TRACEV_(who,'associated(aNode%nldepart) =',associated(aNode%nldepart)) !_TRACEV_(who,'associated(aNode%tldepart) =',associated(aNode%tldepart)) !_TRACEV_(who,'associated(aNode%obssen ) =',associated(aNode%obssen )) equival = associated(aNode%nldepart) .eqv. associated(aNode%muse ) if(equival) equival = associated(aNode%tldepart) .eqv. associated(aNode%nldepart) if(equival) equival = associated(aNode%obssen ) .eqv. associated(aNode%tldepart) if(equival) equival = associated(aNode%muse) ASSERT(equival) !-- ASSERT(lbound(aNode%muse ,1)==1.and.ubound(aNode%muse ,1)==miter+1) !-- ASSERT(lbound(aNode%nldepart,1)==1.and.ubound(aNode%nldepart,1)==miter+1) !-- ASSERT(lbound(aNode%tldepart,1)==1.and.ubound(aNode%tldepart,1)==miter ) !-- ASSERT(lbound(aNode%obssen ,1)==1.and.ubound(aNode%obssen ,1)==miter ) return end subroutine obsNode_check_ function obsNode_alloc_(miter) result(aNode_) implicit none type(_obsNode_), pointer :: aNode_ integer(kind=i_kind), intent(in):: miter character(len=*),parameter:: myname_=myname//"::obsNode_alloc_" _ENTRY_(myname_) allocate(aNode_) aNode_%next => null() allocate(aNode_%muse (miter+1), & aNode_%nldepart(miter+1), & aNode_%tldepart(miter ), & aNode_%obssen (miter ) ) aNode_%luse = .false. aNode_%elat = 0._r_kind aNode_%elon = 0._r_kind aNode_%idv =-1 aNode_%iob =-1 aNode_%ich =-1 aNode_%muse (:)= .false. aNode_%nldepart(:)=-huge(0._r_kind) aNode_%tldepart(:)= 0._r_kind aNode_%wgtjo =-huge(0._r_kind) aNode_%obssen (:)= 0._r_kind call obsNode_check_(myname_,aNode_) _EXIT_(myname_) return end function obsNode_alloc_ subroutine obsNode_init_(anode,idv,iob,ich,elat,elon,luse,miter) implicit none type(_obsNode_),intent(inout):: anode integer(kind=i_kind), intent(in):: idv,iob,ich real (kind=r_kind), intent(in):: elat,elon logical, intent(in):: luse integer(kind=i_kind), intent(in):: miter character(len=*),parameter:: myname_=myname//"::obsNode_init_" _ENTRY_(myname_) aNode%next => null() anode%idv = idv anode%iob = iob anode%ich = ich aNode%elat = elat aNode%elon = elon anode%luse = luse aNode%wgtjo =-huge(0._r_kind) allocate(aNode%muse (miter+1), & aNode%nldepart(miter+1), & aNode%tldepart(miter ), & aNode%obssen (miter ) ) aNode%muse (:)= .false. aNode%nldepart(:)=-huge(0._r_kind) aNode%tldepart(:)= 0._r_kind aNode%obssen (:)= 0._r_kind call obsNode_check_(myname_,aNode) _EXIT_(myname_) return end subroutine obsNode_init_ subroutine anode_assert_(anode,idv,iob,ich,who,what) implicit none type(_obsNode_),intent(in):: anode integer(kind=i_kind), intent(in):: idv,iob,ich character(len=*),intent(in):: who character(len=*),intent(in):: what character(len=*),parameter:: myname_=myname//"::anode_assert_" logical:: valid character(len=:),allocatable:: what_ _ENTRY_(myname_) valid = & anode%idv == idv .and. & anode%iob == iob .and. & anode%ich == ich if(.not.valid) then what_=repeat(" ",len(trim(what))) call perr(who,trim(what)//", %(idv,iob,ich) =",(/anode%idv,anode%iob,anode%ich/)) call perr(who, what_//" (idv,iob,ich) =",(/ idv, iob, ich/)) call die(who) endif _EXIT_(myname_) return end subroutine anode_assert_ subroutine obsNode_set_(anode, & idv,iob,ich,elat,elon,luse,wgtjo, & jiter,muse,nldepart,tldepart,obssen) implicit none type(_obsNode_),intent(inout):: anode integer(kind=i_kind),optional,intent(in):: idv,iob,ich real (kind=r_kind),optional,intent(in):: elat,elon logical ,optional,intent(in):: luse real (kind=r_kind),optional,intent(in):: wgtjo integer(kind=i_kind),optional,intent(in):: jiter logical ,optional,intent(in):: muse real (kind=r_kind),optional,intent(in):: nldepart real (kind=r_kind),optional,intent(in):: tldepart real (kind=r_kind),optional,intent(in):: obssen character(len=*),parameter:: myname_=myname//"::obsNode_set_" _ENTRY_(myname_) if(present(idv )) aNode%idv =idv if(present(iob )) aNode%iob =iob if(present(ich )) aNode%ich =ich if(present(elat)) aNode%elat=elat if(present(elon)) aNode%elon=elon if(present(luse)) aNode%luse=luse if(present(wgtjo )) aNode%wgtjo =wgtjo if(present(jiter)) then if(present(muse ).or.present(nldepart)) then ASSERT(jiter>=lbound(anode%muse ,1)) ASSERT(jiter<=ubound(anode%muse ,1)) ASSERT(jiter>=lbound(anode%nldepart,1)) ASSERT(jiter<=ubound(anode%nldepart,1)) endif if(present(obssen).or.present(tldepart)) then ASSERT(jiter>=lbound(anode%obssen ,1)) ASSERT(jiter<=ubound(anode%obssen ,1)) ASSERT(jiter>=lbound(anode%tldepart,1)) ASSERT(jiter<=ubound(anode%tldepart,1)) endif if(present(muse )) aNode%muse (jiter) = muse if(present(nldepart)) aNode%nldepart(jiter) = nldepart if(present(tldepart)) aNode%tldepart(jiter) = tldepart if(present(obssen )) aNode%obssen (jiter) = obssen endif !call obsNode_check_(myname_,aNode_) _EXIT_(myname_) return end subroutine obsNode_set_ subroutine obsNode_get_(anode, & idv,iob,ich,elat,elon,luse,wgtjo, & jiter,muse,nldepart,tldepart,obssen) implicit none type(_obsNode_),intent(inout):: anode integer(kind=i_kind),optional,intent(out):: idv,iob,ich real (kind=r_kind),optional,intent(out):: elat,elon logical ,optional,intent(out):: luse real (kind=r_kind),optional,intent(out):: wgtjo integer(kind=i_kind),optional,intent(in ):: jiter logical ,optional,intent(out):: muse real(kind=r_kind) ,optional,intent(out):: nldepart real(kind=r_kind) ,optional,intent(out):: tldepart real(kind=r_kind) ,optional,intent(out):: obssen character(len=*),parameter:: myname_=myname//"::obsNode_get_" _ENTRY_(myname_) if(present(idv )) idv = aNode%idv if(present(iob )) iob = aNode%iob if(present(ich )) ich = aNode%ich if(present(elat)) elat = aNode%elat if(present(elon)) elon = aNode%elon if(present(luse)) luse = aNode%luse if(present(wgtjo )) wgtjo = aNode%wgtjo if(present(jiter)) then if(present(muse ).or.present(nldepart)) then ASSERT(jiter>=lbound(anode%muse ,1)) ASSERT(jiter<=ubound(anode%muse ,1)) ASSERT(jiter>=lbound(anode%nldepart,1)) ASSERT(jiter<=ubound(anode%nldepart,1)) endif if(present(obssen).or.present(tldepart)) then ASSERT(jiter>=lbound(anode%obssen ,1)) ASSERT(jiter<=ubound(anode%obssen ,1)) ASSERT(jiter>=lbound(anode%tldepart,1)) ASSERT(jiter<=ubound(anode%tldepart,1)) endif if(present(muse )) muse = aNode%muse (jiter) if(present(nldepart)) nldepart = aNode%nldepart(jiter) if(present(tldepart)) tldepart = aNode%tldepart(jiter) if(present(obssen )) obssen = aNode%obssen (jiter) endif !call obsNode_check_(myname_,aNode_) _EXIT_(myname_) return end subroutine obsNode_get_ subroutine obsNode_read_(aNode,iunit,kiter,istat,redistr) implicit none type(_obsNode_), intent(inout):: aNode integer(kind=i_kind), intent(in ):: iunit integer(kind=i_kind), intent(in ):: kiter ! input size integer(kind=i_kind), intent(out ):: istat logical , intent(in ):: redistr character(len=*),parameter:: myname_=myname//'::obsNode_read_' integer(kind=i_kind):: ier !real(kind=r_kind),dimension(1:kiter):: zobssen _ENTRY_(myname_) istat=0 read(iunit,iostat=ier) aNode%luse,aNode%elat,aNode%elon, & aNode%idv ,aNode%iob ,aNode%ich if(ier/=0) then call perr(myname_,'read(%luse,%elat,%elon,...), iostat =',ier) istat=-1 _EXIT_(myname_) return endif istat=1 if(redistr) then istat=0 if(aNode%luse) then if(obsNode_islocal_(aNode)) istat=1 endif endif if(istat==0) then read(iunit,iostat=ier) if(ier/=0) then call perr(myname_,'skipping read(%nchanl,%muse,...), iostat =',ier) istat=-2 _EXIT_(myname_) return endif else read(iunit,iostat=ier) & aNode%muse (1:kiter+1), & ! = lmuse(1:kiter) aNode%nldepart(1:kiter+1), & ! = znldepart(1:kiter) aNode%tldepart(1:kiter), & ! = ztldepart(1:kiter) aNode%wgtjo, & ! = zwgtjo aNode%obssen (1:kiter) ! = zobssen(1:kiter) if(ier/=0) then call perr(myname_,'read(%nchanl,%muse,...), iostat =',ier) istat=-3 _EXIT_(myname_) return endif ! if (lobsensfc.and..not.lsensrecompute) then ! aNode%obssen(jiter+1:miter )=zobssen(jiter+1:miter ) ! elseif(lobserver) then ! aNode%obssen( 1:jiter-1)=zobssen( 1:jiter-1) ! else ! aNode%obssen( 1:miter )=zobssen( 1:miter ) ! endif endif call obsNode_check_(myname_,aNode) _EXIT_(myname_) return end subroutine obsNode_read_ subroutine obsNode_write_(aNode,iunit,jiter,istat) implicit none type(_obsNode_), intent(in ):: aNode integer(kind=i_kind), intent(in ):: iunit integer(kind=i_kind), intent(in ):: jiter ! the output size integer(kind=i_kind), intent(inout):: istat character(len=*),parameter:: myname_=myname//'::obsNode_write_' _ENTRY_(myname_) write(iunit,iostat=istat) aNode%luse,aNode%elat,aNode%elon, & aNode%idv,aNode%iob,aNode%ich if(istat/=0) then call perr(myname_,'write(%luse,%elat,%elon,...), iostat =',istat) _EXIT_(myname_) return endif write(iunit,iostat=istat) & aNode%muse (1:jiter+1),& aNode%nldepart(1:jiter+1),& aNode%tldepart(1:jiter),& aNode%wgtjo, & aNode%obssen(1:jiter) if(istat/=0) then call perr(myname_,'write(%nchanl,%muse,...), iostat =',istat) _EXIT_(myname_) return endif call obsNode_check_(myname_,aNode) _EXIT_(myname_) return end subroutine obsNode_write_ subroutine obsNode_dealloc_(aNode,deep) implicit none type(_obsNode_),pointer,intent(inout):: aNode logical,optional,intent(in):: deep character(len=*),parameter:: myname_=myname//'::obsNode_dealloc_' logical:: deep_ _ENTRY_(myname_) call obsNode_check_(myname_,aNode) deep_=.false. if(present(deep)) deep_=deep ASSERT(associated(aNode)) ! _TRACEV_(myname_,'if(deep_), deep_ =',deep_) if(deep_) then ! _TRACEV_(myname_,'associated(aNode%nldepart) =',associated(aNode%nldepart)) if(associated(aNode%nldepart)) deallocate(aNode%nldepart) ! _TRACEV_(myname_,'associated(aNode%tldepart) =',associated(aNode%tldepart)) if(associated(aNode%tldepart)) deallocate(aNode%tldepart) ! _TRACEV_(myname_,'associated(aNode%obssen ) =',associated(aNode%obssen )) if(associated(aNode%obssen )) deallocate(aNode%obssen ) ! _TRACEV_(myname_,'associated(aNode%muse ) =',associated(aNode%muse )) if(associated(aNode%muse )) deallocate(aNode%muse ) endif ! This is NOT a recursive dealloc_(). Therefore, the associated target of ! %next is not deallocated, but only %next itself is nullified. ! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) aNode%next => null() ! _TRACEV_(myname_,'associated(%next) =',associated(aNode%next)) deallocate(aNode) ! _TRACEV_(myname_,'associated(aNode) =',associated(aNode)) _EXIT_(myname_) return end subroutine obsNode_dealloc_ subroutine obsNode_show_(aNode,iob) use mpeu_util, only: stdout implicit none type(_obsNode_),intent(in):: aNode integer(kind=i_kind),intent(in):: iob character(len=*),parameter:: myname_=MYNAME//'::obsNode_show_' _ENTRY_(myname_) write(stdout,'(2a,5i4,l4,2f8.2)') myname,":: iob,ity,%(idv,iob,ich,luse,elat,elon) =", & iob,0,aNode%idv,aNode%iob,aNode%ich,aNode%luse,aNode%elat,aNode%elon call obsNode_check_(myname_,aNode) _EXIT_(myname_) return end subroutine obsNode_show_ end module m_obsdiagNode