From a2ceea6eb03df85decc64e227617d76b03e098d8 Mon Sep 17 00:00:00 2001 From: "michael.lueken" Date: Fri, 24 Jul 2020 18:22:32 +0000 Subject: [PATCH] GitHub Issue NOAA-EMC/GSI#13. Continuing to clear through coding standard issues in the master. Finished through src/gsi/mod_strong.f90. --- src/gsi/m_latlonrange.F90 | 36 +- src/gsi/m_obsLList.F90 | 930 ----------------- src/gsi/m_obsNode.F90 | 753 -------------- src/gsi/m_obsNodeTypeManager.F90 | 453 --------- src/gsi/m_obsdiagNode.F90 | 1591 ------------------------------ src/gsi/m_obsdiagnode.F90 | 1591 ++++++++++++++++++++++++++++++ src/gsi/m_obsdiags.F90 | 1464 +++++++++++++-------------- src/gsi/m_obsllist.F90 | 930 +++++++++++++++++ src/gsi/m_obsnode.F90 | 753 ++++++++++++++ src/gsi/m_obsnodetypemanager.F90 | 453 +++++++++ src/gsi/mod_fv3_lola.f90 | 338 +++---- src/gsi/mod_nmmb_to_a.f90 | 94 +- src/gsi/mod_strong.f90 | 120 +-- src/gsi/model_ad.F90 | 220 ++--- src/gsi/model_tl.F90 | 295 +++--- 15 files changed, 5011 insertions(+), 5010 deletions(-) delete mode 100644 src/gsi/m_obsLList.F90 delete mode 100644 src/gsi/m_obsNode.F90 delete mode 100644 src/gsi/m_obsNodeTypeManager.F90 delete mode 100644 src/gsi/m_obsdiagNode.F90 create mode 100644 src/gsi/m_obsdiagnode.F90 create mode 100644 src/gsi/m_obsllist.F90 create mode 100644 src/gsi/m_obsnode.F90 create mode 100644 src/gsi/m_obsnodetypemanager.F90 diff --git a/src/gsi/m_latlonrange.F90 b/src/gsi/m_latlonrange.F90 index ac74a1db36..c9d9e4b39a 100644 --- a/src/gsi/m_latlonrange.F90 +++ b/src/gsi/m_latlonrange.F90 @@ -144,15 +144,15 @@ module m_latlonrange #include "myassert.H" -#define _TIMER_ON_ -#ifdef _TIMER_ON_ -#undef _TIMER_ON_ -#undef _TIMER_OFF_ -#define _TIMER_ON_(id) call timer_ini(id) -#define _TIMER_OFF_(id) call timer_fnl(id) +#define _timer_on_ +#ifdef _timer_on_ +#undef _timer_on_ +#undef _timer_off_ +#define _timer_on_(id) call timer_ini(id) +#define _timer_off_(id) call timer_fnl(id) #else -#define _TIMER_ON_(id) -#define _TIMER_OFF_(id) +#define _timer_on_(id) +#define _timer_off_(id) #endif !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='m_latlonrange' @@ -364,7 +364,7 @@ subroutine gatherwrite_(llrange,hdfile,root,comm) integer(kind=i_kind),allocatable,dimension(:,:):: irecv real (kind=r_kind), dimension(5 ):: rsend real (kind=r_kind),allocatable,dimension(:,:):: rrecv -_TIMER_ON_(myname_) +_timer_on_(myname_) lsize=0 if(mype==root) lsize=npes @@ -411,7 +411,7 @@ subroutine gatherwrite_(llrange,hdfile,root,comm) endif deallocate(irecv,rrecv) -_TIMER_OFF_(myname_) +_timer_off_(myname_) end subroutine gatherwrite_ subroutine readbcast_(hdfile,allranges,root,comm) @@ -428,7 +428,7 @@ subroutine readbcast_(hdfile,allranges,root,comm) integer(kind=i_kind):: ier,lu,irec,jrec,nrec integer(kind=i_kind),allocatable,dimension(:,:):: ibufr real (kind=r_kind),allocatable,dimension(:,:):: rbufr -_TIMER_ON_(myname_) +_timer_on_(myname_) nrec=0 if(mype==root) then @@ -479,7 +479,7 @@ subroutine readbcast_(hdfile,allranges,root,comm) alon_max=rbufr(5,irec) ) enddo deallocate(ibufr,rbufr) -_TIMER_OFF_(myname_) +_timer_off_(myname_) end subroutine readbcast_ subroutine alldump_(allranges,varname) @@ -495,7 +495,7 @@ subroutine alldump_(allranges,varname) character(len=*),parameter:: myname_=myname//"::alldump_" integer(i_kind):: irec character(len=:), allocatable:: varlead_ -_TIMER_ON_(myname_) +_timer_on_(myname_) varlead_=stdout_lead(varname) @@ -505,7 +505,7 @@ subroutine alldump_(allranges,varname) write(stdout,'(a,i4,l2,i8,5f12.4)') varlead_, irec,islocal_( allranges(irec)),allranges(irec) enddo write (stdout,'(a,1x,a)') varlead_,'========' -_TIMER_OFF_(myname_) +_timer_off_(myname_) end subroutine alldump_ subroutine gatherdump_local_(varname,root,comm) @@ -516,10 +516,10 @@ subroutine gatherdump_local_(varname,root,comm) integer(kind=i_kind),intent(in):: comm character(len=*),parameter:: myname_=myname//"::gatherdump_local_" -_TIMER_ON_(myname_) +_timer_on_(myname_) if(.not.localrange_defined_) call localrange_config_() call gatherdump_(localrange_,varname,root,comm) -_TIMER_OFF_(myname_) +_timer_off_(myname_) end subroutine gatherdump_local_ subroutine gatherdump_(llrange,varname,root,comm) @@ -546,7 +546,7 @@ subroutine gatherdump_(llrange,varname,root,comm) real (kind=r_kind), dimension(5 ):: rsend real (kind=r_kind),allocatable,dimension(:,:):: rrecv character(len=:),allocatable:: varlead_ -_TIMER_ON_(myname_) +_timer_on_(myname_) lsize=0 if(mype==root) lsize=npes @@ -580,7 +580,7 @@ subroutine gatherdump_(llrange,varname,root,comm) endif deallocate(irecv,rrecv) -_TIMER_OFF_(myname_) +_timer_off_(myname_) end subroutine gatherdump_ end module m_latlonrange diff --git a/src/gsi/m_obsLList.F90 b/src/gsi/m_obsLList.F90 deleted file mode 100644 index 74b9baa2c1..0000000000 --- a/src/gsi/m_obsLList.F90 +++ /dev/null @@ -1,930 +0,0 @@ -module m_obsLList -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsLList -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of linked-list of polymorphic obsNode. -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2016-06-24 j.guo - added support of using m_latlonRange to find a cluster -! latlonRange from (elat,elon) values of observations. -! 2016-07-25 j.guo - added getTLDdotprod, to accumulate obsNode TLD-dot_produst -! 2016-09-19 j.guo - added function lincr_() to extend []_lsize(). -! 2017-08-26 G.Ge - change allocate(headLL%mold,mold=mold) -! to allocate(headLL%mold,source=mold) -! -! 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 - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: obsLList - - type obsLList - private - integer(i_kind):: n_alloc =0 - - integer(i_kind):: my_obsType =0 - class(obsNode),pointer:: mold => null() ! a mold for the nodes - - class(obsNode),pointer:: head => null() ! - class(obsNode),pointer:: tail => null() - - integer(i_kind):: l_alloc =0 ! previous n_alloc, see showincr - end type obsLList - - public:: obsLList_mold ! get the mold of the obsLList - interface obsLList_mold; module procedure lmold_; end interface - - public:: obsLList_reset ! reset or finalize obsLList to its empty state. - public:: obsLList_appendNode ! append a node to obsLList - - interface obsLList_reset ; module procedure lreset_ ; end interface - interface obsLList_appendNode; module procedure lappendNode_; end interface - - public:: obsLList_rewind ! rewind obsLList - public:: obsLList_nextNode ! move obsLList to its next node - - interface obsLList_rewind ; module procedure lrewind_ ; end interface - interface obsLList_nextNode ; module procedure lnextNode_ ; end interface - - public:: obsLList_headNode ! locate the head node of obsLList - public:: obsLList_tailNode ! locate the tail node of obsLList - - interface obsLList_headNode ; module procedure lheadNode_ ; end interface - interface obsLList_tailNode ; module procedure ltailNode_ ; end interface - - public:: obsLList_lsize ! get the size of a LList - public:: obsLList_lcount ! get the size of a LList - public:: obsLList_lsort ! sort nodes according to their keys - public:: obsLList_write ! output a LList to a file unit - public:: obsLList_read ! input from a file created by _write() - public:: obsLList_checksum ! size consistency checking - public:: obsLList_summary ! show some information about the LList - - interface obsLList_lsize ; module procedure lsize_, & - lincr_ ; end interface - interface obsLList_lcount ; module procedure lcount_ ; end interface - interface obsLList_lsort ; module procedure lsort_ ; end interface - interface obsLList_write ; module procedure lwrite_ ; end interface - interface obsLList_read ; module procedure lread_ ; end interface - interface obsLList_checksum; module procedure & - lchecksum_, & - lchecksum1_ ; end interface - interface obsLList_summary; module procedure lsummary_; end interface - - public:: obsLList_getTLDdotprod ! get "LHS" (dot-product of (:)%diags%tldepar, plus count) - interface obsLList_getTLDdotprod ; module procedure lTLDdotprod_ ; end interface - - character(len=*),parameter:: MYNAME="m_obsLList" - -#include "myassert.H" -#include "mytrace.H" -contains - -subroutine lTLDdotprod_(headLL,jiter,tlddp,nnode,nob) -!-- get "LHS" of the given linked-list - use kinds, only: i_kind,r_kind - use m_obsNode, only: obsNode_next, obsNode_isluse - implicit none - type(obsLList),target, intent(in):: headLL ! a linked-list - integer(kind=i_kind) , intent(in):: jiter ! for this iteration - real (kind=r_kind) , intent(inout):: tlddp ! dot_product((:)%tld) - integer(kind=i_kind) , optional, intent(inout):: nnode ! node count - integer(kind=i_kind) , optional, intent(inout):: nob ! obs. count - - class(obsNode),pointer:: iNode - iNode => lheadNode_(headLL) - do while(associated(iNode)) - if(obsNode_isluse(iNode)) then - call iNode%getTLDdp(jiter,tlddp,nob=nob) - if(present(nnode)) nnode=nnode+1 - endif - iNode => obsNode_next(iNode) - enddo -end subroutine lTLDdotprod_ - -function lmold_(headLL) result(ptr_) - implicit none - class(obsNode),pointer:: ptr_ - type(obsLList),target,intent(in):: headLL - ptr_ => null() - if(associated(headLL%mold)) ptr_ => headLL%mold -end function lmold_ - -!--------------------------- will go to m_obsLList ---------------------- -subroutine lrewind_(headLL) - implicit none - type(obsLList),target,intent(inout):: headLL - headLL%tail => null() -end subroutine lrewind_ - -function lnextNode_(headLL) result(here_) - use m_obsNode, only: obsNode_next - implicit none - class(obsNode),pointer:: here_ - type(obsLList),target,intent(inout):: headLL - - if(associated(headLL%tail)) then - ! when not the first time lnextNode_(), after call lrewind_() - headLL%tail => obsNode_next(headLL%tail) - else - ! When the first time lnextNode_(), after call lrewind_() - headLL%tail => lheadNode_(headLL) - endif - here_ => headLL%tail -end function lnextNode_ - -function lheadNode_(headLL) result(here_) - implicit none - class(obsNode),pointer:: here_ - type(obsLList),target,intent(in):: headLL - here_ => headLL%head -end function lheadNode_ - -function ltailNode_(headLL) result(here_) - implicit none - class(obsNode),pointer:: here_ - type(obsLList),target,intent(in):: headLL - here_ => headLL%tail -end function ltailNode_ - -function lsize_(headLL) - implicit none - integer(i_kind):: lsize_ - type(obsLList),intent(in):: headLL - lsize_=headLL%n_alloc -end function lsize_ -function lincr_(headLL,incr) - implicit none - integer(i_kind):: lincr_ - type(obsLList),intent(inout):: headLL - logical,intent(in):: incr - lincr_=headLL%n_alloc - if(incr) then - lincr_=lincr_-headLL%l_alloc - headLL%l_alloc=headLL%n_alloc - endif -end function lincr_ - -subroutine lreset_(headLL,mold,stat) -!$$$ subprogram documentation block -! . . . . -! subprogram: lreset_ -! prgmmr: J. Guo -! -! abstract: reset a linked-list to empty. -! -! program history log: -! 2015-01-12 guo - reset headLL for a generic obsNode -! -! 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 m_obsNode, only: obsNode_next - use m_obsNode, only: obsNode_clean - use m_obsNode, only: obsNode_type => obsNode_mytype - implicit none - type(obsLList), intent(inout):: headLL - class(obsNode), intent(in ):: mold - integer(i_kind),optional,intent(out):: stat - - character(len=*),parameter:: myname_=MYNAME//"::lreset_" - character(len=:),allocatable:: mymold_ - integer(i_kind):: n - integer(i_kind):: ier -_ENTRY_(myname_) - - if(present(stat)) stat=0 - - call obsNode_clean(headLL%head,deep=.true.,depth=n,stat=ier) - if(ier/=0.or.n/=0) then - call perr(myname_,'obsNode_clean(.deep.), stat =',ier) - call perr(myname_,' depth =',n) - call perr(myname_,' lsize(headLL) =',lsize_(headLL)) - call perr(myname_,' headLL%head%mytype() =',obsNode_type(headLL%head)) - call perr(myname_,' headLL%mold%mytype() =',obsNode_type(headLL%mold)) - if(.not.present(stat)) call die(myname_) - stat=ier - _EXIT_(myname_) - return - endif - - call nodeDestroy_(headLL%head) - - headLL%n_alloc = 0 - headLL%l_alloc = 0 - headLL%head => null() - headLL%tail => null() - - if(associated(headLL%mold)) then - mymold_ = obsNode_type(headLL%mold) - deallocate(headLL%mold,stat=ier) - if(ier/=0) then - call perr(myname_,'deallocate(headLL%mold), stat =',ier) - call perr(myname_,' obsNode_type(headLL%mold) =',mymold_) - if(.not.present(stat)) call die(myname_) - stat=ier - _EXIT_(myname_) - return - endif - endif - - allocate(headLL%mold, mold=mold) -_EXIT_(myname_) -return -end subroutine lreset_ - -subroutine lappendNode_(headLL,targetNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: lappendNode_ -! prgmmr: J. Guo -! -! abstract: append a node to the given linked-list -! -! program history log: -! 2015-01-12 guo - constructed for generic _obsNode_ -! -! input argument list: (see Fortran declarations below) -! -! output argument list: (see Fortran declarations below) -! -! attributes: -! language: f90/f95/f2003/f2008 -! machine: -! -!$$$ end documentation block - ! Link the next node of the list to the given targetNode. The return - ! result is a pointer associated to the same targetNode. - use m_obsNode, only: obsNode_append - implicit none - type(obsLList), intent(inout):: headLL - !class(obsNode), target, intent(in):: targetNode - class(obsNode), pointer, intent(in):: targetNode - - character(len=*),parameter:: myname_=MYNAME//'::lappendNode_' -!_ENTRY_(myname_) - ASSERT(associated(targetNode)) - - if(.not.associated(headLL%head)) then - ! this is a fresh starting -node- for this linked-list ... - call obsNode_append(headLL%head,targetNode) - headLL%tail => headLL%head - headLL%n_alloc = 1 - - else - ASSERT(associated(headLL%tail)) - ASSERT(.not.associated(headLL%tail,targetNode)) - - call obsNode_append(headLL%tail,targetNode) - headLL%n_alloc = headLL%n_alloc + 1 - - endif - -!_EXIT_(myname_) -return -end subroutine lappendNode_ - -!--------------------------- will go to m_obsLListIO ---------------------- -subroutine lread_(headLL,iunit,redistr,diagLookup,jtype) -!$$$ subprogram documentation block -! . . . . -! subprogram: lread_ -! prgmmr: todling -! prgmmr: J. Guo -! -! abstract: Read obs-specific data structure from file. -! -! program history log: -! 2007-10-03 todling - (original read_obsdiags::read_${OBSTYPE}head_() -! 2008-12-08 todling - update to May08 version -! 2015-01-12 guo - restructured for generic _obsNode_, with redistributions -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - !use obsmod, only: obs_diags - use m_obsdiagNode, only: obs_diags - use m_obsNode, only: obsNode_read - use m_obsNode, only: obsNode_setluse - implicit none - type(obsLList), intent(inout):: headLL - integer(i_kind), intent(in ):: iunit - logical , intent(in ):: redistr - type(obs_diags), intent(in ):: diagLookup - integer(i_kind), intent(in ):: jtype - - character(len=*),parameter:: myname_=MYNAME//"::lread_" - class(obsNode),pointer :: aNode => NULL() - integer(i_kind) :: kk,istat,mobs,jread -_ENTRY_(myname_) - -! Read in an obs-specific header of the next block -! >>>>>---------------------------- -! obsHeader is the information about an obs-block, where an obs-block -! a collection of nodes of the same _obsNode_ type, -! !-- not about the corresponding linked-list. - - ASSERT(associated(headLL%mold)) - - call obsHeader_read_(headLL%mold,iunit,mobs,jread,istat) - - if(istat/=0) then - call perr(myname_,'%obsHeader_read_(mobs,jread), istat =',istat) - call perr(myname_,' iunit =',iunit) - call die(myname_) - endif - - if(jtype/=jread) then - call perr(myname_,'unexpected record type, jread =',jread) - call perr(myname_,' expecting jtype =',jtype) - call perr(myname_,' mobs =',mobs) - call perr(myname_,' iunit =',iunit) - call die(myname_) - end if -! ----------------------------<<<<< - - if(mobs==0) then - ! No more record to read - _EXIT_(myname_) - return - endif - - !-- construct an aNode - aNode => alloc_nodeCreate_(mold=headLL%mold) - do kk=1,mobs - !-- initialize aNode from a file (iunit) - call obsNode_read(aNode,iunit,istat,redistr=redistr,diagLookup=diagLookup) - if(istat<0) then - call perr(myname_,'obsNode_read(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call perr(myname_,' kk =',kk) - call perr(myname_,' mobs =',mobs) - call perr(myname_,' redistr =',redistr) - call perr(myname_,' jtype =',jtype) - call die(myname_) - endif - - if(istat==0) cycle - - !-- If this aNode is to be kept ... - if(redistr) then - ! recompute its %luse and %Hop for the redistributed grid partition, - - call obsNode_setluse(aNode) ! reset %luse for subdomain ownership - call aNode%setHop() ! recompute %Hop for the new grid - endif - - !-- keep this obsNode in its linked-list, obsLList := obsdiags(jtype,ibin) - call lappendNode_(headLL,targetNode=aNode) - - !-- Drop the earlier object, contruct a new aNode. - !-- No deep deallocation is needed for aNode, since its - !-- associated target has been passed to headLL - aNode => null() - aNode => alloc_nodeCreate_(mold=headLL%mold) - - enddo ! < mobs > - - call nodeDestroy_(aNode) ! Clean up the working-space an_onsNode - -_EXIT_(myname_) -return -end subroutine lread_ - -subroutine lwrite_(headLL,iunit,luseonly,jtype,luseRange) -!$$$ subprogram documentation block -! . . . . -! subprogram: lwrite_ -! prgmmr: todling -! prgmmr: J. Guo -! -! abstract: Write obs-specific data structure from file. -! -! program history log: -! 2007-10-03 todling - (original write_obsdiags::write_${OBSTYPE}head_() -! 2008-12-08 todling - update to May08 version -! 2015-01-12 guo - restructured for generic _obsNode_, with redistributions -! -! input argument list: -! -! output argument list: -! -! attributes: -! language: f90 -! machine: -! -!$$$ end documentation block - - use m_obsNode, only: obsNode_next - use m_obsNode, only: obsNode_isluse - use m_obsNode, only: obsNode_write - use m_latlonRange, only: latlonRange - use m_latlonRange, only: latlonRange_enclose - implicit none - type(obsLList), intent(in):: headLL - integer(i_kind ), intent(in):: iunit ! unit for output - logical , intent(in):: luseonly - integer(i_kind ), intent(in):: jtype - type(latlonRange),optional,intent(inout):: luseRange - - character(len=*),parameter:: myname_=MYNAME//"::lwrite_" - class(obsNode), pointer :: iNode => NULL() - integer(i_kind) :: istat - integer(i_kind) :: mobs,lobs,iobs,kobs - logical:: isluse_ -_ENTRY_(myname_) - -! if(jtype/=iobsType) then -! call perr(myname_,'unexpected record type, jtype =',jtype) -! call perr(myname_,' expecting iobsType =',iobsType) -! call perr(myname_,' iunit =',iunit) -! call die(myname_) -! end if - -! Read in an obs-specific header of the next block -! >>>>>---------------------------- -! !-- A header is about a collection of nodes of the same obsNode type, -! !-- not about the corresponding linked-list. - - ASSERT(associated(headLL%mold)) - - lobs = lcount_(headLL,luseonly=luseonly) ! actual count of write - mobs = lobs - if(.not.luseonly) mobs = lsize_(headLL) ! actual count of nodes - - call obsHeader_write_(headLL%mold,iunit,lobs,jtype,istat) - - if(istat/=0) then - call perr(myname_,'obsHeader_write_(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call perr(myname_,' jtype =',jtype) - call perr(myname_,' no. node of write =',lobs) - call perr(myname_,' no. node of data =',mobs) - call perr(myname_,' luseonly =',luseonly) - call die(myname_) - endif -! ----------------------------<<<<< - - if(lobs==0) then - ! No more record to write - _EXIT_(myname_) - return - endif - -!-- looping over the linked-list for every obsNode, - - iNode => lheadNode_(headLL) - iobs=0 - kobs=0 - do while(associated(iNode)) - iobs=iobs+1 - isluse_=obsNode_isluse(iNode) - if(isluse_ .or. .not.luseonly) then - if(isluse_.and.present(luseRange)) & - call latlonRange_enclose(luseRange,iNode%elat,iNode%elon) - kobs=kobs+1 - call obsNode_write(iNode,iunit,istat) - if(istat/=0) then - call perr(myname_,' obsNode_write(), istat =',istat) - call perr(myname_,' iunit =',iunit) - call perr(myname_,' jtype =',jtype) - call perr(myname_,'current-luse-node, kobs =',kobs) - call perr(myname_,' current-all-node, iobs =',iobs) - call perr(myname_,' total-luse-node-count =',lobs) - call perr(myname_,' total-all-node-count =',mobs) - call perr(myname_,' luseonly =',luseonly) - call die(myname_) - endif - endif - iNode => obsNode_next(iNode) - enddo - - ASSERT(iobs==mobs) - ASSERT(kobs==lobs) -_EXIT_(myname_) -return -end subroutine lwrite_ - -subroutine lchecksum_(headLL,itype,ibin,leadNode,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,stdout_lead - implicit none - type(obsLList), intent(in):: headLL - integer(kind=i_kind),optional,intent(in ):: itype,ibin - class(obsNode),optional,pointer, intent(in):: leadNode - logical ,optional,intent(out):: sorted - - character(len=*),parameter:: myname_=MYNAME//"::lchecksum_" - integer(kind=i_kind):: lrecount - integer(kind=i_kind):: jtype,jbin - integer(kind=i_kind):: nuse,nooo,ndup,ksum(2) -_ENTRY_(myname_) - lrecount=lcount_(headLL,recount=.true.,nuse=nuse,nooo=nooo,ndup=ndup,ksum=ksum,leadNode=leadNode) - if(present(sorted)) sorted = nooo==0.and.ndup==0 - - jtype=itype - jbin =ibin -_EXIT_(myname_) -return -end subroutine lchecksum_ -subroutine lchecksum1_(headLL,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):: headLL - integer(kind=i_kind),optional ,intent(in):: itype - - character(len=*),parameter:: myname_=MYNAME//"::lchecksum1_" - integer(kind=i_kind):: i -_ENTRY_(myname_) - do i=1,size(headLL) - call lchecksum_(headLL(i),itype=itype,ibin=i) - enddo -_EXIT_(myname_) -return -end subroutine lchecksum1_ - -subroutine lsummary_(headLL,verbose) -!$$$ subprogram documentation block -! . . . . -! subprogram: lsummary_ -! prgmmr: J. Guo -! -! abstract: summarize for the contents of a linked-list. -! -! program history log: -! 2015-01-12 guo - constructed for generic _obsNode_ -! -! 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 m_obsNode, only: obsNode_next - use m_obsNode, only: obsNode_show - implicit none - type(obsLList), intent(in):: headLL - logical,optional, intent(in):: verbose - - character(len=*),parameter:: myname_=MYNAME//"::lsummary_" - class(obsNode), pointer:: iNode - integer(i_kind):: iobs_ - logical:: verbose_ - verbose_=.false. - if(present(verbose)) verbose_=verbose -_ENTRY_(myname_) - !call tell(myname_,' headLList%n_alloc =',headLL%n_alloc) - - if(verbose_) then - iobs_ = 0 - iNode => lheadNode_(headLL) - do while(associated(iNode)) - iobs_=iobs_+1 - call obsNode_show(iNode,iobs_) - iNode => obsNode_next(iNode) - enddo - endif -_EXIT_(myname_) -return -end subroutine lsummary_ - -function lcount_(headLL,luseonly,recount,nuse,nooo,ndup,ksum,leadNode) result(lobs_) -!$$$ subprogram documentation block -! . . . . -! subprogram: lcount_ -! prgmmr: J. Guo -! -! abstract: inquire for the size information about the linked-list -! -! program history log: -! 2015-01-12 guo - constructed for generic _obsNode_ -! -! 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 m_obsNode, only: obsNode_next - use m_obsNode, only: obsNode_isluse - implicit none - integer(kind=i_kind):: lobs_ - type(obsLList), target, intent(in):: headLL - logical,optional,intent(in):: luseonly ! count only luse data - logical,optional,intent(in):: recount - integer(kind=i_kind),optional,intent(out):: nuse ! no. 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 - class(obsNode), pointer, optional, intent(in):: leadNode - - character(len=*),parameter:: myname_=MYNAME//"::lcount_" - class(obsNode), pointer:: iNode - integer(i_kind):: nuse_ - integer(kind=i_kind),dimension(2) :: 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) - if(.not.recount_) recount_ = checksum_ - - if(present(ksum)) then - ALWAYS_ASSERT(size(ksum)==size(kprev)) - endif - - if(.not.(luseonly_.or.recount_)) then - lobs_=headLL%n_alloc - - else - lobs_ = 0 - nuse_ = 0 - - if(checksum_) call checksum_init_(kprev,nooo=nooo,ndup=ndup,ksum=ksum) - - iNode => lheadNode_(headLL) - 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, & - knext=(/iNode%idv,iNode%iob/),nooo=nooo,ndup=ndup,ksum=ksum) - - iNode => obsNode_next(iNode) - enddo - if(present(nuse)) nuse=nuse_ - endif - -_EXIT_(myname_) -return -end function lcount_ - -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 - - integer(kind=i_kind):: k - 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_ - -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_ - -subroutine lsort_(headLL,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 m_obsNode, only: obsNode_next - !use mpeu_util, only: die - implicit none - type(obsLList), intent(inout):: headLL - integer(kind=i_kind),optional,intent(in):: itype,ibin - - character(len=*),parameter:: myname_=myname//'::lsort_' - class(obsNode),pointer:: pNode - integer(kind=i_kind),allocatable,dimension(:):: indx,idv_,iob_ - integer(kind=i_kind):: i,n - logical:: sorted - - type fptr_of_obsnode - class(obsNode),pointer:: ptr - end type fptr_of_obsnode - type(fptr_of_obsnode),allocatable,dimension(:):: lookup -_ENTRY_(myname_) -!_TIMER_ON_(myname_) -! call timer_ini(myname_) - - call lchecksum_(headLL,itype=itype,ibin=ibin,sorted=sorted) - if(sorted) then - _EXIT_(myname_) - return - endif - - n=lsize_(headLL) - - allocate(lookup(n)) - allocate(indx(n),idv_(n),iob_(n)) - - ! Loop over the linked-list, to get keys. - i=0 - pNode => lheadNode_(headLL) - do while(associated(pNode)) - i=i+1 - if(i<=n) then - lookup(i)%ptr => pNode - idv_(i) = pNode%idv - iob_(i) = pNode%iob - endif - pNode => obsNode_next(pNode) - enddo - - ASSERT(i==n) - - ! sort %lookup(1:n), by its (idv,iob) values - call IndexSet (indx) - call IndexSort(indx,iob_) - call IndexSort(indx,idv_) - lookup(1:n) = lookup(indx(1:n)) - - deallocate(indx,idv_,iob_) - - ! Rebuild the linked-list from lookup(1:n)%ptr - headLL%n_alloc = 0 - headLL%head => null() - headLL%tail => null() - - ! rebuild the list according to the sorted table - do i=1,n - call lappendNode_(headLL,lookup(i)%ptr) - enddo - ASSERT(n==headLL%n_alloc) - if(associated(headLL%tail)) then - ASSERT(.not.associated(headLL%tail%llpoint)) - endif - - ! discard the table - deallocate(lookup) - - call lchecksum_(headLL,itype=itype,ibin=ibin,sorted=sorted) - if(.not.sorted) then - call perr(myname_,'failed post-sorting lchecksum_(), 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_ - -function alloc_nodeCreate_(mold) result(ptr_) -!-- allocate() + init() - implicit none - class(obsNode),pointer:: ptr_ - class(obsNode),target,intent(in):: mold - allocate(ptr_,mold=mold) - call ptr_%init() -return -end function alloc_nodeCreate_ - -subroutine nodeDestroy_(node) -!-- clean() + deallocate() - use m_obsNode, only: obsNode_type => obsNode_mytype - implicit none - class(obsNode),pointer,intent(inout):: node - character(len=*),parameter:: myname_=myname//'::nodeDestroy_' - integer(i_kind):: ier - if(associated(node)) then - call node%clean() - deallocate(node,stat=ier) - if(ier/=0) then - call perr(myname_,'can not deallocate(node), stat =',ier) - call perr(myname_,' obsNode_type(node) =',obsNode_type(node)) - call die(myname_) - endif - endif -return -end subroutine nodeDestroy_ - -subroutine obsHeader_read_(aNode,iunit,iobs,itype,istat) -!-- read header of some type - use m_obsNode, only: obsNode - implicit none - class(obsNode) ,intent(in ):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent(out):: iobs,itype - integer(i_kind),intent(out):: istat - call aNode%headerRead(iunit,iobs,itype,istat) -end subroutine obsHeader_read_ - -subroutine obsHeader_write_(aNode,junit,mobs,mtype,istat) -!-- write header of some type - use m_obsNode, only: obsNode - implicit none - class(obsNode) ,intent(in ):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent(in ):: mobs,mtype - integer(i_kind),intent(out):: istat - call aNode%headerWrite(junit,mobs,mtype,istat) -end subroutine obsHeader_write_ -end module m_obsLList diff --git a/src/gsi/m_obsNode.F90 b/src/gsi/m_obsNode.F90 deleted file mode 100644 index 42a7dc8f7e..0000000000 --- a/src/gsi/m_obsNode.F90 +++ /dev/null @@ -1,753 +0,0 @@ -module m_obsNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-01-12 -! -! abstract: basic obsNode functionalities interfacing the distributed grid -! -! program history log: -! 2015-01-12 j guo - added this document block. -! 2016-05-18 j guo - finished its 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 kinds, only: i_kind,r_kind - use mpeu_util, only: tell,perr,die - use mpeu_util, only: assert_ - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - implicit none - private ! except - public:: obsNode ! data structure - - type, abstract:: obsNode - ! private - - ! - Being not "private", type(obsNode) allowes its type extentions - ! to access its components without additional interfaces. - ! - On the other hand, by turning private on, one can use the - ! compiler to report where the components of this type have been - ! used. - - class(obsNode),pointer :: llpoint => NULL() - - logical :: luse =.false. ! flag indicating if ob is used in pen. - real(r_kind) :: time = 0._r_kind ! observation time in sec, relative to the time window - real(r_kind) :: elat = 0._r_kind ! earth lat-lon for redistribution - real(r_kind) :: elon = 0._r_kind ! earth lat-lon for redistribution - - integer(i_kind) :: idv =-1 ! device ID - integer(i_kind) :: iob =-1 ! initial obs sequential ID - -#ifdef _TO_DO_ - integer(i_kind):: nprof ! count of corresponding profile locations - integer(i_kind):: idspl ! cross referencing index to profile locations - ! given i-th observation, corresponding profile - ! is block ([]%idspl+1 : []%idspl+[]%nprof) -#endif - contains - - !----------- overrideable procedures ----------------------------------- - procedure, nopass:: headerRead => obsHeader_read_ ! read a header - procedure, nopass:: headerWrite => obsHeader_write_ ! write a header - - procedure:: init => init_ ! initialize a node - procedure:: clean => clean_ ! clean a node - - !----------- procedures must be defined by extensions ------------------ - procedure(intrfc_mytype_ ),nopass,deferred:: mytype ! return my type name - procedure(intrfc_setHop_ ), deferred:: setHop ! re-construct H - procedure(intrfc_xread_ ), deferred:: xread ! read extensions - procedure(intrfc_xwrite_ ), deferred:: xwrite ! write extensions - procedure(intrfc_isvalid_), deferred:: isvalid ! validate extensions - - procedure(intrfc_gettlddp_), deferred:: gettlddp ! (tlddp,nob)=(sum(%tld*%tld),sum(1) - !--------- non_overrideable procedures are implemented statically ------ - end type obsNode - -!-- module procedures, such as base-specific operations - - public:: obsNode_clean - interface obsNode_clean; module procedure deepclean_; end interface - - ! Nodes operations - public:: obsNode_next ! nextNode => obsNode_next (thisNode) - public:: obsNode_append ! call obsNode_append(thisNode,targetNode) - - interface obsNode_next ; module procedure next_ ; end interface - interface obsNode_append; module procedure append_; end interface - - ! Getters-and-setters - public:: obsNode_islocal ! is aNode local? -- obsNode_islocal(aNode) - public:: obsNode_isluse ! is aNode luse? -- obsNode_isluse(aNode) - public:: obsNode_setluse ! set aNode%luse. -- call obsNode_setluse(aNode) - - interface obsNode_islocal; module procedure islocal_ ; end interface - interface obsNode_isluse ; module procedure isluse_ ; end interface - interface obsNode_setluse; module procedure setluse_ ; end interface - -!-- module procedures, requiring base-specific operations - - ! reader-and-writer - public:: obsNode_read ! call obsNode_read(aNode, ...) - public:: obsNode_write ! call obsNode_write(aNode, ...) - - interface obsNode_read ; module procedure read_ ; end interface - interface obsNode_write ; module procedure write_ ; end interface - - public:: obsNode_show ! call obsNode_show(aNode) - interface obsNode_show ; module procedure show_ ; end interface - - public:: obsNode_mytype ! call obsNode_type(aNode) - interface obsNode_mytype ; module procedure nodetype_ ; end interface - - abstract interface - subroutine intrfc_xread_(aNode,iunit,istat,diagLookup,skip) - use kinds,only: i_kind - use m_obsdiagNode, only: obs_diags - import:: obsNode - implicit none - class(obsNode), intent(inout):: aNode - integer(kind=i_kind), intent(in ):: iunit - integer(kind=i_kind), intent(out):: istat - type(obs_diags) , intent(in ):: diagLookup - logical,optional , intent(in ):: skip - end subroutine intrfc_xread_ - end interface - - abstract interface - subroutine intrfc_xwrite_(aNode,junit,jstat) - use kinds,only: i_kind - import:: obsNode - implicit none - class(obsNode), intent(in):: aNode - integer(kind=i_kind), intent(in ):: junit - integer(kind=i_kind), intent(out):: jstat - end subroutine intrfc_xwrite_ - end interface - - abstract interface - function intrfc_isvalid_(aNode) result(isvalid_) - import:: obsNode - implicit none - logical:: isvalid_ - class(obsNode), intent(in):: aNode - end function intrfc_isvalid_ - end interface - - abstract interface - subroutine intrfc_setHop_(aNode) - use kinds, only: r_kind - import:: obsNode - implicit none - class(obsNode), intent(inout):: aNode - end subroutine intrfc_setHop_ - end interface - - abstract interface - function intrfc_mytype_() - import:: obsNode - implicit none - character(len=:),allocatable:: intrfc_mytype_ - end function intrfc_mytype_ - end interface - - abstract interface - pure subroutine intrfc_gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: i_kind,r_kind - import:: obsNode - implicit none - class(obsNode),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 - end subroutine intrfc_gettlddp_ - end interface - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='m_obsNode' - -#include "mytrace.H" -#include "myassert.H" - -contains -function next_(aNode) result(here_) -!-- associate to thisNode%llpoint. - implicit none - class(obsNode),pointer:: here_ - class(obsNode),target,intent(in):: aNode - - character(len=*),parameter :: myname_=myname//'::next_' -_ENTRY_(myname_) - !!! trying to go next on a null reference is a serious logical error. - here_ => aNode%llpoint -_EXIT_(myname_) -return -end function next_ - -subroutine append_(thisNode,targetNode,follow) -!-- append targetNode to thisNode%llpoint, or thisNode if .not.associated(thisNode) - implicit none - class(obsNode),pointer ,intent(inout):: thisNode - class(obsNode),pointer ,intent(in ):: targetNode - logical ,optional,intent(in):: follow ! Follow targetNode%llpoint to its last node. - ! The default is to nullify(thisNode%llpoint) - - character(len=*),parameter:: myname_=myname//"::append_" - logical:: follow_ -_ENTRY_(myname_) - ASSERT(associated(targetNode)) ! verify for any exception. - - follow_=.false. - if(present(follow)) follow_=follow - - if(.not.associated(thisNode)) then - thisNode => targetNode ! as the first node - - else - thisNode%llpoint => targetNode ! as an additional node - thisNode => thisNode%llpoint - - endif - - if(follow_) then - ! Follow thisNode to thisNode%llpoint, till its end, as targetNode is a - ! valid linked-list. The risk is the possibility of some circular - ! association, evenif both linked-lists, thisNode and targetNode are given - ! clean. - - do while(associated(thisNode%llpoint)) - ASSERT(.not.associated(thisNode%llpoint,targetNode)) - ! This assertion tries to identify possible circular association between - ! linked-list::thisNode and linked-list::targetNode. - - thisNode => thisNode%llpoint - enddo - - else - ! Nullify(thisNode%llpoint) to avoid any possibility of circular - ! association. Note this action WILL touch the input target argument - ! (targetNode) indirectly. - - thisNode%llpoint => null() - endif -_EXIT_(myname_) -return -end subroutine append_ - -function islocal_(aNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: islocal_ -! prgmmr: J. Guo -! -! abstract: check if this node is for the local grid partition. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 mpimod, only: myPE - use m_cvgridLookup, only: cvgridLookup_islocal - implicit none - logical:: islocal_ - class(obsNode),intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//'::islocal_' -_ENTRY_(myname_) - islocal_=cvgridLookup_islocal(aNode%elat,aNode%elon,myPE) -_EXIT_(myname_) -return -end function islocal_ - -function isluse_(aNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: isluse_ -! prgmmr: J. Guo -! -! abstract: check the %luse value of this node -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - logical:: isluse_ - class(obsNode),intent(in):: aNode - character(len=*),parameter:: myname_=MYNAME//'::isluse_' -_ENTRY_(myname_) - isluse_=aNode%luse -_EXIT_(myname_) -return -end function isluse_ - -subroutine setluse_(aNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: lsummary_ -! prgmmr: J. Guo -! -! abstract: set %luse value for locally-owned node. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 mpimod, only: myPE - use m_cvgridLookup, only: cvgridLookup_isluse - implicit none - class(obsNode),intent(inout):: aNode - character(len=*),parameter:: myname_=MYNAME//'::setluse_' -_ENTRY_(myname_) - aNode%luse = cvgridLookup_isluse(aNode%elat, aNode%elon, myPE) -_EXIT_(myname_) -return -end subroutine setluse_ - -!=================================================================== -! Routines below are default code to be used, if they are not override -! by the code invoked this include-file. -subroutine obsHeader_read_(iunit,mobs,jread,istat) -!$$$ subprogram documentation block -! . . . . -! subprogram: obsHeader_read_ -! prgmmr: J. Guo -! -! abstract: read the jtype-block header record. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - 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_' -_ENTRY_(myname_) - read(iunit,iostat=istat) mobs,jread -_EXIT_(myname_) -return -end subroutine obsHeader_read_ - -subroutine obsHeader_write_(junit,mobs,jwrite,jstat) -!$$$ subprogram documentation block -! . . . . -! subprogram: obsHeader_write_ -! prgmmr: J. Guo -! -! abstract: write the jtype-block header record. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - 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 -_EXIT_(myname_) -return -end subroutine obsHeader_write_ - -subroutine init_(aNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: init_ -! prgmmr: J. Guo -! -! abstract: allocate a node. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - class(obsNode),intent(out):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::init_' -_ENTRY_(myname_) -!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) - aNode%llpoint => null() - aNode%luse = .false. - aNode%time = 0._r_kind - aNode%elat = 0._r_kind - aNode%elon = 0._r_kind - aNode%idv =-1 - aNode%iob =-1 -_EXIT_(myname_) -return -end subroutine init_ - -subroutine clean_(aNode) -!$$$ subprogram documentation block -! . . . . -! subprogram: clean_ -! prgmmr: J. Guo -! -! abstract: a shallow node clean -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - class(obsNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::clean_' -_ENTRY_(myname_) -!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) - call anode%init() -_EXIT_(myname_) -return -end subroutine clean_ - -subroutine deepclean_(aNode,deep,depth,stat) -!$$$ subprogram documentation block -! . . . . -! subprogram: subroutine deepclean_ -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2018-04-11 -! -! abstract: a deep node clean -! -! program history log: -! 2018-04-11 j guo - added this document block -! -! 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 - - implicit none - class(obsNode ),pointer ,intent(inout):: aNode - logical ,optional,intent(in ):: deep ! with deep=.true., the full - ! linked-list headed by aNode - ! will be "deep" cleaned. - integer(i_kind),optional,intent(out):: depth ! depth of deep-cleaned nodes at - ! the return. zero is expected - ! unless in an error. - integer(i_kind),optional,intent(out):: stat ! status return. - - character(len=*),parameter:: myname_=MYNAME//'::deepclean_' - integer(i_kind):: ier,depth_ - logical:: deep_ - - if(present(depth)) depth=0 - if(present(stat )) stat=0 - - if(.not.associated(aNode)) return - - deep_=.false. - if(present(deep )) deep_=deep - - if(deep_) then - depth_=0 - call recurs_nodeclean_(aNode,depth_,ier) - if(present(depth)) depth=depth_ - - if(ier/=0) then - call perr(myname_,'recurs_nodeclean_(), stat =',ier) - call perr(myname_,' depth =',depth_) - call perr(myname_,' aNode%mytype() =',nodetype_(aNode)) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - else - ! Full-clean aNode itself, but not %llpoint. This includes any dynamic - ! component of aNode defined in its type/endtype block. - call aNode%clean() - endif - -return -end subroutine deepclean_ - -recursive subroutine recurs_nodeclean_(aNode,depth,stat) - implicit none - class(obsNode),pointer,intent(inout):: aNode - ! This routine intends to fully erase the contents of argument aNode, - ! but not the storage of it. A target attribute is used to prevent any - ! attempt to deallocate. Also see step (2) and (4) below. - integer(i_kind),intent(inout):: depth - integer(i_kind),intent( out):: stat - - character(len=*),parameter:: myname_=MYNAME//"::recurs_nodeclean_" - - stat=0 - if(associated(aNode)) then - - if(associated(aNode%llpoint)) then - depth=depth+1 - - ! (1) deep-clean the target of %llpoint, a level deeper than aNode. - - call recurs_nodeclean_(aNode%llpoint,depth,stat) - if(stat/=0) return - - ! (2) deallocate %llpoint to release the memory associated with it. This is - ! in concert with step (4) below. - - deallocate(aNode%llpoint,stat=stat) - if(stat/=0) then - call perr(myname_,"deallocate(aNode%llpoint), stat =",stat) - call perr(myname_,' depth =',depth) - return - endif - - depth=depth-1 - endif - - ! (3) full-clean aNode itself other than %llpoint, including any its dynamic - ! component defined in its type/endtype block. - - call aNode%clean() - - ! (4) memory storage of aNode itself is NOT expected to be deallocated. - ! This is in concert with step (2) above. - endif -return -end subroutine recurs_nodeclean_ - -subroutine read_(aNode,iunit,istat,redistr,diagLookup) -!$$$ subprogram documentation block -! . . . . -! subprogram: read_ -! prgmmr: J. Guo -! -! abstract: read the input for a node. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 m_obsdiagNode, only: obsdiagLookup_locate - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - implicit none - class(obsNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent( out):: istat - logical ,intent(in ):: redistr - type(obs_diags),intent(in ):: diagLookup - - character(len=*),parameter:: myname_=MYNAME//'::read_' - integer(i_kind):: ier -_ENTRY_(myname_) - - istat=0 - read(iunit,iostat=ier) aNode%luse,aNode%time,aNode%elat,aNode%elon, & - !aNode%dlat,aNode%dlon, & - aNode%idv ,aNode%iob - if(ier/=0) then - call perr(myname_,'read(%(luse,time,elat,elon,...)), iostat =',ier) - istat=-1 - _EXIT_(myname_) - return - endif - - istat=1 ! Now a complete xread(aNode) is expected. - if(redistr) then ! Or additional conditions must be considered. - istat=0 ! A complete xread(aNode) is not expected, unless - if(aNode%luse) then ! ... .and. ... - if(islocal_(aNode)) istat=1 - endif - endif - - call aNode%xread(iunit,ier,diagLookup,skip=istat==0) - if(ier/=0) then - call perr(myname_,'aNode%xread(), iostat =',ier) - call perr(myname_,' skip =',istat==0) - call perr(myname_,' istat =',istat) - istat=-2 - _EXIT_(myname_) - return - endif - -_EXIT_(myname_) -return -end subroutine read_ - -subroutine write_(aNode,junit,jstat) - implicit none -!$$$ subprogram documentation block -! . . . . -! subprogram: write_ -! prgmmr: J. Guo -! -! abstract: write a node for output. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! input argument list: (see Fortran declarations below) -! -! output argument list: (see Fortran declarations below) -! -! attributes: -! language: f90/f95/f2003/f2008 -! machine: -! -!$$$ end documentation block - class(obsNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::write_' -_ENTRY_(myname_) - - jstat=0 - write(junit,iostat=jstat) aNode%luse,aNode%time,aNode%elat,aNode%elon, & - aNode%idv,aNode%iob - if(jstat/=0) then - call perr(myname_,'write(%(luse,elat,elon,...)), jstat =',jstat) - _EXIT_(myname_) - return - endif - - call aNode%xwrite(junit,jstat) - if (jstat/=0) then - call perr(myname_,'aNode%xwrite(), jstat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine write_ - -subroutine show_(aNode,iob) -!$$$ subprogram documentation block -! . . . . -! subprogram: show_ -! prgmmr: J. Guo -! -! abstract: show selected obsNode data. -! -! program history log: -! 2015-01-12 guo - constructed for generic obsNode -! -! 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 - implicit none - class(obsNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iob - - character(len=*),parameter:: myname_=MYNAME//'::show_' - logical:: isvalid_ -_ENTRY_(myname_) - isvalid_=aNode%isvalid() - write(stdout,"(2a,3i4,2x,2l1,3f8.2)") myname,":: iob,%(idv,iob,luse,vald,time,elat,elon) =", & - iob,aNode%idv,aNode%iob,aNode%luse,isvalid_,aNode%time,aNode%elat,aNode%elon -_EXIT_(myname_) -return -end subroutine show_ - -function nodetype_(aNode) -!-- Return its type information, even when the argument is a NULL. - implicit none - character(len=:),allocatable:: nodetype_ - class(obsNode),pointer,intent(in):: aNode - nodetype_=".null.[obsNode]" - if(associated(aNode)) nodetype_=aNode%mytype() -end function nodetype_ - -end module m_obsNode diff --git a/src/gsi/m_obsNodeTypeManager.F90 b/src/gsi/m_obsNodeTypeManager.F90 deleted file mode 100644 index b5ecc6e1ba..0000000000 --- a/src/gsi/m_obsNodeTypeManager.F90 +++ /dev/null @@ -1,453 +0,0 @@ -module m_obsNodeTypeManager -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_obsNodeTypeManager -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2015-08-13 -! -! abstract: obsNode type manager, as an enumerated type molder. -! -! program history log: -! 2015-08-13 j guo - added this document block. -! 2016-05-18 j guo - finished its initial polymorphic implementation, -! with total 33 obs-types. -! 2018-01-23 k apodaca - add a new observation type i.e. lightning (light) -! suitable for the GOES/GLM instrument -! -! 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_psNode , only: psNode - use m_tNode , only: tNode - use m_wNode , only: wNode - use m_qNode , only: qNode - use m_spdNode , only: spdNode - use m_rwNode , only: rwNode - use m_dwNode , only: dwNode - use m_sstNode , only: sstNode - use m_pwNode , only: pwNode - use m_pcpNode , only: pcpNode - use m_ozNode , only: ozNode - use m_o3lNode , only: o3lNode - use m_gpsNode , only: gpsNode - use m_radNode , only: radNode - use m_tcpNode , only: tcpNode - use m_lagNode , only: lagNode - use m_colvkNode, only: colvkNode - use m_aeroNode , only: aeroNode - use m_aerolNode, only: aerolNode - use m_pm2_5Node, only: pm2_5Node - use m_gustNode , only: gustNode - use m_visNode , only: visNode - use m_pblhNode , only: pblhNode - - use m_wspd10mNode, only: wspd10mNode - use m_uwnd10mNode, only: uwnd10mNode - use m_vwnd10mNode, only: vwnd10mNode - - use m_td2mNode , only: td2mNode - use m_mxtmNode , only: mxtmNode - use m_mitmNode , only: mitmNode - use m_pmslNode , only: pmslNode - use m_howvNode , only: howvNode - use m_tcamtNode, only: tcamtNode - use m_lcbasNode, only: lcbasNode - use m_pm10Node , only: pm10Node - use m_cldchNode, only: cldchNode - - use m_swcpNode , only: swcpNode - use m_lwcpNode , only: lwcpNode - - use m_lightNode, only: lightNode - use m_dbzNode , only: dbzNode - - use kinds, only: i_kind - use m_obsNode, only: obsNode - use mpeu_util, only: perr,die - - implicit none - private ! except - - public:: obsNodeType_undef - public:: obsNodeType_lbound - public:: obsNodeType_ubound - public:: obsNodeType_count - - public:: iobsNode_kind - public:: iobsNode_ps - public:: iobsNode_t - public:: iobsNode_w - public:: iobsNode_q - public:: iobsNode_spd - public:: iobsNode_rw - public:: iobsNode_dw - public:: iobsNode_sst - public:: iobsNode_pw - public:: iobsNode_pcp - public:: iobsNode_oz - public:: iobsNode_o3l - public:: iobsNode_gps - public:: iobsNode_rad - public:: iobsNode_tcp - public:: iobsNode_lag - public:: iobsNode_colvk - public:: iobsNode_aero - public:: iobsNode_aerol - public:: iobsNode_pm2_5 - public:: iobsNode_gust - public:: iobsNode_vis - public:: iobsNode_pblh - public:: iobsNode_wspd10m - public:: iobsNode_uwnd10m - public:: iobsNode_vwnd10m - public:: iobsNode_td2m - public:: iobsNode_mxtm - public:: iobsNode_mitm - public:: iobsNode_pmsl - public:: iobsNode_howv - public:: iobsNode_tcamt - public:: iobsNode_lcbas - public:: iobsNode_pm10 - public:: iobsNode_cldch - public:: iobsNode_swcp - public:: iobsNode_lwcp - - public:: iobsNode_light - public:: iobsNode_dbz - - public :: obsNode_typeMold - public :: obsNode_typeIndex - - interface obsNode_typeMold; module procedure & - index2vmold_, & - vname2vmold_ - end interface - interface obsNode_typeIndex; module procedure & - vmold2index_, & - vname2index_ - end interface - - type(psNode ), target, save:: ps_mold - type(tNode ), target, save:: t_mold - type(wNode ), target, save:: w_mold - type(qNode ), target, save:: q_mold - type(spdNode ), target, save:: spd_mold - type(rwNode ), target, save:: rw_mold - type(dwNode ), target, save:: dw_mold - type(sstNode ), target, save:: sst_mold - type(pwNode ), target, save:: pw_mold - type(pcpNode ), target, save:: pcp_mold - type(ozNode ), target, save:: oz_mold - type(o3lNode ), target, save:: o3l_mold - type(gpsNode ), target, save:: gps_mold - type(radNode ), target, save:: rad_mold - type(tcpNode ), target, save:: tcp_mold - type(lagNode ), target, save:: lag_mold - type(colvkNode), target, save:: colvk_mold - type(aeroNode ), target, save:: aero_mold - type(aerolNode), target, save:: aerol_mold - type(pm2_5Node), target, save:: pm2_5_mold - type(gustNode ), target, save:: gust_mold - type(visNode ), target, save:: vis_mold - type(pblhNode ), target, save:: pblh_mold - - type(wspd10mNode), target, save:: wspd10m_mold - type(uwnd10mNode), target, save:: uwnd10m_mold - type(vwnd10mNode), target, save:: vwnd10m_mold - - type( td2mNode), target, save:: td2m_mold - type( mxtmNode), target, save:: mxtm_mold - type( mitmNode), target, save:: mitm_mold - type( pmslNode), target, save:: pmsl_mold - type( howvNode), target, save:: howv_mold - type( tcamtNode), target, save:: tcamt_mold - type( lcbasNode), target, save:: lcbas_mold - type( pm10Node), target, save:: pm10_mold - type( cldchNode), target, save:: cldch_mold - - type( swcpNode), target, save:: swcp_mold - type( lwcpNode), target, save:: lwcp_mold - type( lightNode), target, save:: light_mold - type( dbzNode), target, save:: dbz_mold -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='m_obsNodeTypeManager' - -! UseCase 1: configuration of a single mold -! -! use m_obsNodeTypeManager, only: obsNode_typeMold -! use m_psNode, only: i_psNode -! ... -! allocate(psLList%mold, source=obsNode_typeMold(i_psNode)) -! or, for Fortran 2008 ALLOCATE() with MOLD= specifier -! allocate(psLList%mold, mold=obsNode_typeMold(i_psNode)) -! -! UseCase 2: configuration of molds in an array -! -! use m_obsLList, only: obsLList_moldConfig -! use m_obsNodeTypeManager, only: obsNode_typeMold -! ... -! do jtype=lbound(obsdiags,2),ubound(obsdiags,2) -! do ibin=lbound(obsdiags,1),ubound(obsdiags,1) -! call obsLList_moldConfig(obsdiags(ibin,jtype),mold=obsNode_typeMold(jtype)) -! enddo -! enddo -! - - enum, bind(C) - enumerator:: iobsNode_zero_ = 0 - - enumerator:: iobsNode_ps - enumerator:: iobsNode_t - enumerator:: iobsNode_w - enumerator:: iobsNode_q - enumerator:: iobsNode_spd - enumerator:: iobsNode_rw - enumerator:: iobsNode_dw - enumerator:: iobsNode_sst - enumerator:: iobsNode_pw - enumerator:: iobsNode_pcp - enumerator:: iobsNode_oz - enumerator:: iobsNode_o3l - enumerator:: iobsNode_gps - enumerator:: iobsNode_rad - enumerator:: iobsNode_tcp - enumerator:: iobsNode_lag - enumerator:: iobsNode_colvk - enumerator:: iobsNode_aero - enumerator:: iobsNode_aerol - enumerator:: iobsNode_pm2_5 - enumerator:: iobsNode_gust - enumerator:: iobsNode_vis - enumerator:: iobsNode_pblh - enumerator:: iobsNode_wspd10m - enumerator:: iobsNode_uwnd10m - enumerator:: iobsNode_vwnd10m - enumerator:: iobsNode_td2m - enumerator:: iobsNode_mxtm - enumerator:: iobsNode_mitm - enumerator:: iobsNode_pmsl - enumerator:: iobsNode_howv - enumerator:: iobsNode_tcamt - enumerator:: iobsNode_lcbas - enumerator:: iobsNode_pm10 - enumerator:: iobsNode_cldch - enumerator:: iobsNode_swcp - enumerator:: iobsNode_lwcp - enumerator:: iobsNode_light - enumerator:: iobsNode_dbz - - enumerator:: iobsNode_extra_ - end enum - - integer(i_kind),parameter:: iobsNode_kind = kind(iobsNode_zero_) - - integer(iobsNode_kind),parameter:: obsNodeType_undef = -1_iobsNode_kind - integer(iobsNode_kind),parameter:: obsNodeType_lbound = iobsNode_zero_ +1 - integer(iobsNode_kind),parameter:: obsNodeType_ubound = iobsNode_extra_-1 - integer(iobsNode_kind),parameter:: obsNodeType_count = obsNodeType_ubound-obsNodeType_lbound+1 - -contains -function vname2index_(vname) result(index_) - use mpeu_util, only: lowercase - implicit none - integer(i_kind):: index_ - character(len=*),intent(in):: vname - character(len=len(vname)):: vname_ - vname_=lowercase(vname) - - index_=0 ! a default return value, if the given name is unknown. - select case(vname_) - case("ps" , "[psnode]"); index_ = iobsNode_ps - case("t" , "[tnode]"); index_ = iobsNode_t - case("w" , "[wnode]"); index_ = iobsNode_w - case("q" , "[qnode]"); index_ = iobsNode_q - case("spd" , "[spdnode]"); index_ = iobsNode_spd - case("rw" , "[rwnode]"); index_ = iobsNode_rw - case("dw" , "[dwnode]"); index_ = iobsNode_dw - case("sst" , "[sstnode]"); index_ = iobsNode_sst - case("pw" , "[pwnode]"); index_ = iobsNode_pw - case("pcp" , "[pcpnode]"); index_ = iobsNode_pcp - case("oz" , "[oznode]"); index_ = iobsNode_oz - case("o3l" , "[o3lnode]"); index_ = iobsNode_o3l - case("gps" , "[gpsnode]"); index_ = iobsNode_gps - case("rad" , "[radnode]"); index_ = iobsNode_rad - case("tcp" , "[tcpnode]"); index_ = iobsNode_tcp - case("lag" , "[lagnode]"); index_ = iobsNode_lag - case("colvk","[colvknode]"); index_ = iobsNode_colvk - case("aero" , "[aeronode]"); index_ = iobsNode_aero - case("aerol","[aerolnode]"); index_ = iobsNode_aerol - case("pm2_5","[pm2_5node]"); index_ = iobsNode_pm2_5 - case("gust" , "[gustnode]"); index_ = iobsNode_gust - case("vis" , "[visnode]"); index_ = iobsNode_vis - case("pblh" , "[pblhnode]"); index_ = iobsNode_pblh - - case("wspd10m", & - "[wspd10mnode]"); index_ = iobsNode_wspd10m - case("uwnd10m", & - "[uwnd10mnode]"); index_ = iobsNode_uwnd10m - case("vwnd10m", & - "[vwnd10mnode]"); index_ = iobsNode_vwnd10m - - case("td2m" , "[td2mnode]"); index_ = iobsNode_td2m - case("mxtm" , "[mxtmnode]"); index_ = iobsNode_mxtm - case("mitm" , "[mitmnode]"); index_ = iobsNode_mitm - case("pmsl" , "[pmslnode]"); index_ = iobsNode_pmsl - case("howv" , "[howvnode]"); index_ = iobsNode_howv - case("tcamt","[tcamtnode]"); index_ = iobsNode_tcamt - case("lcbas","[lcbasnode]"); index_ = iobsNode_lcbas - - case("pm10" , "[pm10node]"); index_ = iobsNode_pm10 - case("cldch","[cldchnode]"); index_ = iobsNode_cldch - - case("swcp" , "[swcpnode]"); index_ = iobsNode_swcp - case("lwcp" , "[lwcpnode]"); index_ = iobsNode_lwcp - - case("light","[lightnode]"); index_ = iobsNode_light - case("dbz" , "[dbznode]"); index_ = iobsNode_dbz - - end select -end function vname2index_ - -function vmold2index_(mold) result(index_) - implicit none - integer(i_kind):: index_ - class(obsNode),target,intent(in):: mold - - index_=vname2index_(mold%mytype()) -end function vmold2index_ - -function vmold2index_select_(mold) result(index_) - implicit none - integer(i_kind):: index_ - class(obsNode),target,intent(in):: mold - - index_=0 - select type(mold) - type is( psNode); index_ = iobsNode_ps - type is( tNode); index_ = iobsNode_t - type is( wNode); index_ = iobsNode_w - type is( qNode); index_ = iobsNode_q - type is( spdNode); index_ = iobsNode_spd - type is( rwNode); index_ = iobsNode_rw - type is( dwNode); index_ = iobsNode_dw - type is( sstNode); index_ = iobsNode_sst - type is( pwNode); index_ = iobsNode_pw - type is( pcpNode); index_ = iobsNode_pcp - type is( ozNode); index_ = iobsNode_oz - type is( o3lNode); index_ = iobsNode_o3l - type is( gpsNode); index_ = iobsNode_gps - type is( radNode); index_ = iobsNode_rad - type is( tcpNode); index_ = iobsNode_tcp - type is( lagNode); index_ = iobsNode_lag - type is(colvkNode); index_ = iobsNode_colvk - type is( aeroNode); index_ = iobsNode_aero - type is(aerolNode); index_ = iobsNode_aerol - type is(pm2_5Node); index_ = iobsNode_pm2_5 - type is( gustNode); index_ = iobsNode_gust - type is( visNode); index_ = iobsNode_vis - type is( pblhNode); index_ = iobsNode_pblh - - type is(wspd10mNode); index_ = iobsNode_wspd10m - type is(uwnd10mNode); index_ = iobsNode_uwnd10m - type is(vwnd10mNode); index_ = iobsNode_vwnd10m - - type is( td2mNode); index_ = iobsNode_td2m - type is( mxtmNode); index_ = iobsNode_mxtm - type is( mitmNode); index_ = iobsNode_mitm - type is( pmslNode); index_ = iobsNode_pmsl - type is( howvNode); index_ = iobsNode_howv - type is(tcamtNode); index_ = iobsNode_tcamt - type is(lcbasNode); index_ = iobsNode_lcbas - - type is( pm10Node); index_ = iobsNode_pm10 - type is(cldchNode); index_ = iobsNode_cldch - - type is( swcpNode); index_ = iobsNode_swcp - type is( lwcpNode); index_ = iobsNode_lwcp - - type is(lightNode); index_ = iobsNode_light - type is( dbzNode); index_ = iobsNode_dbz - - end select -end function vmold2index_select_ - -function index2vmold_(i_obType) result(obsmold_) - implicit none - class(obsNode),pointer:: obsmold_ - integer(kind=i_kind),intent(in):: i_obType - - character(len=*),parameter:: myname_=myname//"::index2vmold_" - - obsmold_ => null() - select case(i_obType) - case(iobsNode_ps ); obsmold_ => ps_mold - case(iobsNode_t ); obsmold_ => t_mold - case(iobsNode_w ); obsmold_ => w_mold - case(iobsNode_q ); obsmold_ => q_mold - case(iobsNode_spd ); obsmold_ => spd_mold - case(iobsNode_rw ); obsmold_ => rw_mold - case(iobsNode_dw ); obsmold_ => dw_mold - case(iobsNode_sst ); obsmold_ => sst_mold - case(iobsNode_pw ); obsmold_ => pw_mold - case(iobsNode_pcp ); obsmold_ => pcp_mold - case(iobsNode_oz ); obsmold_ => oz_mold - case(iobsNode_o3l ); obsmold_ => o3l_mold - case(iobsNode_gps ); obsmold_ => gps_mold - case(iobsNode_rad ); obsmold_ => rad_mold - case(iobsNode_tcp ); obsmold_ => tcp_mold - case(iobsNode_lag ); obsmold_ => lag_mold - case(iobsNode_colvk); obsmold_ => colvk_mold - case(iobsNode_aero ); obsmold_ => aero_mold - case(iobsNode_aerol); obsmold_ => aerol_mold - case(iobsNode_pm2_5); obsmold_ => pm2_5_mold - case(iobsNode_gust ); obsmold_ => gust_mold - case(iobsNode_vis ); obsmold_ => vis_mold - case(iobsNode_pblh ); obsmold_ => pblh_mold - - case(iobsNode_wspd10m); obsmold_ => wspd10m_mold - case(iobsNode_uwnd10m); obsmold_ => uwnd10m_mold - case(iobsNode_vwnd10m); obsmold_ => vwnd10m_mold - - case(iobsNode_td2m ); obsmold_ => td2m_mold - case(iobsNode_mxtm ); obsmold_ => mxtm_mold - case(iobsNode_mitm ); obsmold_ => mitm_mold - case(iobsNode_pmsl ); obsmold_ => pmsl_mold - case(iobsNode_howv ); obsmold_ => howv_mold - case(iobsNode_tcamt); obsmold_ => tcamt_mold - case(iobsNode_lcbas); obsmold_ => lcbas_mold - - case(iobsNode_pm10 ); obsmold_ => pm10_mold - case(iobsNode_cldch); obsmold_ => cldch_mold - - case(iobsNode_swcp ); obsmold_ => swcp_mold - case(iobsNode_lwcp ); obsmold_ => lwcp_mold - - case(iobsNode_light); obsmold_ => light_mold - case(iobsNode_dbz); obsmold_ => dbz_mold - - end select -end function index2vmold_ - -function vname2vmold_(vname) result(obsmold_) - implicit none - class(obsNode),pointer:: obsmold_ - character(len=*),intent(in):: vname - - character(len=*),parameter:: myname_=myname//"::vname2vmold_" - integer(kind=i_kind):: i_obType - - i_obType=vname2index_(vname) - obsmold_ => index2vmold_(i_obType) -end function vname2vmold_ - -end module m_obsNodeTypeManager diff --git a/src/gsi/m_obsdiagNode.F90 b/src/gsi/m_obsdiagNode.F90 deleted file mode 100644 index 8d21b9721d..0000000000 --- a/src/gsi/m_obsdiagNode.F90 +++ /dev/null @@ -1,1591 +0,0 @@ -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 diff --git a/src/gsi/m_obsdiagnode.F90 b/src/gsi/m_obsdiagnode.F90 new file mode 100644 index 0000000000..8cfd0d4782 --- /dev/null +++ b/src/gsi/m_obsdiagnode.F90 @@ -0,0 +1,1591 @@ +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 diff --git a/src/gsi/m_obsdiags.F90 b/src/gsi/m_obsdiags.F90 index c95b998cd5..a54d242c84 100644 --- a/src/gsi/m_obsdiags.F90 +++ b/src/gsi/m_obsdiags.F90 @@ -11,26 +11,26 @@ module m_obsdiags ! program history log: ! 2015-02-04 j guo - Re-implemented read_obsdiags() and write_obsdiags(), ! to support reconfigurable observation operators. This -! implemenstation uses an obsLList template to support, +! implemenstation uses an obsllist template to support, ! in ceterian degree, static polymoprhism for different ! observation types. ! 2015-10-09 j guo - By using Fortran 2003 dynamic polymorphism, this -! version has removed many ugly type dispatching SELECT -! CASE constructs, by using an obsLList, a linked-list -! of dynamic polymorphic observation type (obsNode), -! which replaced the earlier obsLList template. -! 2016-06-22 j guo - Added latlonRange for selected file readings, to let +! version has removed many ugly type dispatching select +! case constructs, by using an obsllist, a linked-list +! of dynamic polymorphic observation type (obsnode), +! which replaced the earlier obsllist template. +! 2016-06-22 j guo - Added latlonrange for selected file readings, to let ! []_mread() to skip unnecessary read() of some files ! containing no relevant observations. -! . Added obsdiags_alwaysLocal, as a user controlable +! . Added obsdiags_alwayslocal, as a user controlable ! switch to allow or to bypass selected file readings. -! . Added CHECK_SIZES_ outputs to allow size checkings. -! . Added #define SHOW_LLRANGE, for text-dumping of latlonRanges. -! . Added #define DEBUG_obsdiags, for text-dumping +! . Added check_sizes_ outputs to allow size checkings. +! . Added #define show_llrange, for text-dumping of latlonranges. +! . Added #define debug_obsdiags, for text-dumping ! specific sections of obsdiags(:,:). -! . Locally renamed MPI_comm_world to gsi_comm_world. +! . locally renamed mpi_comm_world to gsi_comm_world. ! 2018-01-23 k apodaca - Add a new observation type i.e. lightning (light) -! suitable for the GOES/GLM instrument +! suitable for the goes/glm instrument ! ! input argument list: see Fortran 90 style document below ! @@ -48,85 +48,85 @@ module m_obsdiags use mpeu_util, only: tell,warn,perr,die use mpeu_util, only: assert_ use mpeu_util, only: stdout_open,stdout_close,stdout - use mpeu_mpif, only: gsi_comm_world => MPI_comm_world + use mpeu_mpif, only: gsi_comm_world => mpi_comm_world - use gsi_obOper, only: obOper + use gsi_oboper, only: oboper - use m_obsLList, only: obsLList - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags + use m_obsllist, only: obsllist + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags - use gsi_obOperTypeManager, only: nobs_type => obOper_count + use gsi_obopertypemanager, only: nobs_type => oboper_count use gsi_4dvar , only: nobs_bins !use obsmod, only: obsdiags ! (nobs_type,nobs_bins) implicit none private ! except - public:: obOpers_config - interface obOpers_config; module procedure config_; end interface + public:: obopers_config + interface obopers_config; module procedure config_; end interface - ! obOper instance creater with initialization to objects corresponding + ! oboper instance creater with initialization to objects corresponding ! linked-list data instances. - public:: obOper_create - public:: obOper_headNode - public:: obOper_destroy - interface obOper_create; module procedure & - createbydtype_, & - createbyindex_, & - createbyvmold_ - end interface - interface obOper_headNode; module procedure headnode_; end interface - interface obOper_destroy ; module procedure destroy_ ; end interface + public:: oboper_create + public:: oboper_headnode + public:: oboper_destroy + interface oboper_create; module procedure & + createbydtype_, & + createbyindex_, & + createbyvmold_ + end interface + interface oboper_headnode; module procedure headnode_; end interface + interface oboper_destroy ; module procedure destroy_ ; end interface public:: obsdiags_reset public:: obsdiags_write public:: obsdiags_read public:: obsdiags_sort - interface obsdiags_reset; module procedure reset_; end interface - interface obsdiags_write; module procedure write_; end interface - interface obsdiags_read ; module procedure mread_; end interface - interface obsdiags_sort ; module procedure lsort_; end interface + interface obsdiags_reset; module procedure reset_; end interface + interface obsdiags_write; module procedure write_; end interface + interface obsdiags_read ; module procedure mread_; end interface + interface obsdiags_sort ; module procedure lsort_; end interface public:: obsdiags_create public:: obsdiags_destroy public:: obsdiags_inquire - interface obsdiags_create ; module procedure create_obsmod_vars; end interface - interface obsdiags_destroy; module procedure destroy_obsmod_vars; end interface - interface obsdiags_inquire; module procedure inquire_obsdiags ; end interface + interface obsdiags_create ; module procedure create_obsmod_vars; end interface + interface obsdiags_destroy; module procedure destroy_obsmod_vars; end interface + interface obsdiags_inquire; module procedure inquire_obsdiags ; end interface public:: obsdiags_summary - interface obsdiags_summary ; module procedure summary_ ; end interface + interface obsdiags_summary ; module procedure summary_ ; end interface - public:: obsdiags_alwaysLocal - logical,save:: obsdiags_alwaysLocal = .false. + public:: obsdiags_alwayslocal + logical,save:: obsdiags_alwayslocal = .false. ! Note: User configurables ! -! (1) obsdiags_mread(..,mPEs,..) via /SETUP/:mPEs_observer: +! (1) obsdiags_mread(..,mpes,..) via /setup/:mpes_observer: ! -! mPEs==0, for reading "my own data"; -! mPEs=>0, reading "all data", from PE 0 to mPEs-1, but only up to the +! mpes==0, for reading "my own data"; +! mpes=>0, reading "all data", from pe 0 to mpes-1, but only up to the ! highest count of the actually accessible files. ! -! This value is configured through gsimod namelist/SETUP/:mPEs_observer, +! This value is configured through gsimod namelist/setup/:mpes_observer, ! with the default value set to 0, to behave as it was ("my own data"). -! Otherwise, a simple usage is to let mPEs_observer=1024, or other large +! Otherwise, a simple usage is to let mpes_observer=1024, or other large ! enough value, such that the solver-mode will try to determine how many ! files created by the observer-mode are actually there to read. ! -! (2) obsdiags_alwaysLocal via /SETUP/:alwaysLocal: +! (2) obsdiags_alwayslocal via /setup/:alwayslocal: ! -! obsdiags_alwaysLocal sets an alternative default value of the optional -! argument of obsdiags_mread(..,alwaysLocal). +! obsdiags_alwayslocal sets an alternative default value of the optional +! argument of obsdiags_mread(..,alwayslocal). ! -! obsdiags_alwaysLocal==.false., its default value. +! obsdiags_alwayslocal==.false., its default value. ! It let obsdiags_mread() to check the locality of a file first, -! using latlonRange_islocal(iPE), to avoid unnecessary opening+ +! using latlonrange_islocal(ipe), to avoid unnecessary opening+ ! reading some files. -! obsdiags_alwaysLocal==.true., override latlonRange_islocal(iPE). +! obsdiags_alwayslocal==.true., override latlonrange_islocal(ipe). ! It let obsdiags_mread() to always open+read all file. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -134,25 +134,25 @@ module m_obsdiags logical,save:: lobsdiags_allocated_ = .false. logical,save:: lobstypes_allocated_ = .false. - logical,parameter:: All_PEs =.false. ! report status on all PEs or root only - !logical,parameter:: All_PEs =.true. ! report status on all PEs or root only - logical,parameter:: DO_SUMMARY =.false. ! report status on all PEs or root only - !logical,parameter:: DO_SUMMARY =.true. ! report status on all PEs or root only + logical,parameter:: all_pes =.false. ! report status on all pes or root only + !logical,parameter:: all_pes =.true. ! report status on all pes or root only + logical,parameter:: do_summary =.false. ! report status on all pes or root only + !logical,parameter:: do_summary =.true. ! report status on all pes or root only - ! SYNCH_MESSAGES is a flag to invoke MPI_Barrier() calls before some + ! synch_messages is a flag to invoke mpi_barrier() calls before some ! status messages. These calls are otherwise not necessary for the ! functionalities, but used here to ensure those messages mean what they - ! intent to mean, in case that only the root PE is used to report some - ! all PE status. + ! intent to mean, in case that only the root pe is used to report some + ! all pe status. - !logical,parameter:: SYNCH_MESSAGES = .true. ! turn synch on - !logical,parameter:: SYNCH_MESSAGES = .not. All_PEs ! conditionally turn on - logical,parameter:: SYNCH_MESSAGES = .false. ! turn synch off + !logical,parameter:: synch_messages = .true. ! turn synch on + !logical,parameter:: synch_messages = .not. all_pes ! conditionally turn on + logical,parameter:: synch_messages = .false. ! turn synch off public :: obsdiags - public :: obsLLists + public :: obsllists - type(obsLList ),save,dimension(:,:),pointer :: obsLLists => null() + type(obsllist ),save,dimension(:,:),pointer :: obsllists => null() type(obs_diags),save,dimension(:,:),pointer :: obsdiags => null() ! (nobs_type,nobs_bins) integer(i_kind),save:: jfunc__jiter = -1 @@ -163,29 +163,29 @@ module m_obsdiags integer(i_kind),save:: gsi_4dvar__min_offset = -1 real (r_kind),save:: gsi_4dvar__hr_obsbin = -999._r_kind -!#define DEBUG_TRACE -!#define DEBUG_VERBOSE +!#define debug_trace +!#define debug_verbose #include "mytrace.H" #include "myassert.H" -#define _TIMER_ON_ -#ifdef _TIMER_ON_ -#undef _TIMER_ON_ -#undef _TIMER_OFF_ -#undef _TIMER_USE_ -#define _TIMER_ON_(id) call timer_ini(id) -#define _TIMER_OFF_(id) call timer_fnl(id) -#define _TIMER_USE_ use timermod, only: timer_ini,timer_fnl +#define _timer_on_ +#ifdef _timer_on_ +#undef _timer_on_ +#undef _timer_off_ +#undef _timer_use_ +#define _timer_on_(id) call timer_ini(id) +#define _timer_off_(id) call timer_fnl(id) +#define _timer_use_ use timermod, only: timer_ini,timer_fnl #else -#define _TIMER_ON_(id) -#define _TIMER_OFF_(id) -#define _TIMER_USE_ +#define _timer_on_(id) +#define _timer_off_(id) +#define _timer_use_ #endif - logical,parameter:: CHECK_SIZES_=.false. - !logical,parameter:: CHECK_SIZES_=.true. + logical,parameter:: check_sizes_=.false. + !logical,parameter:: check_sizes_=.true. - !-- if(CHECK_SIZES_) then + !-- if(check_sizes_) then !-- these size counters, integer(i_kind),allocatable,dimension(:),save:: lsize_type ! luse counts of ob_type @@ -195,235 +195,235 @@ module m_obsdiags integer(i_kind),allocatable,dimension(:),save:: nsize_diag ! total counts of obs_diags !-- will be used to generate extra log-information, reporting different - !-- size-counts of linked-lists, of all j-type, i-bin, on all PEs. Search - !-- "CHECK_SIZES_" here for details. + !-- size-counts of linked-lists, of all j-type, i-bin, on all pes. Search + !-- "check_sizes_" here for details. !-- endif contains subroutine config_() -!> Coupling external configurations (through external modules) to obOpers' own +!> Coupling external configurations (through external modules) to obopers' own !> module configurations implicit none -!> For all obOpers, import external configurations +!> For all obopers, import external configurations call jfunc__import_() call gsi_4dvar__import_() -!> For specific obOpers, import specific configurations - call lwcpOper__config_() +!> For specific obopers, import specific configurations + call lwcpoper__config_() -return + return contains subroutine jfunc__import_() - !> jfunc parameters imported - use jfunc, only: jiter - use jfunc, only: miter - use jfunc, only: jiterstart - implicit none - jfunc__jiter = jiter - jfunc__miter = miter - jfunc__jiterstart = jiterstart +!> jfunc parameters imported + use jfunc, only: jiter + use jfunc, only: miter + use jfunc, only: jiterstart + implicit none + jfunc__jiter = jiter + jfunc__miter = miter + jfunc__jiterstart = jiterstart return - end subroutine jfunc__import_ +end subroutine jfunc__import_ subroutine gsi_4dvar__import_() - !> gsi4dvar parameters imported - use gsi_4dvar, only: nobs_bins - use gsi_4dvar, only: min_offset - use gsi_4dvar, only: hr_obsbin - implicit none - gsi_4dvar__nobs_bins = nobs_bins - gsi_4dvar__min_offset = min_offset - gsi_4dvar__hr_obsbin = hr_obsbin +!> gsi4dvar parameters imported + use gsi_4dvar, only: nobs_bins + use gsi_4dvar, only: min_offset + use gsi_4dvar, only: hr_obsbin + implicit none + gsi_4dvar__nobs_bins = nobs_bins + gsi_4dvar__min_offset = min_offset + gsi_4dvar__hr_obsbin = hr_obsbin return - end subroutine gsi_4dvar__import_ -subroutine lwcpOper__config_() - !> gsi_lwcpOper parameters for configuration - !> gfs_stratosphere imports - use gfs_stratosphere, only: use_gfs_stratosphere - use gfs_stratosphere, only: nsig_save - !> lwcpOper - use gsi_lwcpOper , only: lwcpOper_config - implicit none +end subroutine gsi_4dvar__import_ +subroutine lwcpoper__config_() +!> gsi_lwcpoper parameters for configuration +!> gfs_stratosphere imports + use gfs_stratosphere, only: use_gfs_stratosphere + use gfs_stratosphere, only: nsig_save +!> lwcpoper + use gsi_lwcpoper , only: lwcpoper_config + implicit none - call lwcpOper_config() ! reset to default - !> From gfs_stratosphere to gsi_lwcpOper, and expected to be refactored into an attribute of profile-vectors objects) - if(use_gfs_stratosphere) call lwcpOper_config(nsig_save=nsig_save) + call lwcpoper_config() ! reset to default +!> From gfs_stratosphere to gsi_lwcpoper, and expected to be refactored into an attribute of profile-vectors objects) + if(use_gfs_stratosphere) call lwcpoper_config(nsig_save=nsig_save) return - end subroutine lwcpOper__config_ +end subroutine lwcpoper__config_ end subroutine config_ function createbydtype_(dtype) result(self) -!>> create an obOper to its components instanciated in this data module, with -!>> a given obOper registered dtype - use gsi_obOperTypeManager, only: obOper_typeMold ! (dtype) +!>> create an oboper to its components instanciated in this data module, with +!>> a given oboper registered dtype + use gsi_obopertypemanager, only: oboper_typemold ! (dtype) implicit none - class(obOper),pointer:: self + class(oboper),pointer:: self character(len=*),intent(in):: dtype character(len=*),parameter:: myname_=myname//"::createbydtype_" - self => createbyvmold_(obOper_typeMold(dtype)) + self => createbyvmold_(oboper_typemold(dtype)) -#ifdef DEBUG_VERBOSE +#ifdef debug_verbose ! show status of the object for debugging call tell(myname_,'--- argument dtype =',trim(dtype)) call tell(myname_,'associated(return) =',associated(self)) - !if(associated(self)) call obOper_show_(myname_,self) + !if(associated(self)) call oboper_show_(myname_,self) #endif end function createbydtype_ function createbyindex_(ioper) result(self) -!>> create an obOper to its components instanciated in this data module, with -!>> a given obOper registered index. - use gsi_obOperTypeManager, only: obOper_typeMold ! (ioper) - use gsi_obOperTypeManager, only: obOper_lbound - use gsi_obOperTypeManager, only: obOper_ubound +!>> create an oboper to its components instanciated in this data module, with +!>> a given oboper registered index. + use gsi_obopertypemanager, only: oboper_typemold ! (ioper) + use gsi_obopertypemanager, only: oboper_lbound + use gsi_obopertypemanager, only: oboper_ubound implicit none - class(obOper),pointer:: self + class(oboper),pointer:: self integer(kind=i_kind),intent(in):: ioper character(len=*),parameter:: myname_=myname//"::createbyindex_" - class(obOper),pointer:: mold_ + class(oboper),pointer:: mold_ - mold_ => obOper_typeMold(ioper) + mold_ => oboper_typemold(ioper) if(associated(mold_)) then - allocate(self,mold=mold_) - - if(ioperubound(obsLLists,1)) then - call perr(myname_,'unexpected value, ioper =',ioper) - call perr(myname_,' lbound(obsLLists,1) =',lbound(obsLLists,1)) - call perr(myname_,' ubound(obsLLists,1) =',ubound(obsLLists,1)) - call perr(myname_,' %mytype() =',self%mytype()) - call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) - call die(myname_) - endif - if(ioperubound( obsdiags,1)) then - call perr(myname_,'unexpected value, ioper =',ioper) - call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) - call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) - call perr(myname_,' %mytype() =',self%mytype()) - call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) - call die(myname_) - endif + allocate(self,mold=mold_) + + if(ioperubound(obsllists,1)) then + call perr(myname_,'unexpected value, ioper =',ioper) + call perr(myname_,' lbound(obsllists,1) =',lbound(obsllists,1)) + call perr(myname_,' ubound(obsllists,1) =',ubound(obsllists,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + if(ioperubound( obsdiags,1)) then + call perr(myname_,'unexpected value, ioper =',ioper) + call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) + call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif - call self%init(obsLLists(ioper,:), & - obsdiags(ioper,:) ) - mold_ => null() + call self%init(obsllists(ioper,:), & + obsdiags(ioper,:) ) + mold_ => null() else - call perr(myname_,'.not.associated, ioper =',ioper) - call die(myname_) + call perr(myname_,'.not.associated, ioper =',ioper) + call die(myname_) endif -#ifdef DEBUG_VERBOSE +#ifdef debug_verbose !>> show status of the object for debugging call tell(myname_,'--- argument ioper =',ioper) call tell(myname_,'associated(return) =',associated(self)) - !if(associated(self)) call obOper_show_(myname_,self) + !if(associated(self)) call oboper_show_(myname_,self) #endif end function createbyindex_ function createbyvmold_(mold) result(self) -!>> initialize an obOper to its components (linked-lists) - use gsi_obOperTypeManager, only: obOper_typeIndex ! to type-index - use gsi_obOperTypeManager, only: obOper_typeIndex ! to type-index +!>> initialize an oboper to its components (linked-lists) + use gsi_obopertypemanager, only: oboper_typeindex ! to type-index + use gsi_obopertypemanager, only: oboper_typeindex ! to type-index implicit none - class(obOper),pointer:: self - class(obOper),target,intent(in):: mold + class(oboper),pointer:: self + class(oboper),target,intent(in):: mold character(len=*),parameter:: myname_=myname//"::createbyvmold_" - integer(kind=i_kind):: itype ! for a registered obsNode type index + integer(kind=i_kind):: itype ! for a registered obsnode type index self => mold if(associated(self)) then - allocate(self,mold=mold) - - ! Get its corresponding obsNode type name, then convert to its type-index - itype=obOper_typeIndex(self) - - if(itypeubound(obsLLists,1)) then - call perr(myname_,'unexpected value, itype =',itype) - call perr(myname_,' lbound(obsLLists,1) =',lbound(obsLLists,1)) - call perr(myname_,' ubound(obsLLists,1) =',ubound(obsLLists,1)) - call perr(myname_,' %mytype() =',self%mytype()) - call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) - call die(myname_) - endif - if(itypeubound( obsdiags,1)) then - call perr(myname_,'unexpected value, itype =',itype) - call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) - call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) - call perr(myname_,' %mytype() =',self%mytype()) - call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) - call die(myname_) - endif + allocate(self,mold=mold) + + ! Get its corresponding obsnode type name, then convert to its type-index + itype=oboper_typeindex(self) + + if(itypeubound(obsllists,1)) then + call perr(myname_,'unexpected value, itype =',itype) + call perr(myname_,' lbound(obsllists,1) =',lbound(obsllists,1)) + call perr(myname_,' ubound(obsllists,1) =',ubound(obsllists,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif + if(itypeubound( obsdiags,1)) then + call perr(myname_,'unexpected value, itype =',itype) + call perr(myname_,' lbound( obsdiags,1) =',lbound( obsdiags,1)) + call perr(myname_,' ubound( obsdiags,1) =',ubound( obsdiags,1)) + call perr(myname_,' %mytype() =',self%mytype()) + call perr(myname_,' %mytype(nodetype) =',self%mytype(nodetype=.true.)) + call die(myname_) + endif - call self%init(obsLLists(itype,:), & - obsdiags(itype,:) ) + call self%init(obsllists(itype,:), & + obsdiags(itype,:) ) endif -#ifdef DEBUG_VERBOSE +#ifdef debug_verbose ! show status of the object for debugging call tell(myname_,'--- argument mold%mytype() =',mold%mytype()) call tell(myname_,' mold%mytype(nodetype) =',mold%mytype(nodetype=.true.)) call tell(myname_,' associated(return) =',associated(self)) - if(associated(self)) call obOper_show_(myname_,self) + if(associated(self)) call oboper_show_(myname_,self) #endif end function createbyvmold_ subroutine oboper_show_(mname,self) - use gsi_obOper, only: obOper - use gsi_obOperTypeManager, only: obOper_typeIndex - use gsi_obOperTypeManager, only: obOper_typeInfo - use m_obsNodeTypeManager , only: obsNode_typeIndex ! to type-index + use gsi_oboper, only: oboper + use gsi_obopertypemanager, only: oboper_typeindex + use gsi_obopertypemanager, only: oboper_typeinfo + use m_obsnodetypemanager , only: obsnode_typeindex ! to type-index use mpeu_util, only: tell implicit none character(len=*),intent(in):: mname - class(obOper),target,intent(in):: self + class(oboper),target,intent(in):: self - call tell(mname,' obOper_typeIndex(%) =',obOper_typeIndex(self)) - call tell(mname,' obOper_typeInfo(%) =',obOper_typeInfo(self)) - call tell(mname,' associated(%obsLL) =',associated(self%obsLL)) - call tell(mname,'associated(%odiagLL) =',associated(self%odiagLL)) + call tell(mname,' oboper_typeindex(%) =',oboper_typeindex(self)) + call tell(mname,' oboper_typeinfo(%) =',oboper_typeinfo(self)) + call tell(mname,' associated(%obsll) =',associated(self%obsll)) + call tell(mname,'associated(%odiagll) =',associated(self%odiagll)) call tell(mname,' self%nodetype() =', self%mytype(nodetype=.true.)) -end subroutine obOper_show_ +end subroutine oboper_show_ subroutine destroy_(self) implicit none - class(obOper),pointer,intent(inout):: self + class(oboper),pointer,intent(inout):: self if(associated(self)) then - call self%clean() - deallocate(self) + call self%clean() + deallocate(self) endif end subroutine destroy_ -function headNode_(iobOper,ibin) result(anode) -!>> Example: -- get the head node of an obOper%obsLL(ibin) -!>> psptr => psNode_typecast(headNode(iobOper_ps)) - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode - use gsi_obOper, only: obOper +function headnode_(ioboper,ibin) result(anode) +!>> Example: -- get the head node of an oboper%obsll(ibin) +!>> psptr => psnode_typecast(headnode(ioboper_ps)) + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode + use gsi_oboper, only: oboper implicit none - integer(kind=i_kind),intent(in):: iobOper + integer(kind=i_kind),intent(in):: ioboper integer(kind=i_kind),intent(in):: ibin - class(obsNode),pointer:: anode + class(obsnode),pointer:: anode - character(len=*),parameter:: myname_=myname//"::headNode_" - class(obOper),pointer:: obOper_ + character(len=*),parameter:: myname_=myname//"::headnode_" + class(oboper),pointer:: oboper_ - obOper_ => createbyindex_(iobOper) - if(.not.associated(obOper_)) then - call perr(myname_,'createbuindex_(), associated(obOper_) =',associated(obOper_)) - call perr(myname_,' ioper =',iobOper) - call perr(myname_,' ibin =',ibin) - call die(myname_) - endif + oboper_ => createbyindex_(ioboper) + if(.not.associated(oboper_)) then + call perr(myname_,'createbuindex_(), associated(oboper_) =',associated(oboper_)) + call perr(myname_,' ioper =',ioboper) + call perr(myname_,' ibin =',ibin) + call die(myname_) + endif - anode => obsLList_headNode(obOper_%obsLL(ibin)) - call destroy_(obOper_) -end function headNode_ + anode => obsllist_headnode(oboper_%obsll(ibin)) + call destroy_(oboper_) +end function headnode_ -subroutine lobsdiags_statusCheck_(who,allocated) +subroutine lobsdiags_statuscheck_(who,allocated) !-- check the allocation status of basic obsdiags components. use obsmod, only: luse_obsdiag implicit none @@ -432,24 +432,24 @@ subroutine lobsdiags_statusCheck_(who,allocated) if(.not.luse_obsdiag) return if(allocated) then - if( .not.lobsdiags_allocated_ .or. & - .not.lobstypes_allocated_ ) then - if(.not.lobsdiags_allocated_) call perr(who,'.not.lobsdiags_allocated_') - if(.not.lobstypes_allocated_) call perr(who,'.not.lobstypes_allocated_') - call die(who) - endif + if( .not.lobsdiags_allocated_ .or. & + .not.lobstypes_allocated_ ) then + if(.not.lobsdiags_allocated_) call perr(who,'.not.lobsdiags_allocated_') + if(.not.lobstypes_allocated_) call perr(who,'.not.lobstypes_allocated_') + call die(who) + endif else - if( lobsdiags_allocated_ .or. & - lobstypes_allocated_ ) then - if(lobsdiags_allocated_) call perr(who,'lobsdiags_allocated_ already') - if(lobstypes_allocated_) call perr(who,'lobstypes_allocated_ already') - call die(who) - endif + if( lobsdiags_allocated_ .or. & + lobstypes_allocated_ ) then + if(lobsdiags_allocated_) call perr(who,'lobsdiags_allocated_ already') + if(lobstypes_allocated_) call perr(who,'lobstypes_allocated_ already') + call die(who) + endif endif -end subroutine lobsdiags_statusCheck_ +end subroutine lobsdiags_statuscheck_ -subroutine mread_(cdfile,mPEs,force,jiter_expected,alwaysLocal) +subroutine mread_(cdfile,mpes,force,jiter_expected,alwayslocal) !$$$ subprogram documentation block ! . . . . ! subprogram: m_obdiags::mread_ @@ -486,195 +486,195 @@ subroutine mread_(cdfile,mPEs,force,jiter_expected,alwaysLocal) !$$$ end documentation block use mpeu_util, only: tell,perr,die,stdout_open,stdout_close,stdout - _TIMER_USE_ + _timer_use_ use kinds, only: r_kind,i_kind use obsmod, only: lobserver - use mpimod, only: myPE - use m_latlonRange, only: latlonRange - use m_latlonRange, only: latlonRange_reset - use m_latlonRange, only: latlonRange_islocal - use m_latlonRange, only: latlonRange_readBcast - use m_latlonRange, only: latlonRange_allDump - - use m_obsdiagNode, only: obsdiagLList_dump + use mpimod, only: mype + use m_latlonrange, only: latlonrange + use m_latlonrange, only: latlonrange_reset + use m_latlonrange, only: latlonrange_islocal + use m_latlonrange, only: latlonrange_readbcast + use m_latlonrange, only: latlonrange_alldump + + use m_obsdiagnode, only: obsdiagllist_dump implicit none character(len=*), intent(in) :: cdfile ! prefix, "obsdiags." - integer(i_kind),optional,intent(in):: mPEs ! number of files, from 0 to mPEs-1 + integer(i_kind),optional,intent(in):: mpes ! number of files, from 0 to mpes-1 logical ,optional,intent(in):: force ! force to read ob_types, regardless l4dvar etc. integer(i_kind),optional,intent(in):: jiter_expected ! expected input jiter - logical ,optional,intent(in):: alwaysLocal ! read all files + logical ,optional,intent(in):: alwayslocal ! read all files ! ---------------------------------------------------------- character(len=*),parameter:: myname_=myname//"::mread_" logical:: redistr,exist_ - integer(i_kind):: lPE,uPE,iPE,ier + integer(i_kind):: lpe,upe,ipe,ier integer(i_kind):: jtyp,jread logical:: force_read - logical:: alwaysLocal_ + logical:: alwayslocal_ logical:: fileislocal - type(latlonRange),allocatable,dimension(:):: allRanges + type(latlonrange),allocatable,dimension(:):: allranges _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) !call stdout_open("obsdiags_mread") force_read=.false. if(present(force)) force_read=force - alwaysLocal_=obsdiags_alwaysLocal - if(present(alwaysLocal)) alwaysLocal_=alwaysLocal + alwayslocal_=obsdiags_alwayslocal + if(present(alwayslocal)) alwayslocal_=alwayslocal - call lobsdiags_statusCheck_(myname_,allocated=.true.) + call lobsdiags_statuscheck_(myname_,allocated=.true.) ! Determine the configuration, either read-my-own-data-only, or ! try-to-read-all-data-available. - lPE=myPE - uPE=lPE + lpe=mype + upe=lpe redistr=.false. - if(present(mPEs)) then - if(mPEs>0) then - redistr=.true. - lPE=0 - uPE=-1 - do iPE=lPE,mPEs-1 - inquire(file=trim(filename_(cdfile,iPE)), exist=exist_) - if(exist_) uPE=iPE - enddo - endif + if(present(mpes)) then + if(mpes>0) then + redistr=.true. + lpe=0 + upe=-1 + do ipe=lpe,mpes-1 + inquire(file=trim(filename_(cdfile,ipe)), exist=exist_) + if(exist_) upe=ipe + enddo + endif endif ! Reset components of obsdiags, for their re-construction from files call reset_() - if(CHECK_SIZES_) then - allocate(lsize_type(nobs_type)) - allocate(nsize_type(nobs_type)) - allocate(lsize_diag(nobs_type)) - allocate(nsize_diag(nobs_type)) - allocate(msize_diag(nobs_type)) - - lsize_type(:)=0 - nsize_type(:)=0 - lsize_diag(:)=0 - nsize_diag(:)=0 - msize_diag(:)=0 + if(check_sizes_) then + allocate(lsize_type(nobs_type)) + allocate(nsize_type(nobs_type)) + allocate(lsize_diag(nobs_type)) + allocate(nsize_diag(nobs_type)) + allocate(msize_diag(nobs_type)) + + lsize_type(:)=0 + nsize_type(:)=0 + lsize_diag(:)=0 + nsize_diag(:)=0 + msize_diag(:)=0 endif - ! MPI_Barrier() calls are not necessary. They are used here to ensure + ! mpi_barrier() calls are not necessary. They are used here to ensure ! the log-messages mean what they really mean, if only the root is used to - ! report the all-PE status. + ! report the all-pe status. - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) + if(synch_messages) call mpi_barrier(gsi_comm_world,ier) if(redistr) then - if(mype==0) then - call tell(myname_,'Reading obsdiags files for redistribution, nPEs =',uPE-lPE+1) - call tell(myname_,' prefix of the files, cdfile =',trim(cdfile)) - call tell(myname_,' lPE =',lPE) - call tell(myname_,' uPE =',uPE) - call tell(myname_,' alwaysLocal =',alwaysLocal_) - endif - - allocate(allRanges(0:uPE)) - call latlonRange_reset(allRanges) - call latlonRange_readBcast(hdfilename_(cdfile),allRanges,root=0,comm=gsi_comm_world) - -!#define SHOW_LLRANGE -#ifdef SHOW_LLRANGE - call latlonRange_alldump(allRanges,"obsLLRange") + if(mype==0) then + call tell(myname_,'Reading obsdiags files for redistribution, npes =',upe-lpe+1) + call tell(myname_,' prefix of the files, cdfile =',trim(cdfile)) + call tell(myname_,' lpe =',lpe) + call tell(myname_,' upe =',upe) + call tell(myname_,' alwayslocal =',alwayslocal_) + endif + + allocate(allranges(0:upe)) + call latlonrange_reset(allranges) + call latlonrange_readbcast(hdfilename_(cdfile),allranges,root=0,comm=gsi_comm_world) + +!#define show_llrange +#ifdef show_llrange + call latlonrange_alldump(allranges,"obsllrange") #endif - jread=-1 ! checker of the input jiter values - do iPE=lPE,uPE - fileislocal=latlonRange_islocal(allRanges(iPE)) - if(alwaysLocal_.or.fileislocal) then - call read_(cdfile,iPE,redistr,fileislocal=fileislocal, & - force=force, & - jiter_expected=jiter_expected, & - verbose=.not.alwaysLocal_.or.myPE==0, & - jread=jread) - endif - enddo - -!#define DEBUG_obsdiags -#ifdef DEBUG_obsdiags + jread=-1 ! checker of the input jiter values + do ipe=lpe,upe + fileislocal=latlonrange_islocal(allranges(ipe)) + if(alwayslocal_.or.fileislocal) then + call read_(cdfile,ipe,redistr,fileislocal=fileislocal, & + force=force, & + jiter_expected=jiter_expected, & + verbose=.not.alwayslocal_.or.mype==0, & + jread=jread) + endif + enddo + +!#define debug_obsdiags +#ifdef debug_obsdiags ! This is an example of dumping information for debugging, on selected - ! PEs, for specific jtyp and ibin. + ! pes, for specific jtyp and ibin. ! - ! This example is on PE #1, for (jtype==3 .and. ibin==3). - - if(myPE==1) then - call tell(myname_) - call tell(myname_,'dumping obsdiags(), jtyp =',3) - call tell(myname_,' ibin =',3) - call tell(myname_,' jread =',jread) - call obsdiagLList_dump(obsdiags(3,3),jiter=jread) - endif + ! This example is on pe #1, for (jtype==3 .and. ibin==3). + + if(mype==1) then + call tell(myname_) + call tell(myname_,'dumping obsdiags(), jtyp =',3) + call tell(myname_,' ibin =',3) + call tell(myname_,' jread =',jread) + call obsdiagllist_dump(obsdiags(3,3),jiter=jread) + endif #endif ! Sort to ensure the ordering is unique. - call lsort_() + call lsort_() - call latlonRange_reset(allRanges) - deallocate(allRanges) + call latlonrange_reset(allranges) + deallocate(allranges) else ! of if(redistr) - call read_(cdfile,myPE,redistr,fileislocal=.true., & - force=force, & - jiter_expected=jiter_expected, & - verbose=.true.) + call read_(cdfile,mype,redistr,fileislocal=.true., & + force=force, & + jiter_expected=jiter_expected, & + verbose=.true.) endif ! of if(redistr) - if(myPE==0) then - call tell(myname_,'Finished reading of all obsdiags files, nPEs =',uPE-lPE+1) + if(mype==0) then + call tell(myname_,'Finished reading of all obsdiags files, npes =',upe-lpe+1) endif - if(CHECK_SIZES_) then - do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) - if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & - lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then - write(stdout,'(i5.3,i5,7x,5i8,2x,l1)') myPE,jtyp ,lsize_type(jtyp),nsize_type(jtyp), & - msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) - endif - enddo - - call iMPI_reduceSUM_(lsize_type,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(nsize_type,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(lsize_diag,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(nsize_diag,root=0,comm=gsi_comm_world) - call iMPI_reduceSUM_(msize_diag,root=0,comm=gsi_comm_world) - - if(myPE==0) then - do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) + if(check_sizes_) then + do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then - write(stdout,'(2x,a,i5,7x,5i8,2x,l1)') '***',jtyp ,lsize_type(jtyp),nsize_type(jtyp), & - msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) + write(stdout,'(i5.3,i5,7x,5i8,2x,l1)') mype,jtyp ,lsize_type(jtyp),nsize_type(jtyp), & + msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) endif - enddo - endif - - deallocate(lsize_type) - deallocate(nsize_type) - deallocate(lsize_diag) - deallocate(nsize_diag) - deallocate(msize_diag) + enddo + + call impi_reducesum_(lsize_type,root=0,comm=gsi_comm_world) + call impi_reducesum_(nsize_type,root=0,comm=gsi_comm_world) + call impi_reducesum_(lsize_diag,root=0,comm=gsi_comm_world) + call impi_reducesum_(nsize_diag,root=0,comm=gsi_comm_world) + call impi_reducesum_(msize_diag,root=0,comm=gsi_comm_world) + + if(mype==0) then + do jtyp=lbound(lsize_type,1),ubound(lsize_type,1) + if( msize_diag(jtyp)>0.or.lsize_diag(jtyp)>0.or.nsize_diag(jtyp)>0 .or. & + lsize_type(jtyp)>0.or.nsize_type(jtyp)>0 ) then + write(stdout,'(2x,a,i5,7x,5i8,2x,l1)') '***',jtyp ,lsize_type(jtyp),nsize_type(jtyp), & + msize_diag(jtyp),lsize_diag(jtyp),nsize_diag(jtyp) + endif + enddo + endif + + deallocate(lsize_type) + deallocate(nsize_type) + deallocate(lsize_diag) + deallocate(nsize_diag) + deallocate(msize_diag) endif - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) - if(DO_SUMMARY) call summary_(myname_) + if(synch_messages) call mpi_barrier(gsi_comm_world,ier) + if(do_summary) call summary_(myname_) if(lobserver) then - if(.not.force_read) then - !call destroyobs( skipit=.true.) - call reset_(obsdiags_keep=.true.) - endif + if(.not.force_read) then + !call destroyobs( skipit=.true.) + call reset_(obsdiags_keep=.true.) + endif endif !call stdout_close() -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine mread_ subroutine reset_(obsdiags_keep) @@ -682,26 +682,26 @@ subroutine reset_(obsdiags_keep) use obsmod, only: luse_obsdiag use obsmod, only: lobsdiag_allocated - use m_obsdiagNode, only: obsdiagLList_reset - use m_obsdiagNode, only: obsdiagLList_rewind - use m_obsLList, only: obsLList_reset - use m_obsNode , only: obsNode - use gsi_obOperTypeManager, only: obOper_typeMold - use gsi_obOperTypeManager, only: obOper_lbound - use gsi_obOperTypeManager, only: obOper_ubound - use m_obsNodeTypeManager , only: obsNode_typeMold + use m_obsdiagnode, only: obsdiagllist_reset + use m_obsdiagnode, only: obsdiagllist_rewind + use m_obsllist, only: obsllist_reset + use m_obsnode , only: obsnode + use gsi_obopertypemanager, only: oboper_typemold + use gsi_obopertypemanager, only: oboper_lbound + use gsi_obopertypemanager, only: oboper_ubound + use m_obsnodetypemanager , only: obsnode_typemold - _TIMER_USE_ + _timer_use_ implicit none logical,optional,intent(in):: obsdiags_keep character(len=*),parameter:: myname_=myname//'::reset_' integer(i_kind):: ii,jj logical:: obsdiags_keep_ integer(i_kind):: ier - class(obsNode),pointer:: mNode_ - class(obOper ),pointer:: mOper_ + class(obsnode),pointer:: mnode_ + class(oboper ),pointer:: moper_ _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) _TRACEV_(myname_,'lobsdiag_allocated =',lobsdiag_allocated) _TRACEV_(myname_,'lobsdiags_allocated_ =',lobsdiags_allocated_) @@ -709,86 +709,86 @@ subroutine reset_(obsdiags_keep) ASSERT(nobs_type>0) ASSERT(nobs_bins>0) - ! Both objects, obsdiags and obsLLists are checked for their associated sizes + ! Both objects, obsdiags and obsllists are checked for their associated sizes ! and allocated shapes, regardless luse_obsdiag or not. This is to simplify ! the algorithm logic. The enforcements of (luse_obsdiag) are done on lower ! levels only. if(.not.lobstypes_allocated_) then - lobstypes_allocated_=.true. - if(.not.associated(obsLLists)) call die(myname_,'unexpectedly, .not.associated(obsLLists)') + lobstypes_allocated_=.true. + if(.not.associated(obsllists)) call die(myname_,'unexpectedly, .not.associated(obsllists)') endif if(.not.lobsdiags_allocated_) then - lobsdiags_allocated_=.true. - if(.not.associated(obsdiags )) call die(myname_,'unexpectedly, .not.associated(obsdiags)') + lobsdiags_allocated_=.true. + if(.not.associated(obsdiags )) call die(myname_,'unexpectedly, .not.associated(obsdiags)') endif - ASSERT(all(shape(obsdiags )==shape(obsLLists ))) - ASSERT( size(obsdiags,1)== size(obsLLists,1) ) - ASSERT( size(obsdiags,2)== size(obsLLists,2) ) + ASSERT(all(shape(obsdiags )==shape(obsllists ))) + ASSERT( size(obsdiags,1)== size(obsllists,1) ) + ASSERT( size(obsdiags,2)== size(obsllists,2) ) obsdiags_keep_=.false. if(present(obsdiags_keep)) obsdiags_keep_=obsdiags_keep - do ii=1,size(obsLLists,2) ! nobs_bins - do jj=1,size(obsLLists,1) ! nobs_type - if(luse_obsdiag) then - if(.not.obsdiags_keep_) then - call obsdiagLList_reset(obsdiags(jj,ii)) - lobsdiag_allocated=.false. - - else - call obsdiagLList_rewind(obsdiags(jj,ii)) - - ! In cases of rewinding without resetting, an obsdiagLList can - ! be either initialized (lobsdiag_allocated), or not initialized - ! (.not.lobsdiag_allocated). So the code here should not try - ! to alter the value of lobsdiag_allocated. + do ii=1,size(obsllists,2) ! nobs_bins + do jj=1,size(obsllists,1) ! nobs_type + if(luse_obsdiag) then + if(.not.obsdiags_keep_) then + call obsdiagllist_reset(obsdiags(jj,ii)) + lobsdiag_allocated=.false. + + else + call obsdiagllist_rewind(obsdiags(jj,ii)) + + ! In cases of rewinding without resetting, an obsdiagllist can + ! be either initialized (lobsdiag_allocated), or not initialized + ! (.not.lobsdiag_allocated). So the code here should not try + ! to alter the value of lobsdiag_allocated. + endif endif - endif !++++ - mOper_ => obOper_typeMold(jj) - if(.not.associated(mOper_)) then - call perr(myname_,'obOper_typeMold(j) not associated, j =',jj) - call perr(myname_,' obOper_lbound =',obOper_lbound) - call perr(myname_,' obOper_ubound =',obOper_ubound) - call die(myname_) + moper_ => oboper_typemold(jj) + if(.not.associated(moper_)) then + call perr(myname_,'oboper_typemold(j) not associated, j =',jj) + call perr(myname_,' oboper_lbound =',oboper_lbound) + call perr(myname_,' oboper_ubound =',oboper_ubound) + call die(myname_) endif - mNode_ => mOper_%nodeMold() - if(.not.associated(mNode_)) then - call perr(myname_,'mOper_%nodeMold() not associated, j =',jj) - call perr(myname_,' mOper_%mytype() =',mOper_%mytype()) - call die(myname_) + mnode_ => moper_%nodemold() + if(.not.associated(mnode_)) then + call perr(myname_,'moper_%nodemold() not associated, j =',jj) + call perr(myname_,' moper_%mytype() =',moper_%mytype()) + call die(myname_) endif - mOper_ => null() + moper_ => null() !++++ - call obsLList_reset(obsLLists(jj,ii),mold=mNode_, stat=ier) + call obsllist_reset(obsllists(jj,ii),mold=mnode_, stat=ier) if(ier/=0) then - call perr(myname_,'call obsLList_reset(), stat =',ier) - call perr(myname_,' ibin =',ii) - call perr(myname_,' jtype =',jj) - call perr(myname_,' mold%mytype() =',mNode_%mytype()) - call die(myname_) + call perr(myname_,'call obsllist_reset(), stat =',ier) + call perr(myname_,' ibin =',ii) + call perr(myname_,' jtype =',jj) + call perr(myname_,' mold%mytype() =',mnode_%mytype()) + call die(myname_) endif - mNode_ => null() - enddo + mnode_ => null() + enddo enddo -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine reset_ subroutine lsort_() !$$$ subprogram documentation block ! -! abstract: sort entries of obsdiags(:,:) and obsLLists(:,:) +! abstract: sort entries of obsdiags(:,:) and obsllists(:,:) ! ! program history log: ! @@ -799,51 +799,51 @@ subroutine lsort_() use gsi_unformatted, only: unformatted_open use obsmod, only: luse_obsdiag - use m_obsLList, only: obsLList_lsort - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_lsort + use m_obsllist, only: obsllist_lsort + use m_obsdiagnode, only: obsdiagllist_lsize + use m_obsdiagnode, only: obsdiagllist_lsort - _TIMER_USE_ + _timer_use_ implicit none character(len=*), parameter :: myname_=myname//"::lsort_" integer(i_kind) :: ii,jj !,iobs,lobs,ierr _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) ! ---------------------------------------------------------- - call lobsdiags_statusCheck_(myname_,allocated=.true.) + call lobsdiags_statuscheck_(myname_,allocated=.true.) if (luse_obsdiag) then - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) + ASSERT(all(shape(obsdiags)==shape(obsllists))) + ASSERT(size(obsdiags,1)==size(obsllists,1)) + ASSERT(size(obsdiags,2)==size(obsllists,2)) endif do jj=1,size(obsdiags,1) do ii=1,size(obsdiags,2) - call obsdiagLList_lsort(obsdiags(jj,ii),itype=jj,ibin=ii) + call obsdiagllist_lsort(obsdiags(jj,ii),itype=jj,ibin=ii) enddo enddo - do jj=1,size(obsLLists,1) - do ii=1,size(obsLLists,2) - call obsLList_lsort(obsLLists(jj,ii),itype=jj,ibin=ii) + do jj=1,size(obsllists,1) + do ii=1,size(obsllists,2) + call obsllist_lsort(obsllists(jj,ii),itype=jj,ibin=ii) enddo enddo ! ---------------------------------------------------------- -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine lsort_ subroutine write_(cdfile,luseonly,force) !$$$ subprogram documentation block ! -! abstract: Write obsdiags data structure to file. +! abstract: write obsdiags data structure to file. ! ! program history log: ! 2007-07-05 tremolet @@ -863,22 +863,22 @@ subroutine write_(cdfile,luseonly,force) ! !$$$ -use mpeu_util, only: tell,die,perr,stdout_open,stdout_close -_TIMER_USE_ + use mpeu_util, only: tell,die,perr,stdout_open,stdout_close +_timer_use_ use gsi_unformatted, only: unformatted_open use mpimod, only: mype use gsi_4dvar, only: l4dvar use jfunc, only: jiter, miter - use m_obsLList, only: obsLList_write - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_write + use m_obsllist, only: obsllist_write + use m_obsdiagnode, only: obsdiagllist_lsize + use m_obsdiagnode, only: obsdiagllist_write - use m_latlonRange, only: latlonRange - use m_latlonRange, only: latlonRange_reset - use m_latlonRange, only: latlonRange_gatherWrite - use m_latlonRange, only: latlonRange_gatherDump + use m_latlonrange, only: latlonrange + use m_latlonrange, only: latlonrange_reset + use m_latlonrange, only: latlonrange_gatherwrite + use m_latlonrange, only: latlonrange_gatherdump implicit none character(len=*), intent(in) :: cdfile ! := "obsdiags." @@ -887,102 +887,102 @@ subroutine write_(cdfile,luseonly,force) character(len=*), parameter :: myname_=myname//"::write_" -integer(i_kind) :: iunit,istat -integer(i_kind) :: ii,jj,ier -logical :: luseonly_ -logical :: force_write -type(latlonRange):: luseRange + integer(i_kind) :: iunit,istat + integer(i_kind) :: ii,jj,ier + logical :: luseonly_ + logical :: force_write + type(latlonrange):: luserange ! ---------------------------------------------------------- _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) !call stdout_open("obsdiags_write") force_write=.false. if(present(force)) force_write=force - call lobsdiags_statusCheck_(myname_,allocated=.true.) + call lobsdiags_statuscheck_(myname_,allocated=.true.) - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) + ASSERT(all(shape(obsdiags)==shape(obsllists))) + ASSERT(size(obsdiags,1)==size(obsllists,1)) + ASSERT(size(obsdiags,2)==size(obsllists,2)) luseonly_=.false. if(present(luseonly)) luseonly_=luseonly call unformatted_open( unit=iunit, & - file=trim(filename_(cdfile,myPE)), & + file=trim(filename_(cdfile,mype)), & class='.obsdiags.', & action='write', & status='unknown', & newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. iostat=istat,silent=.true.) - if(istat/=0) then - call perr(myname_,'unformatted_open(), file =',filename_(cdfile,myPE)) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif + if(istat/=0) then + call perr(myname_,'unformatted_open(), file =',filename_(cdfile,mype)) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) + endif - if(DO_SUMMARY) call summary_(myname_) + if(do_summary) call summary_(myname_) do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - call obsdiagLList_write(obsdiags(jj,ii),iunit,luseonly_,jiter,miter,jj,ii,luseRange=luseRange) + do jj=1,size(obsdiags,1) + call obsdiagllist_write(obsdiags(jj,ii),iunit,luseonly_,jiter,miter,jj,ii,luserange=luserange) - if (force_write .or. l4dvar) then - call obsLList_write(obsLLists(jj,ii),iunit,luseonly_,jj,luseRange=luseRange) - endif + if (force_write .or. l4dvar) then + call obsllist_write(obsllists(jj,ii),iunit,luseonly_,jj,luserange=luserange) + endif - write(iunit)ii,jj ! a jj_obstype-block trailer - enddo + write(iunit)ii,jj ! a jj_obstype-block trailer + enddo enddo close(iunit) - ! latlonRange_gatherWrite() implies a mpi_barrier() action. - call latlonRange_gatherWrite(luseRange,hdfilename_(cdfile),root=0,comm=gsi_comm_world) + ! latlonrange_gatherwrite() implies a mpi_barrier() action. + call latlonrange_gatherwrite(luserange,hdfilename_(cdfile),root=0,comm=gsi_comm_world) -#ifdef SHOW_LLRANGE +#ifdef show_llrange ! Text-dump to diagnose the values - call latlonRange_gatherDump( "cvgLLRange",root=0,comm=gsi_comm_world) - call latlonRange_gatherDump(luseRange,"obsLLRange",root=0,comm=gsi_comm_world) + call latlonrange_gatherdump( "cvgllrange",root=0,comm=gsi_comm_world) + call latlonrange_gatherdump(luserange,"obsllrange",root=0,comm=gsi_comm_world) #endif - call latlonRange_reset(luseRange) + call latlonrange_reset(luserange) - if(SYNCH_MESSAGES) call MPI_Barrier(gsi_comm_world,ier) - if (mype==0) call tell(myname_,'Finish writing obsdiags to file ',filename_(cdfile,myPE)) + if(synch_messages) call mpi_barrier(gsi_comm_world,ier) + if (mype==0) call tell(myname_,'Finish writing obsdiags to file ',filename_(cdfile,mype)) ! ---------------------------------------------------------- !call stdout_close() -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine write_ -subroutine read_(cdfile,iPE,redistr,fileislocal,force,jiter_expected,verbose,jread) +subroutine read_(cdfile,ipe,redistr,fileislocal,force,jiter_expected,verbose,jread) use mpeu_util, only: tell,perr,die use mpeu_util, only: stdout use mpimod, only: mype use gsi_4dvar, only: l4dvar use gsi_unformatted, only: unformatted_open use jfunc, only: jiter,miter - _TIMER_USE_ + _timer_use_ use obsmod, only: lobserver - use m_obsLList, only: obsLList_read - use m_obsLList, only: obsLList_lsize - use m_obsLList, only: obsLList_lcount + use m_obsllist, only: obsllist_read + use m_obsllist, only: obsllist_lsize + use m_obsllist, only: obsllist_lcount - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obsdiagLList_read - use m_obsdiagNode, only: obsdiagLList_lsize - use m_obsdiagNode, only: obsdiagLList_lcount - use m_obsdiagNode, only: obsdiagLookup_build - use m_obsdiagNode, only: obsdiagLookup_clean + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obsdiagllist_read + use m_obsdiagnode, only: obsdiagllist_lsize + use m_obsdiagnode, only: obsdiagllist_lcount + use m_obsdiagnode, only: obsdiaglookup_build + use m_obsdiagnode, only: obsdiaglookup_clean implicit none character(len=*), intent(in ):: cdfile ! prefix of the input file - integer(i_kind ), intent(in ):: iPE ! iPE of the input file + integer(i_kind ), intent(in ):: ipe ! ipe of the input file logical , intent(in ):: redistr ! data redistribution is expected logical , intent(in ):: fileislocal ! the file to read, is known local @@ -992,158 +992,158 @@ subroutine read_(cdfile,iPE,redistr,fileislocal,force,jiter_expected,verbose,jre integer(i_kind ), optional, intent(inout):: jread ! jiter read from the input character(len=*),parameter:: myname_=myname//'::read_' - character(len=*),parameter:: diag_timer_=myname_//'.obsdiagLList_read' - character(len=*),parameter:: list_timer_=myname_//'.obsLList_read' + character(len=*),parameter:: diag_timer_=myname_//'.obsdiagllist_read' + character(len=*),parameter:: list_timer_=myname_//'.obsllist_read' integer(i_kind):: ii,jj integer(i_kind):: ki,kj integer(i_kind):: iunit,istat integer(i_kind):: jread_ integer(i_kind):: lsize_type_,nsize_type_ integer(i_kind):: lsize_diag_,nsize_diag_,msize_diag_ - type(obs_diag),pointer:: leadNode => NULL() + type(obs_diag),pointer:: leadnode => null() logical:: force_read logical:: verbose_ _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) - call lobsdiags_statusCheck_(myname_,allocated=.true.) + call lobsdiags_statuscheck_(myname_,allocated=.true.) force_read=.false. if(present(force)) force_read=force verbose_=.false. if(present(verbose)) verbose_=verbose - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) - if(CHECK_SIZES_) then - ASSERT(size(obsdiags,1)==size(lsize_type )) - ASSERT(size(obsdiags,1)==size(nsize_type )) - ASSERT(size(obsdiags,1)==size(lsize_diag )) - ASSERT(size(obsdiags,1)==size(nsize_diag )) - endif + ASSERT(all(shape(obsdiags)==shape(obsllists))) + ASSERT(size(obsdiags,1)==size(obsllists,1)) + ASSERT(size(obsdiags,2)==size(obsllists,2)) + if(check_sizes_) then + ASSERT(size(obsdiags,1)==size(lsize_type )) + ASSERT(size(obsdiags,1)==size(nsize_type )) + ASSERT(size(obsdiags,1)==size(lsize_diag )) + ASSERT(size(obsdiags,1)==size(nsize_diag )) + endif call unformatted_open( unit=iunit, & - file=trim(filename_(cdfile,iPE)), & + file=trim(filename_(cdfile,ipe)), & class='.obsdiags.', & action='read', & status='old', & newunit=.true., & ! with newunit=.true., unit returns a value assigned by Fortran. iostat=istat,silent=.true.) - if(istat/=0) then - call perr(myname_,'unformatted_open(), file =',trim(filename_(cdfile,iPE))) - call perr(myname_,' myPE =',myPE) - call perr(myname_,' iPE =',iPE) - call perr(myname_,' miter =',miter) - call perr(myname_,' redistr =',redistr) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif - - if(verbose_) call tell(myname_,'Reading obsdiags, file =',trim(filename_(cdfile,iPE))) - - leadNode => null() + if(istat/=0) then + call perr(myname_,'unformatted_open(), file =',trim(filename_(cdfile,ipe))) + call perr(myname_,' mype =',mype) + call perr(myname_,' ipe =',ipe) + call perr(myname_,' miter =',miter) + call perr(myname_,' redistr =',redistr) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) + endif + + if(verbose_) call tell(myname_,'Reading obsdiags, file =',trim(filename_(cdfile,ipe))) + + leadnode => null() do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - if(CHECK_SIZES_) then - lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.,recount=.true.) - nsize_type_= obsLList_lsize (obsLLists(jj,ii) ) - - lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.,recount=.true.) - !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.) - nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) ) - endif - - call obsdiagLList_read(obsdiags(jj,ii),iunit,redistr,jiter,miter,jj,ii,jread_,leadNode=leadNode, & - jiter_expected=jiter_expected) - if(present(jread)) then - if(jread/=jread_) then - if(jread>0) then - call perr(myname_,'not the same iteration, jiter =',jiter) - call perr(myname_,' saved jread =',jread) - call perr(myname_,' current jread =',jread_) - call die(myname_) - endif - jread=jread_ + do jj=1,size(obsdiags,1) + if(check_sizes_) then + lsize_type_= obsllist_lcount(obsllists(jj,ii),luseonly=.true.,recount=.true.) + nsize_type_= obsllist_lsize (obsllists(jj,ii) ) + + lsize_diag_= obsdiagllist_lcount(obsdiags(jj,ii),luseonly=.true.,recount=.true.) + !msize_diag_= obsdiagllist_lcount(obsdiags(jj,ii),museonly=.true.) + nsize_diag_= obsdiagllist_lsize (obsdiags(jj,ii) ) endif - endif - call obsdiagLookup_build(obsdiags(jj,ii),leadNode=leadNode,jiter=jread) - leadNode => null() ! nullified after its use, to avoid leadNode dangling arround. - - if (force_read .or. l4dvar.and..not.(lobserver.and.jiter==1)) then - call obsLList_read(obsLLists(jj,ii),iunit,redistr,obsdiags(jj,ii),jj) - endif + call obsdiagllist_read(obsdiags(jj,ii),iunit,redistr,jiter,miter,jj,ii,jread_,leadnode=leadnode, & + jiter_expected=jiter_expected) + if(present(jread)) then + if(jread/=jread_) then + if(jread>0) then + call perr(myname_,'not the same iteration, jiter =',jiter) + call perr(myname_,' saved jread =',jread) + call perr(myname_,' current jread =',jread_) + call die(myname_) + endif + jread=jread_ + endif + endif - call obsdiagLookup_clean(obsdiags(jj,ii)) + call obsdiaglookup_build(obsdiags(jj,ii),leadnode=leadnode,jiter=jread) + leadnode => null() ! nullified after its use, to avoid leadnode dangling arround. - read(iunit)ki,kj - if(ki/=ii .or. kj/=jj) then - call perr(myname_,'mismatched block id, file =',filename_(cdfile,iPE)) - if(kj/=jj) then - call perr(myname_,' reading kj =',kj) - call perr(myname_,' expecting jj =',jj) + if (force_read .or. l4dvar.and..not.(lobserver.and.jiter==1)) then + call obsllist_read(obsllists(jj,ii),iunit,redistr,obsdiags(jj,ii),jj) endif - if(ki/=ii) then - call perr(myname_,' reading ki =',ki) - call perr(myname_,' expecting ii =',ii) + + call obsdiaglookup_clean(obsdiags(jj,ii)) + + read(iunit)ki,kj + if(ki/=ii .or. kj/=jj) then + call perr(myname_,'mismatched block id, file =',filename_(cdfile,ipe)) + if(kj/=jj) then + call perr(myname_,' reading kj =',kj) + call perr(myname_,' expecting jj =',jj) + endif + if(ki/=ii) then + call perr(myname_,' reading ki =',ki) + call perr(myname_,' expecting ii =',ii) + endif + call perr(myname_,' file =',filename_(cdfile,ipe)) + call perr(myname_,' cdfile =',cdfile) + call perr(myname_,' mype =',mype) + call perr(myname_,' ipe =',ipe) + call perr(myname_,' miter =',miter) + call perr(myname_,' redistr =',redistr) + call perr(myname_,' newunit =',iunit) + call perr(myname_,' iostat =',istat) + call die(myname_) endif - call perr(myname_,' file =',filename_(cdfile,iPE)) - call perr(myname_,' cdfile =',cdfile) - call perr(myname_,' myPE =',myPE) - call perr(myname_,' iPE =',iPE) - call perr(myname_,' miter =',miter) - call perr(myname_,' redistr =',redistr) - call perr(myname_,' newunit =',iunit) - call perr(myname_,' iostat =',istat) - call die(myname_) - endif - ASSERT(1<=jj.and.jj<=nobs_type) + ASSERT(1<=jj.and.jj<=nobs_type) - if(CHECK_SIZES_) then - lsize_type_= obsLList_lcount(obsLLists(jj,ii),luseonly=.true.)-lsize_type_ - nsize_type_= obsLList_lsize (obsLLists(jj,ii) )-nsize_type_ + if(check_sizes_) then + lsize_type_= obsllist_lcount(obsllists(jj,ii),luseonly=.true.)-lsize_type_ + nsize_type_= obsllist_lsize (obsllists(jj,ii) )-nsize_type_ - lsize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),luseonly=.true.)-lsize_diag_ - !msize_diag_= obsdiagLList_lcount(obsdiags(jj,ii),museonly=.true.)-msize_diag_ - nsize_diag_= obsdiagLList_lsize (obsdiags(jj,ii) )-nsize_diag_ + lsize_diag_= obsdiagllist_lcount(obsdiags(jj,ii),luseonly=.true.)-lsize_diag_ + !msize_diag_= obsdiagllist_lcount(obsdiags(jj,ii),museonly=.true.)-msize_diag_ + nsize_diag_= obsdiagllist_lsize (obsdiags(jj,ii) )-nsize_diag_ - if( fileislocal .or. lsize_type_>0.or.nsize_type_>0 .or. & - msize_diag_>0.or. lsize_diag_>0.or.nsize_diag_>0 ) then - write(stdout,'(i5.3,2i5,2x,5i6,2x,l1)') iPE,jj,ii,lsize_type_,nsize_type_, & - msize_diag_,lsize_diag_,nsize_diag_,fileislocal - endif + if( fileislocal .or. lsize_type_>0.or.nsize_type_>0 .or. & + msize_diag_>0.or. lsize_diag_>0.or.nsize_diag_>0 ) then + write(stdout,'(i5.3,2i5,2x,5i6,2x,l1)') ipe,jj,ii,lsize_type_,nsize_type_, & + msize_diag_,lsize_diag_,nsize_diag_,fileislocal + endif - lsize_type(jj)= lsize_type(jj) +lsize_type_ - nsize_type(jj)= nsize_type(jj) +nsize_type_ + lsize_type(jj)= lsize_type(jj) +lsize_type_ + nsize_type(jj)= nsize_type(jj) +nsize_type_ - lsize_diag(jj)= lsize_diag(jj) +lsize_diag_ - !msize_diag(jj)= msize_diag(jj) +msize_diag_ - nsize_diag(jj)= nsize_diag(jj) +nsize_diag_ - endif + lsize_diag(jj)= lsize_diag(jj) +lsize_diag_ + !msize_diag(jj)= msize_diag(jj) +msize_diag_ + nsize_diag(jj)= nsize_diag(jj) +nsize_diag_ + endif - enddo ! jj=1,size(obsdiags,1) + enddo ! jj=1,size(obsdiags,1) enddo ! ii=1,size(obsdiags,2) close(iunit) ! ---------------------------------------------------------- -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine read_ -function filename_(prefix,iPE) -!>> name of partitioned (obsdiags,obsLLists) files +function filename_(prefix,ipe) +!>> name of partitioned (obsdiags,obsllists) files implicit none character(len=:),allocatable:: filename_ character(len=*) , intent(in ):: prefix - integer(kind=i_kind), intent(in ):: iPE + integer(kind=i_kind), intent(in ):: ipe - character(len=4):: chPE - write(chPE,'(i4.4)') iPE - filename_=trim(adjustl(prefix))//'.'//trim(chPE) + character(len=4):: chpe + write(chpe,'(i4.4)') ipe + filename_=trim(adjustl(prefix))//'.'//trim(chpe) end function filename_ function hdfilename_(prefix) @@ -1156,16 +1156,16 @@ function hdfilename_(prefix) end function hdfilename_ subroutine summary_(title) -!-- get a summary of obsdiags(:,:) and obsLLists(:,:) -use obsmod, only: luse_obsdiag -use mpeu_util, only: tell,die,perr,stdout_open,stdout_close -_TIMER_USE_ +!-- get a summary of obsdiags(:,:) and obsllists(:,:) + use obsmod, only: luse_obsdiag + use mpeu_util, only: tell,die,perr,stdout_open,stdout_close +_timer_use_ use gsi_unformatted, only: unformatted_open use gsi_4dvar, only: nobs_bins - use m_obsLList, only: obsLList_lsize => obsLList_lcount - use m_obsdiagNode, only: obsdiagLList_lsize => obsdiagLList_lcount + use m_obsllist, only: obsllist_lsize => obsllist_lcount + use m_obsdiagnode, only: obsdiagllist_lsize => obsdiagllist_lcount implicit none character(len=*), intent(in) :: title @@ -1176,154 +1176,154 @@ subroutine summary_(title) integer(i_kind),dimension(nobs_type,nobs_bins):: ldiag,ndiag integer(i_kind),dimension(nobs_type,nobs_bins):: lobss,nobss _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) ! ---------------------------------------------------------- - call lobsdiags_statusCheck_(myname_,allocated=.true.) + call lobsdiags_statuscheck_(myname_,allocated=.true.) if (luse_obsdiag) then - ASSERT(all(shape(obsdiags)==shape(obsLLists))) - ASSERT(size(obsdiags,1)==size(obsLLists,1)) - ASSERT(size(obsdiags,2)==size(obsLLists,2)) + ASSERT(all(shape(obsdiags)==shape(obsllists))) + ASSERT(size(obsdiags,1)==size(obsllists,1)) + ASSERT(size(obsdiags,2)==size(obsllists,2)) endif do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - ldiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.true. ,recount=.true.) - ndiag(jj,ii) = obsdiagLList_lsize(obsdiags(jj,ii),luseonly=.false.,recount=.true.) - enddo + do jj=1,size(obsdiags,1) + ldiag(jj,ii) = obsdiagllist_lsize(obsdiags(jj,ii),luseonly=.true. ,recount=.true.) + ndiag(jj,ii) = obsdiagllist_lsize(obsdiags(jj,ii),luseonly=.false.,recount=.true.) + enddo enddo - do ii=1,size(obsLLists,2) - do jj=1,size(obsLLists,1) - lobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.true. ,recount=.true.) - nobss(jj,ii) = obsLList_lsize(obsLLists(jj,ii),luseonly=.false.,recount=.true.) - enddo + do ii=1,size(obsllists,2) + do jj=1,size(obsllists,1) + lobss(jj,ii) = obsllist_lsize(obsllists(jj,ii),luseonly=.true. ,recount=.true.) + nobss(jj,ii) = obsllist_lsize(obsllists(jj,ii),luseonly=.false.,recount=.true.) + enddo enddo call gather_write_(title,lobss,ldiag,nobss,ndiag,root=0,comm=gsi_comm_world) ! ---------------------------------------------------------- -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) -return + return end subroutine summary_ subroutine gather_write_(title,lobss,ldiag,nobss,ndiag,root,comm) - use mpimod , only: mype,nPE + use mpimod , only: mype,npe use kinds , only: i_kind - use mpeu_mpif, only: MPI_ikind - _TIMER_USE_ + use mpeu_mpif, only: mpi_ikind + _timer_use_ implicit none character(len=*),intent(in):: title integer(kind=i_kind),dimension(:,:),intent(in):: lobss,ldiag integer(kind=i_kind),dimension(:,:),intent(in):: nobss,ndiag - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm + integer(kind=mpi_ikind),intent(in):: root + integer(kind=mpi_ikind),intent(in):: comm character(len=*),parameter:: myname_=myname//'::gather_write_' - integer(kind=i_kind):: jj,ii,iPE - integer(kind=i_kind) :: mtyp,mbin,mPEs + integer(kind=i_kind):: jj,ii,ipe + integer(kind=i_kind) :: mtyp,mbin,mpes integer(kind=i_kind),allocatable,dimension(:,:,:):: ldiagm,ndiagm integer(kind=i_kind),allocatable,dimension(:,:,:):: lobssm,nobssm _ENTRY_(myname_) -_TIMER_ON_(myname_) +_timer_on_(myname_) mtyp=size(lobss,1) mbin=size(lobss,2) - ASSERT(mtyp==size(nobss,1)) - ASSERT(mbin==size(nobss,2)) - ASSERT(mtyp==size(ldiag,1)) - ASSERT(mbin==size(ldiag,2)) - ASSERT(mtyp==size(ndiag,1)) - ASSERT(mbin==size(ndiag,2)) - - mPEs=0 ! its value is significant only on root - if(myPE==root) mPEs=nPE - - allocate(lobssm(mtyp,mbin,0:mPEs-1)) - allocate(ldiagm(mtyp,mbin,0:mPEs-1)) - allocate(nobssm(mtyp,mbin,0:mPEs-1)) - allocate(ndiagm(mtyp,mbin,0:mPEs-1)) - - call iMPI_gather_(lobss,lobssm,root,comm) - call iMPI_gather_(nobss,nobssm,root,comm) - call iMPI_gather_(ldiag,ldiagm,root,comm) - call iMPI_gather_(ndiag,ndiagm,root,comm) - - if(myPE==root) then - do iPE=0,nPE-1 - write(stdout,'(2a,i6)' ) title,'(): local obs/diag counts, iPE =',iPE - write(stdout,'(2a,9(1x,a))') title,'(): typ', ('| -----lo -----ld -----no -----nd',ii=1,mbin) - do jj=1,mtyp - write(stdout,'(2a,i3,9(1x,a,2(1x,2i8)))') & - title,'(): ',jj , & - ("|",lobssm(jj,ii,iPE),ldiagm(jj,ii,iPE), & - nobssm(jj,ii,iPE),ndiagm(jj,ii,iPE), ii=1,mbin) - enddo - enddo + ASSERT(mtyp==size(nobss,1)) + ASSERT(mbin==size(nobss,2)) + ASSERT(mtyp==size(ldiag,1)) + ASSERT(mbin==size(ldiag,2)) + ASSERT(mtyp==size(ndiag,1)) + ASSERT(mbin==size(ndiag,2)) + + mpes=0 ! its value is significant only on root + if(mype==root) mpes=npe + + allocate(lobssm(mtyp,mbin,0:mpes-1)) + allocate(ldiagm(mtyp,mbin,0:mpes-1)) + allocate(nobssm(mtyp,mbin,0:mpes-1)) + allocate(ndiagm(mtyp,mbin,0:mpes-1)) + + call impi_gather_(lobss,lobssm,root,comm) + call impi_gather_(nobss,nobssm,root,comm) + call impi_gather_(ldiag,ldiagm,root,comm) + call impi_gather_(ndiag,ndiagm,root,comm) + + if(mype==root) then + do ipe=0,npe-1 + write(stdout,'(2a,i6)' ) title,'(): local obs/diag counts, ipe =',ipe + write(stdout,'(2a,9(1x,a))') title,'(): typ', ('| -----lo -----ld -----no -----nd',ii=1,mbin) + do jj=1,mtyp + write(stdout,'(2a,i3,9(1x,a,2(1x,2i8)))') & + title,'(): ',jj , & + ("|",lobssm(jj,ii,ipe),ldiagm(jj,ii,ipe), & + nobssm(jj,ii,ipe),ndiagm(jj,ii,ipe), ii=1,mbin) + enddo + enddo endif deallocate(lobssm) deallocate(ldiagm) deallocate(nobssm) deallocate(ndiagm) -_TIMER_OFF_(myname_) +_timer_off_(myname_) _EXIT_(myname_) end subroutine gather_write_ -subroutine iMPI_barrier_(comm) - use mpeu_mpif, only: MPI_ikind +subroutine impi_barrier_(comm) + use mpeu_mpif, only: mpi_ikind use mpeu_util, only: die implicit none - integer(kind=MPI_ikind),intent(in):: comm + integer(kind=mpi_ikind),intent(in):: comm - character(len=*),parameter:: myname_=myname//"::iMPI_barrier_" - integer(kind=MPI_ikind):: ier + character(len=*),parameter:: myname_=myname//"::impi_barrier_" + integer(kind=mpi_ikind):: ier - call MPI_barrier(comm,ier) - if(ier/=0) call die(myname_,'MPI_barrier() error, ierror =',ier) -end subroutine iMPI_barrier_ + call mpi_barrier(comm,ier) + if(ier/=0) call die(myname_,'mpi_barrier() error, ierror =',ier) +end subroutine impi_barrier_ -subroutine iMPI_gather_(isend,irecv,root,comm) - use mpeu_mpif,only: MPI_ikind,MPI_type +subroutine impi_gather_(isend,irecv,root,comm) + use mpeu_mpif,only: mpi_ikind,mpi_type use mpeu_util, only: die use kinds, only: i_kind implicit none integer(kind=i_kind),dimension(:,: ),intent(in ):: isend integer(kind=i_kind),dimension(:,:,:),intent(out):: irecv - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm + integer(kind=mpi_ikind),intent(in):: root + integer(kind=mpi_ikind),intent(in):: comm - character(len=*),parameter:: myname_=myname//"::iMPI_gather_" - integer(kind=MPI_ikind):: itype,isize,ierr + character(len=*),parameter:: myname_=myname//"::impi_gather_" + integer(kind=mpi_ikind):: itype,isize,ierr isize=size(isend) - itype=MPI_type(isend) - call MPI_gather(isend,isize,itype, & + itype=mpi_type(isend) + call mpi_gather(isend,isize,itype, & irecv,isize,itype, root,comm,ierr) - if(ierr/=0) call die(myname_,'MPI_gather() error, ierror =',ierr) -end subroutine iMPI_gather_ + if(ierr/=0) call die(myname_,'mpi_gather() error, ierror =',ierr) +end subroutine impi_gather_ -subroutine iMPI_reduceSUM_(iredu,root,comm) - use mpeu_mpif,only: MPI_ikind,MPI_type,MPI_SUM +subroutine impi_reducesum_(iredu,root,comm) + use mpeu_mpif,only: mpi_ikind,mpi_type,mpi_sum use mpeu_util, only: die use kinds, only: i_kind implicit none integer(kind=i_kind),dimension(:),intent(inout):: iredu - integer(kind=MPI_ikind),intent(in):: root - integer(kind=MPI_ikind),intent(in):: comm + integer(kind=mpi_ikind),intent(in):: root + integer(kind=mpi_ikind),intent(in):: comm - character(len=*),parameter:: myname_=myname//"::iMPI_reduceSUM_" - integer(kind=MPI_ikind):: itype,isize,ierr + character(len=*),parameter:: myname_=myname//"::impi_reducesum_" + integer(kind=mpi_ikind):: itype,isize,ierr !integer(kind=kind(iredu)),dimension(size(iredu)):: irecv isize=size(iredu) - itype=MPI_type(iredu) - call MPI_reduce((iredu),iredu,isize,itype, MPI_SUM, root,comm,ierr) - if(ierr/=0) call die(myname_,'MPI_reduce(MPI_SUM) error, ierror =',ierr) + itype=mpi_type(iredu) + call mpi_reduce((iredu),iredu,isize,itype, mpi_sum, root,comm,ierr) + if(ierr/=0) call die(myname_,'mpi_reduce(mpi_sum) error, ierror =',ierr) !iredu(:)=irecv(:) -end subroutine iMPI_reduceSUM_ +end subroutine impi_reducesum_ subroutine create_obsmod_vars() !$$$ subprogram documentation block @@ -1336,7 +1336,7 @@ subroutine create_obsmod_vars() ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation -! 2015-10-09 j guo - moved here from MODULE OBSMOD with modifcations +! 2015-10-09 j guo - moved here from module obsmod with modifcations ! ! input argument list: ! @@ -1347,13 +1347,13 @@ subroutine create_obsmod_vars() ! machine: ibm rs/6000 sp ! !$$$ end documentation block - use gsi_4dvar, only: nobs_bins - implicit none - lobstypes_allocated_=.true. - lobsdiags_allocated_=.true. - allocate(obsllists(nobs_type,nobs_bins)) - allocate(obsdiags (nobs_type,nobs_bins)) - return + use gsi_4dvar, only: nobs_bins + implicit none + lobstypes_allocated_=.true. + lobsdiags_allocated_=.true. + allocate(obsllists(nobs_type,nobs_bins)) + allocate(obsdiags (nobs_type,nobs_bins)) + return end subroutine create_obsmod_vars subroutine destroy_obsmod_vars() @@ -1389,47 +1389,47 @@ subroutine inquire_obsdiags(kiter) ! !$$$ end documentation block -use constants, only: one,two,three,four,five -use mpimod, only: mpi_max,mpi_comm_world,ierror,mype -use mpeu_mpif, only: mpi_type, MPI_IKIND -implicit none + use constants, only: one,two,three,four,five + use mpimod, only: mpi_max,mpi_comm_world,ierror,mype + use mpeu_mpif, only: mpi_type, mpi_ikind + implicit none -integer(i_kind), intent(in ) :: kiter + integer(i_kind), intent(in ) :: kiter -real(r_kind) :: sizei, sizer, sizel, sizep, ziter, zsize, ztot -integer(i_kind) :: ii,jj,iobsa(2),iobsb(2) -type(obs_diag), pointer :: obsptr => null() + real(r_kind) :: sizei, sizer, sizel, sizep, ziter, zsize, ztot + integer(i_kind) :: ii,jj,iobsa(2),iobsb(2) + type(obs_diag), pointer :: obsptr => null() ! Any better way to determine size or i_kind, r_kind, etc... ? -sizei=four -sizer=8.0_r_kind -sizel=one -sizep=four - -iobsa(:)=0 -do ii=1,size(obsdiags,2) - do jj=1,size(obsdiags,1) - obsptr => obsdiags(jj,ii)%head - do while (associated(obsptr)) - iobsa(1)=iobsa(1)+1 - if (ANY(obsptr%muse(:))) iobsa(2)=iobsa(2)+1 - obsptr => obsptr%next - enddo - enddo -enddo - -call mpi_reduce(iobsa,iobsb,2_MPI_IKIND,mpi_type(iobsa),mpi_max,0_MPI_IKIND,mpi_comm_world,ierror) - -if (mype==0) then - ziter=real(kiter,r_kind) - zsize = sizer*(three*ziter+two) + sizei + sizel*(ziter+one) + sizep*five - ztot=real(iobsb(1),r_kind)*zsize - ztot=ztot/(1024.0_r_kind*1024.0_r_kind) + sizei=four + sizer=8.0_r_kind + sizel=one + sizep=four + + iobsa(:)=0 + do ii=1,size(obsdiags,2) + do jj=1,size(obsdiags,1) + obsptr => obsdiags(jj,ii)%head + do while (associated(obsptr)) + iobsa(1)=iobsa(1)+1 + if (any(obsptr%muse(:))) iobsa(2)=iobsa(2)+1 + obsptr => obsptr%next + enddo + enddo + enddo + + call mpi_reduce(iobsa,iobsb,2_mpi_ikind,mpi_type(iobsa),mpi_max,0_mpi_ikind,mpi_comm_world,ierror) + + if (mype==0) then + ziter=real(kiter,r_kind) + zsize = sizer*(three*ziter+two) + sizei + sizel*(ziter+one) + sizep*five + ztot=real(iobsb(1),r_kind)*zsize + ztot=ztot/(1024.0_r_kind*1024.0_r_kind) - write(6,*)'obsdiags: Bytes per element=',NINT(zsize) - write(6,*)'obsdiags: length total, used=',iobsb(1),iobsb(2) - write(6,'(A,F8.1,A)')'obsdiags: Estimated memory usage= ',ztot,' Mb' -endif + write(6,*)'obsdiags: Bytes per element=',nint(zsize) + write(6,*)'obsdiags: length total, used=',iobsb(1),iobsb(2) + write(6,'(A,F8.1,A)')'obsdiags: Estimated memory usage= ',ztot,' Mb' + endif end subroutine inquire_obsdiags diff --git a/src/gsi/m_obsllist.F90 b/src/gsi/m_obsllist.F90 new file mode 100644 index 0000000000..ee5b2d142d --- /dev/null +++ b/src/gsi/m_obsllist.F90 @@ -0,0 +1,930 @@ +module m_obsllist +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsllist +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of linked-list of polymorphic obsnode. +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2016-06-24 j.guo - added support of using m_latlonrange to find a cluster +! latlonrange from (elat,elon) values of observations. +! 2016-07-25 j.guo - added gettlddotprod, to accumulate obsnode tld-dot_produst +! 2016-09-19 j.guo - added function lincr_() to extend []_lsize(). +! 2017-08-26 G.Ge - change allocate(headll%mold,mold=mold) +! to allocate(headll%mold,source=mold) +! +! 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 + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: obsllist + + type obsllist + private + integer(i_kind):: n_alloc =0 + + integer(i_kind):: my_obstype =0 + class(obsnode),pointer:: mold => null() ! a mold for the nodes + + class(obsnode),pointer:: head => null() ! + class(obsnode),pointer:: tail => null() + + integer(i_kind):: l_alloc =0 ! previous n_alloc, see showincr + end type obsllist + + public:: obsllist_mold ! get the mold of the obsllist + interface obsllist_mold; module procedure lmold_; end interface + + public:: obsllist_reset ! reset or finalize obsllist to its empty state. + public:: obsllist_appendnode ! append a node to obsllist + + interface obsllist_reset ; module procedure lreset_ ; end interface + interface obsllist_appendnode; module procedure lappendnode_; end interface + + public:: obsllist_rewind ! rewind obsllist + public:: obsllist_nextnode ! move obsllist to its next node + + interface obsllist_rewind ; module procedure lrewind_ ; end interface + interface obsllist_nextnode ; module procedure lnextnode_ ; end interface + + public:: obsllist_headnode ! locate the head node of obsllist + public:: obsllist_tailnode ! locate the tail node of obsllist + + interface obsllist_headnode ; module procedure lheadnode_ ; end interface + interface obsllist_tailnode ; module procedure ltailnode_ ; end interface + + public:: obsllist_lsize ! get the size of a llist + public:: obsllist_lcount ! get the size of a llist + public:: obsllist_lsort ! sort nodes according to their keys + public:: obsllist_write ! output a llist to a file unit + public:: obsllist_read ! input from a file created by _write() + public:: obsllist_checksum ! size consistency checking + public:: obsllist_summary ! show some information about the llist + + interface obsllist_lsize ; module procedure lsize_, & + lincr_ ; end interface + interface obsllist_lcount ; module procedure lcount_ ; end interface + interface obsllist_lsort ; module procedure lsort_ ; end interface + interface obsllist_write ; module procedure lwrite_ ; end interface + interface obsllist_read ; module procedure lread_ ; end interface + interface obsllist_checksum; module procedure & + lchecksum_, & + lchecksum1_ ; end interface + interface obsllist_summary; module procedure lsummary_; end interface + + public:: obsllist_gettlddotprod ! get "LHS" (dot-product of (:)%diags%tldepar, plus count) + interface obsllist_gettlddotprod ; module procedure ltlddotprod_ ; end interface + + character(len=*),parameter:: myname="m_obsllist" + +#include "myassert.H" +#include "mytrace.H" +contains + +subroutine ltlddotprod_(headll,jiter,tlddp,nnode,nob) +!-- get "lhs" of the given linked-list + use kinds, only: i_kind,r_kind + use m_obsnode, only: obsnode_next, obsnode_isluse + implicit none + type(obsllist),target, intent(in):: headll ! a linked-list + integer(kind=i_kind) , intent(in):: jiter ! for this iteration + real (kind=r_kind) , intent(inout):: tlddp ! dot_product((:)%tld) + integer(kind=i_kind) , optional, intent(inout):: nnode ! node count + integer(kind=i_kind) , optional, intent(inout):: nob ! obs. count + + class(obsnode),pointer:: inode + inode => lheadnode_(headll) + do while(associated(inode)) + if(obsnode_isluse(inode)) then + call inode%gettlddp(jiter,tlddp,nob=nob) + if(present(nnode)) nnode=nnode+1 + endif + inode => obsnode_next(inode) + enddo +end subroutine ltlddotprod_ + +function lmold_(headll) result(ptr_) + implicit none + class(obsnode),pointer:: ptr_ + type(obsllist),target,intent(in):: headll + ptr_ => null() + if(associated(headll%mold)) ptr_ => headll%mold +end function lmold_ + +!--------------------------- will go to m_obsllist ---------------------- +subroutine lrewind_(headll) + implicit none + type(obsllist),target,intent(inout):: headll + headll%tail => null() +end subroutine lrewind_ + +function lnextnode_(headll) result(here_) + use m_obsnode, only: obsnode_next + implicit none + class(obsnode),pointer:: here_ + type(obsllist),target,intent(inout):: headll + + if(associated(headll%tail)) then + ! when not the first time lnextnode_(), after call lrewind_() + headll%tail => obsnode_next(headll%tail) + else + ! When the first time lnextnode_(), after call lrewind_() + headll%tail => lheadnode_(headll) + endif + here_ => headll%tail +end function lnextnode_ + +function lheadnode_(headll) result(here_) + implicit none + class(obsnode),pointer:: here_ + type(obsllist),target,intent(in):: headll + here_ => headll%head +end function lheadnode_ + +function ltailnode_(headll) result(here_) + implicit none + class(obsnode),pointer:: here_ + type(obsllist),target,intent(in):: headll + here_ => headll%tail +end function ltailnode_ + +function lsize_(headll) + implicit none + integer(i_kind):: lsize_ + type(obsllist),intent(in):: headll + lsize_=headll%n_alloc +end function lsize_ +function lincr_(headll,incr) + implicit none + integer(i_kind):: lincr_ + type(obsllist),intent(inout):: headll + logical,intent(in):: incr + lincr_=headll%n_alloc + if(incr) then + lincr_=lincr_-headll%l_alloc + headll%l_alloc=headll%n_alloc + endif +end function lincr_ + +subroutine lreset_(headll,mold,stat) +!$$$ subprogram documentation block +! . . . . +! subprogram: lreset_ +! prgmmr: J. Guo +! +! abstract: reset a linked-list to empty. +! +! program history log: +! 2015-01-12 guo - reset headll for a generic obsnode +! +! 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 m_obsnode, only: obsnode_next + use m_obsnode, only: obsnode_clean + use m_obsnode, only: obsnode_type => obsnode_mytype + implicit none + type(obsllist), intent(inout):: headll + class(obsnode), intent(in ):: mold + integer(i_kind),optional,intent(out):: stat + + character(len=*),parameter:: myname_=myname//"::lreset_" + character(len=:),allocatable:: mymold_ + integer(i_kind):: n + integer(i_kind):: ier +_ENTRY_(myname_) + + if(present(stat)) stat=0 + + call obsnode_clean(headll%head,deep=.true.,depth=n,stat=ier) + if(ier/=0.or.n/=0) then + call perr(myname_,'obsnode_clean(.deep.), stat =',ier) + call perr(myname_,' depth =',n) + call perr(myname_,' lsize(headll) =',lsize_(headll)) + call perr(myname_,' headll%head%mytype() =',obsnode_type(headll%head)) + call perr(myname_,' headll%mold%mytype() =',obsnode_type(headll%mold)) + if(.not.present(stat)) call die(myname_) + stat=ier + _EXIT_(myname_) + return + endif + + call nodedestroy_(headll%head) + + headll%n_alloc = 0 + headll%l_alloc = 0 + headll%head => null() + headll%tail => null() + + if(associated(headll%mold)) then + mymold_ = obsnode_type(headll%mold) + deallocate(headll%mold,stat=ier) + if(ier/=0) then + call perr(myname_,'deallocate(headll%mold), stat =',ier) + call perr(myname_,' obsnode_type(headll%mold) =',mymold_) + if(.not.present(stat)) call die(myname_) + stat=ier + _EXIT_(myname_) + return + endif + endif + + allocate(headll%mold, mold=mold) +_EXIT_(myname_) + return +end subroutine lreset_ + +subroutine lappendnode_(headll,targetnode) +!$$$ subprogram documentation block +! . . . . +! subprogram: lappendnode_ +! prgmmr: J. Guo +! +! abstract: append a node to the given linked-list +! +! program history log: +! 2015-01-12 guo - constructed for generic _obsnode_ +! +! input argument list: (see Fortran declarations below) +! +! output argument list: (see Fortran declarations below) +! +! attributes: +! language: f90/f95/f2003/f2008 +! machine: +! +!$$$ end documentation block + ! Link the next node of the list to the given targetnode. The return + ! result is a pointer associated to the same targetnode. + use m_obsnode, only: obsnode_append + implicit none + type(obsllist), intent(inout):: headll + !class(obsnode), target, intent(in):: targetnode + class(obsnode), pointer, intent(in):: targetnode + + character(len=*),parameter:: myname_=myname//'::lappendnode_' +!_ENTRY_(myname_) + ASSERT(associated(targetnode)) + + if(.not.associated(headll%head)) then + ! this is a fresh starting -node- for this linked-list ... + call obsnode_append(headll%head,targetnode) + headll%tail => headll%head + headll%n_alloc = 1 + + else + ASSERT(associated(headll%tail)) + ASSERT(.not.associated(headll%tail,targetnode)) + + call obsnode_append(headll%tail,targetnode) + headll%n_alloc = headll%n_alloc + 1 + + endif + +!_EXIT_(myname_) + return +end subroutine lappendnode_ + +!--------------------------- will go to m_obsllistio ---------------------- +subroutine lread_(headll,iunit,redistr,diaglookup,jtype) +!$$$ subprogram documentation block +! . . . . +! subprogram: lread_ +! prgmmr: todling +! prgmmr: J. Guo +! +! abstract: read obs-specific data structure from file. +! +! program history log: +! 2007-10-03 todling - (original read_obsdiags::read_${obstype}head_() +! 2008-12-08 todling - update to May08 version +! 2015-01-12 guo - restructured for generic _obsnode_, with redistributions +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + !use obsmod, only: obs_diags + use m_obsdiagnode, only: obs_diags + use m_obsnode, only: obsnode_read + use m_obsnode, only: obsnode_setluse + implicit none + type(obsllist), intent(inout):: headll + integer(i_kind), intent(in ):: iunit + logical , intent(in ):: redistr + type(obs_diags), intent(in ):: diaglookup + integer(i_kind), intent(in ):: jtype + + character(len=*),parameter:: myname_=myname//"::lread_" + class(obsnode),pointer :: anode => null() + integer(i_kind) :: kk,istat,mobs,jread +_ENTRY_(myname_) + +! read in an obs-specific header of the next block +! >>>>>---------------------------- +! obsheader is the information about an obs-block, where an obs-block +! a collection of nodes of the same _obsnode_ type, +! !-- not about the corresponding linked-list. + + ASSERT(associated(headll%mold)) + + call obsheader_read_(headll%mold,iunit,mobs,jread,istat) + + if(istat/=0) then + call perr(myname_,'%obsheader_read_(mobs,jread), istat =',istat) + call perr(myname_,' iunit =',iunit) + call die(myname_) + endif + + if(jtype/=jread) then + call perr(myname_,'unexpected record type, jread =',jread) + call perr(myname_,' expecting jtype =',jtype) + call perr(myname_,' mobs =',mobs) + call perr(myname_,' iunit =',iunit) + call die(myname_) + end if +! ----------------------------<<<<< + + if(mobs==0) then + ! No more record to read + _EXIT_(myname_) + return + endif + + !-- construct an anode + anode => alloc_nodecreate_(mold=headll%mold) + do kk=1,mobs + !-- initialize anode from a file (iunit) + call obsnode_read(anode,iunit,istat,redistr=redistr,diaglookup=diaglookup) + if(istat<0) then + call perr(myname_,'obsnode_read(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call perr(myname_,' kk =',kk) + call perr(myname_,' mobs =',mobs) + call perr(myname_,' redistr =',redistr) + call perr(myname_,' jtype =',jtype) + call die(myname_) + endif + + if(istat==0) cycle + + !-- If this anode is to be kept ... + if(redistr) then + ! recompute its %luse and %hop for the redistributed grid partition, + + call obsnode_setluse(anode) ! reset %luse for subdomain ownership + call anode%sethop() ! recompute %hop for the new grid + endif + + !-- keep this obsnode in its linked-list, obsllist := obsdiags(jtype,ibin) + call lappendnode_(headll,targetnode=anode) + + !-- Drop the earlier object, contruct a new anode. + !-- No deep deallocation is needed for anode, since its + !-- associated target has been passed to headll + anode => null() + anode => alloc_nodecreate_(mold=headll%mold) + + enddo ! < mobs > + + call nodedestroy_(anode) ! Clean up the working-space an_onsnode + +_EXIT_(myname_) + return +end subroutine lread_ + +subroutine lwrite_(headll,iunit,luseonly,jtype,luserange) +!$$$ subprogram documentation block +! . . . . +! subprogram: lwrite_ +! prgmmr: todling +! prgmmr: J. Guo +! +! abstract: write obs-specific data structure from file. +! +! program history log: +! 2007-10-03 todling - (original write_obsdiags::write_${obstype}head_() +! 2008-12-08 todling - update to May08 version +! 2015-01-12 guo - restructured for generic _obsnode_, with redistributions +! +! input argument list: +! +! output argument list: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use m_obsnode, only: obsnode_next + use m_obsnode, only: obsnode_isluse + use m_obsnode, only: obsnode_write + use m_latlonrange, only: latlonrange + use m_latlonrange, only: latlonrange_enclose + implicit none + type(obsllist), intent(in):: headll + integer(i_kind ), intent(in):: iunit ! unit for output + logical , intent(in):: luseonly + integer(i_kind ), intent(in):: jtype + type(latlonrange),optional,intent(inout):: luserange + + character(len=*),parameter:: myname_=myname//"::lwrite_" + class(obsnode), pointer :: inode => null() + integer(i_kind) :: istat + integer(i_kind) :: mobs,lobs,iobs,kobs + logical:: isluse_ +_ENTRY_(myname_) + +! if(jtype/=iobstype) then +! call perr(myname_,'unexpected record type, jtype =',jtype) +! call perr(myname_,' expecting iobstype =',iobstype) +! call perr(myname_,' iunit =',iunit) +! call die(myname_) +! end if + +! read in an obs-specific header of the next block +! >>>>>---------------------------- +! !-- A header is about a collection of nodes of the same obsnode type, +! !-- not about the corresponding linked-list. + + ASSERT(associated(headll%mold)) + + lobs = lcount_(headll,luseonly=luseonly) ! actual count of write + mobs = lobs + if(.not.luseonly) mobs = lsize_(headll) ! actual count of nodes + + call obsheader_write_(headll%mold,iunit,lobs,jtype,istat) + + if(istat/=0) then + call perr(myname_,'obsheader_write_(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call perr(myname_,' jtype =',jtype) + call perr(myname_,' no. node of write =',lobs) + call perr(myname_,' no. node of data =',mobs) + call perr(myname_,' luseonly =',luseonly) + call die(myname_) + endif +! ----------------------------<<<<< + + if(lobs==0) then + ! No more record to write + _EXIT_(myname_) + return + endif + +!-- looping over the linked-list for every obsnode, + + inode => lheadnode_(headll) + iobs=0 + kobs=0 + do while(associated(inode)) + iobs=iobs+1 + isluse_=obsnode_isluse(inode) + if(isluse_ .or. .not.luseonly) then + if(isluse_.and.present(luserange)) & + call latlonrange_enclose(luserange,inode%elat,inode%elon) + kobs=kobs+1 + call obsnode_write(inode,iunit,istat) + if(istat/=0) then + call perr(myname_,' obsnode_write(), istat =',istat) + call perr(myname_,' iunit =',iunit) + call perr(myname_,' jtype =',jtype) + call perr(myname_,'current-luse-node, kobs =',kobs) + call perr(myname_,' current-all-node, iobs =',iobs) + call perr(myname_,' total-luse-node-count =',lobs) + call perr(myname_,' total-all-node-count =',mobs) + call perr(myname_,' luseonly =',luseonly) + call die(myname_) + endif + endif + inode => obsnode_next(inode) + enddo + + ASSERT(iobs==mobs) + ASSERT(kobs==lobs) +_EXIT_(myname_) + return +end subroutine lwrite_ + +subroutine lchecksum_(headll,itype,ibin,leadnode,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,stdout_lead + implicit none + type(obsllist), intent(in):: headll + integer(kind=i_kind),optional,intent(in ):: itype,ibin + class(obsnode),optional,pointer, intent(in):: leadnode + logical ,optional,intent(out):: sorted + + character(len=*),parameter:: myname_=myname//"::lchecksum_" + integer(kind=i_kind):: lrecount + integer(kind=i_kind):: jtype,jbin + integer(kind=i_kind):: nuse,nooo,ndup,ksum(2) +_ENTRY_(myname_) + lrecount=lcount_(headll,recount=.true.,nuse=nuse,nooo=nooo,ndup=ndup,ksum=ksum,leadnode=leadnode) + if(present(sorted)) sorted = nooo==0.and.ndup==0 + + jtype=itype + jbin =ibin +_EXIT_(myname_) + return +end subroutine lchecksum_ +subroutine lchecksum1_(headll,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):: headll + integer(kind=i_kind),optional ,intent(in):: itype + + character(len=*),parameter:: myname_=myname//"::lchecksum1_" + integer(kind=i_kind):: i +_ENTRY_(myname_) + do i=1,size(headll) + call lchecksum_(headll(i),itype=itype,ibin=i) + enddo +_EXIT_(myname_) + return +end subroutine lchecksum1_ + +subroutine lsummary_(headll,verbose) +!$$$ subprogram documentation block +! . . . . +! subprogram: lsummary_ +! prgmmr: J. Guo +! +! abstract: summarize for the contents of a linked-list. +! +! program history log: +! 2015-01-12 guo - constructed for generic _obsnode_ +! +! 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 m_obsnode, only: obsnode_next + use m_obsnode, only: obsnode_show + implicit none + type(obsllist), intent(in):: headll + logical,optional, intent(in):: verbose + + character(len=*),parameter:: myname_=myname//"::lsummary_" + class(obsnode), pointer:: inode + integer(i_kind):: iobs_ + logical:: verbose_ + verbose_=.false. + if(present(verbose)) verbose_=verbose +_ENTRY_(myname_) + !call tell(myname_,' headllist%n_alloc =',headll%n_alloc) + + if(verbose_) then + iobs_ = 0 + inode => lheadnode_(headll) + do while(associated(inode)) + iobs_=iobs_+1 + call obsnode_show(inode,iobs_) + inode => obsnode_next(inode) + enddo + endif +_EXIT_(myname_) + return +end subroutine lsummary_ + +function lcount_(headll,luseonly,recount,nuse,nooo,ndup,ksum,leadnode) result(lobs_) +!$$$ subprogram documentation block +! . . . . +! subprogram: lcount_ +! prgmmr: J. Guo +! +! abstract: inquire for the size information about the linked-list +! +! program history log: +! 2015-01-12 guo - constructed for generic _obsnode_ +! +! 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 m_obsnode, only: obsnode_next + use m_obsnode, only: obsnode_isluse + implicit none + integer(kind=i_kind):: lobs_ + type(obsllist), target, intent(in):: headll + logical,optional,intent(in):: luseonly ! count only luse data + logical,optional,intent(in):: recount + integer(kind=i_kind),optional,intent(out):: nuse ! no. 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 + class(obsnode), pointer, optional, intent(in):: leadnode + + character(len=*),parameter:: myname_=myname//"::lcount_" + class(obsnode), pointer:: inode + integer(i_kind):: nuse_ + integer(kind=i_kind),dimension(2) :: 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) + if(.not.recount_) recount_ = checksum_ + + if(present(ksum)) then + ALWAYS_ASSERT(size(ksum)==size(kprev)) + endif + + if(.not.(luseonly_.or.recount_)) then + lobs_=headll%n_alloc + + else + lobs_ = 0 + nuse_ = 0 + + if(checksum_) call checksum_init_(kprev,nooo=nooo,ndup=ndup,ksum=ksum) + + inode => lheadnode_(headll) + 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, & + knext=(/inode%idv,inode%iob/),nooo=nooo,ndup=ndup,ksum=ksum) + + inode => obsnode_next(inode) + enddo + if(present(nuse)) nuse=nuse_ + endif + +_EXIT_(myname_) + return +end function lcount_ + +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 + + integer(kind=i_kind):: k + 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_ + +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_ + +subroutine lsort_(headll,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 m_obsnode, only: obsnode_next + !use mpeu_util, only: die + implicit none + type(obsllist), intent(inout):: headll + integer(kind=i_kind),optional,intent(in):: itype,ibin + + character(len=*),parameter:: myname_=myname//'::lsort_' + class(obsnode),pointer:: pnode + integer(kind=i_kind),allocatable,dimension(:):: indx,idv_,iob_ + integer(kind=i_kind):: i,n + logical:: sorted + + type fptr_of_obsnode + class(obsnode),pointer:: ptr + end type fptr_of_obsnode + type(fptr_of_obsnode),allocatable,dimension(:):: lookup +_ENTRY_(myname_) +!_timer_on_(myname_) +! call timer_ini(myname_) + + call lchecksum_(headll,itype=itype,ibin=ibin,sorted=sorted) + if(sorted) then + _EXIT_(myname_) + return + endif + + n=lsize_(headll) + + allocate(lookup(n)) + allocate(indx(n),idv_(n),iob_(n)) + + ! Loop over the linked-list, to get keys. + i=0 + pnode => lheadnode_(headll) + do while(associated(pnode)) + i=i+1 + if(i<=n) then + lookup(i)%ptr => pnode + idv_(i) = pnode%idv + iob_(i) = pnode%iob + endif + pnode => obsnode_next(pnode) + enddo + + ASSERT(i==n) + + ! sort %lookup(1:n), by its (idv,iob) values + call indexset (indx) + call indexsort(indx,iob_) + call indexsort(indx,idv_) + lookup(1:n) = lookup(indx(1:n)) + + deallocate(indx,idv_,iob_) + + ! Rebuild the linked-list from lookup(1:n)%ptr + headll%n_alloc = 0 + headll%head => null() + headll%tail => null() + + ! rebuild the list according to the sorted table + do i=1,n + call lappendnode_(headll,lookup(i)%ptr) + enddo + ASSERT(n==headll%n_alloc) + if(associated(headll%tail)) then + ASSERT(.not.associated(headll%tail%llpoint)) + endif + + ! discard the table + deallocate(lookup) + + call lchecksum_(headll,itype=itype,ibin=ibin,sorted=sorted) + if(.not.sorted) then + call perr(myname_,'failed post-sorting lchecksum_(), 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_ + +function alloc_nodecreate_(mold) result(ptr_) +!-- allocate() + init() + implicit none + class(obsnode),pointer:: ptr_ + class(obsnode),target,intent(in):: mold + allocate(ptr_,mold=mold) + call ptr_%init() + return +end function alloc_nodecreate_ + +subroutine nodedestroy_(node) +!-- clean() + deallocate() + use m_obsnode, only: obsnode_type => obsnode_mytype + implicit none + class(obsnode),pointer,intent(inout):: node + character(len=*),parameter:: myname_=myname//'::nodedestroy_' + integer(i_kind):: ier + if(associated(node)) then + call node%clean() + deallocate(node,stat=ier) + if(ier/=0) then + call perr(myname_,'can not deallocate(node), stat =',ier) + call perr(myname_,' obsnode_type(node) =',obsnode_type(node)) + call die(myname_) + endif + endif + return +end subroutine nodedestroy_ + +subroutine obsheader_read_(anode,iunit,iobs,itype,istat) +!-- read header of some type + use m_obsnode, only: obsnode + implicit none + class(obsnode) ,intent(in ):: anode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: iobs,itype + integer(i_kind),intent(out):: istat + call anode%headerread(iunit,iobs,itype,istat) +end subroutine obsheader_read_ + +subroutine obsheader_write_(anode,junit,mobs,mtype,istat) +!-- write header of some type + use m_obsnode, only: obsnode + implicit none + class(obsnode) ,intent(in ):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs,mtype + integer(i_kind),intent(out):: istat + call anode%headerwrite(junit,mobs,mtype,istat) +end subroutine obsheader_write_ +end module m_obsllist diff --git a/src/gsi/m_obsnode.F90 b/src/gsi/m_obsnode.F90 new file mode 100644 index 0000000000..defd300b90 --- /dev/null +++ b/src/gsi/m_obsnode.F90 @@ -0,0 +1,753 @@ +module m_obsnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2015-01-12 +! +! abstract: basic obsnode functionalities interfacing the distributed grid +! +! program history log: +! 2015-01-12 j guo - added this document block. +! 2016-05-18 j guo - finished its 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 kinds, only: i_kind,r_kind + use mpeu_util, only: tell,perr,die + use mpeu_util, only: assert_ + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + implicit none + private ! except + public:: obsnode ! data structure + + type, abstract:: obsnode + ! private + + ! - Being not "private", type(obsnode) allowes its type extentions + ! to access its components without additional interfaces. + ! - On the other hand, by turning private on, one can use the + ! compiler to report where the components of this type have been + ! used. + + class(obsnode),pointer :: llpoint => null() + + logical :: luse =.false. ! flag indicating if ob is used in pen. + real(r_kind) :: time = 0._r_kind ! observation time in sec, relative to the time window + real(r_kind) :: elat = 0._r_kind ! earth lat-lon for redistribution + real(r_kind) :: elon = 0._r_kind ! earth lat-lon for redistribution + + integer(i_kind) :: idv =-1 ! device id + integer(i_kind) :: iob =-1 ! initial obs sequential id + +#ifdef _TO_DO_ + integer(i_kind):: nprof ! count of corresponding profile locations + integer(i_kind):: idspl ! cross referencing index to profile locations + ! given i-th observation, corresponding profile + ! is block ([]%idspl+1 : []%idspl+[]%nprof) +#endif + contains + + !----------- overrideable procedures ----------------------------------- + procedure, nopass:: headerread => obsheader_read_ ! read a header + procedure, nopass:: headerwrite => obsheader_write_ ! write a header + + procedure:: init => init_ ! initialize a node + procedure:: clean => clean_ ! clean a node + + !----------- procedures must be defined by extensions ------------------ + procedure(intrfc_mytype_ ),nopass,deferred:: mytype ! return my type name + procedure(intrfc_sethop_ ), deferred:: sethop ! re-construct H + procedure(intrfc_xread_ ), deferred:: xread ! read extensions + procedure(intrfc_xwrite_ ), deferred:: xwrite ! write extensions + procedure(intrfc_isvalid_), deferred:: isvalid ! validate extensions + + procedure(intrfc_gettlddp_), deferred:: gettlddp ! (tlddp,nob)=(sum(%tld*%tld),sum(1) + !--------- non_overrideable procedures are implemented statically ------ + end type obsnode + +!-- module procedures, such as base-specific operations + + public:: obsnode_clean + interface obsnode_clean; module procedure deepclean_; end interface + + ! nodes operations + public:: obsnode_next ! nextnode => obsnode_next (thisnode) + public:: obsnode_append ! call obsnode_append(thisnode,targetnode) + + interface obsnode_next ; module procedure next_ ; end interface + interface obsnode_append; module procedure append_; end interface + + ! Getters-and-setters + public:: obsnode_islocal ! is anode local? -- obsnode_islocal(anode) + public:: obsnode_isluse ! is anode luse? -- obsnode_isluse(anode) + public:: obsnode_setluse ! set anode%luse. -- call obsnode_setluse(anode) + + interface obsnode_islocal; module procedure islocal_ ; end interface + interface obsnode_isluse ; module procedure isluse_ ; end interface + interface obsnode_setluse; module procedure setluse_ ; end interface + +!-- module procedures, requiring base-specific operations + + ! reader-and-writer + public:: obsnode_read ! call obsnode_read(anode, ...) + public:: obsnode_write ! call obsnode_write(anode, ...) + + interface obsnode_read ; module procedure read_ ; end interface + interface obsnode_write ; module procedure write_ ; end interface + + public:: obsnode_show ! call obsnode_show(anode) + interface obsnode_show ; module procedure show_ ; end interface + + public:: obsnode_mytype ! call obsnode_type(anode) + interface obsnode_mytype ; module procedure nodetype_ ; end interface + + abstract interface + subroutine intrfc_xread_(anode,iunit,istat,diaglookup,skip) + use kinds,only: i_kind + use m_obsdiagnode, only: obs_diags + import:: obsnode + implicit none + class(obsnode), intent(inout):: anode + integer(kind=i_kind), intent(in ):: iunit + integer(kind=i_kind), intent(out):: istat + type(obs_diags) , intent(in ):: diaglookup + logical,optional , intent(in ):: skip + end subroutine intrfc_xread_ + end interface + + abstract interface + subroutine intrfc_xwrite_(anode,junit,jstat) + use kinds,only: i_kind + import:: obsnode + implicit none + class(obsnode), intent(in):: anode + integer(kind=i_kind), intent(in ):: junit + integer(kind=i_kind), intent(out):: jstat + end subroutine intrfc_xwrite_ + end interface + + abstract interface + function intrfc_isvalid_(anode) result(isvalid_) + import:: obsnode + implicit none + logical:: isvalid_ + class(obsnode), intent(in):: anode + end function intrfc_isvalid_ + end interface + + abstract interface + subroutine intrfc_sethop_(anode) + use kinds, only: r_kind + import:: obsnode + implicit none + class(obsnode), intent(inout):: anode + end subroutine intrfc_sethop_ + end interface + + abstract interface + function intrfc_mytype_() + import:: obsnode + implicit none + character(len=:),allocatable:: intrfc_mytype_ + end function intrfc_mytype_ + end interface + + abstract interface + pure subroutine intrfc_gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: i_kind,r_kind + import:: obsnode + implicit none + class(obsnode),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 + end subroutine intrfc_gettlddp_ + end interface + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='m_obsnode' + +#include "mytrace.H" +#include "myassert.H" + +contains +function next_(anode) result(here_) +!-- associate to thisnode%llpoint. + implicit none + class(obsnode),pointer:: here_ + class(obsnode),target,intent(in):: anode + + character(len=*),parameter :: myname_=myname//'::next_' +_ENTRY_(myname_) + !!! trying to go next on a null reference is a serious logical error. + here_ => anode%llpoint +_EXIT_(myname_) + return +end function next_ + +subroutine append_(thisnode,targetnode,follow) +!-- append targetnode to thisnode%llpoint, or thisnode if .not.associated(thisnode) + implicit none + class(obsnode),pointer ,intent(inout):: thisnode + class(obsnode),pointer ,intent(in ):: targetnode + logical ,optional,intent(in):: follow ! Follow targetnode%llpoint to its last node. + ! The default is to nullify(thisnode%llpoint) + + character(len=*),parameter:: myname_=myname//"::append_" + logical:: follow_ +_ENTRY_(myname_) + ASSERT(associated(targetnode)) ! verify for any exception. + + follow_=.false. + if(present(follow)) follow_=follow + + if(.not.associated(thisnode)) then + thisnode => targetnode ! as the first node + + else + thisnode%llpoint => targetnode ! as an additional node + thisnode => thisnode%llpoint + + endif + + if(follow_) then + ! Follow thisnode to thisnode%llpoint, till its end, as targetnode is a + ! valid linked-list. The risk is the possibility of some circular + ! association, evenif both linked-lists, thisnode and targetnode are given + ! clean. + + do while(associated(thisnode%llpoint)) + ASSERT(.not.associated(thisnode%llpoint,targetnode)) + ! This assertion tries to identify possible circular association between + ! linked-list::thisnode and linked-list::targetnode. + + thisnode => thisnode%llpoint + enddo + + else + ! Nullify(thisnode%llpoint) to avoid any possibility of circular + ! association. Note this action will touch the input target argument + ! (targetnode) indirectly. + + thisnode%llpoint => null() + endif +_EXIT_(myname_) + return +end subroutine append_ + +function islocal_(anode) +!$$$ subprogram documentation block +! . . . . +! subprogram: islocal_ +! prgmmr: J. Guo +! +! abstract: check if this node is for the local grid partition. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 mpimod, only: mype + use m_cvgridlookup, only: cvgridlookup_islocal + implicit none + logical:: islocal_ + class(obsnode),intent(in):: anode + character(len=*),parameter:: myname_=myname//'::islocal_' +_ENTRY_(myname_) + islocal_=cvgridlookup_islocal(anode%elat,anode%elon,mype) +_EXIT_(myname_) + return +end function islocal_ + +function isluse_(anode) +!$$$ subprogram documentation block +! . . . . +! subprogram: isluse_ +! prgmmr: J. Guo +! +! abstract: check the %luse value of this node +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + logical:: isluse_ + class(obsnode),intent(in):: anode + character(len=*),parameter:: myname_=myname//'::isluse_' +_ENTRY_(myname_) + isluse_=anode%luse +_EXIT_(myname_) + return +end function isluse_ + +subroutine setluse_(anode) +!$$$ subprogram documentation block +! . . . . +! subprogram: lsummary_ +! prgmmr: J. Guo +! +! abstract: set %luse value for locally-owned node. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 mpimod, only: mype + use m_cvgridlookup, only: cvgridlookup_isluse + implicit none + class(obsnode),intent(inout):: anode + character(len=*),parameter:: myname_=myname//'::setluse_' +_ENTRY_(myname_) + anode%luse = cvgridlookup_isluse(anode%elat, anode%elon, mype) +_EXIT_(myname_) + return +end subroutine setluse_ + +!=================================================================== +! Routines below are default code to be used, if they are not override +! by the code invoked this include-file. +subroutine obsheader_read_(iunit,mobs,jread,istat) +!$$$ subprogram documentation block +! . . . . +! subprogram: obsheader_read_ +! prgmmr: J. Guo +! +! abstract: read the jtype-block header record. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + 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_' +_ENTRY_(myname_) + read(iunit,iostat=istat) mobs,jread +_EXIT_(myname_) + return +end subroutine obsheader_read_ + +subroutine obsheader_write_(junit,mobs,jwrite,jstat) +!$$$ subprogram documentation block +! . . . . +! subprogram: obsheader_write_ +! prgmmr: J. Guo +! +! abstract: write the jtype-block header record. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + 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 +_EXIT_(myname_) + return +end subroutine obsheader_write_ + +subroutine init_(anode) +!$$$ subprogram documentation block +! . . . . +! subprogram: init_ +! prgmmr: J. Guo +! +! abstract: allocate a node. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + class(obsnode),intent(out):: anode + + character(len=*),parameter:: myname_=myname//'::init_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',anode%mytype()) + anode%llpoint => null() + anode%luse = .false. + anode%time = 0._r_kind + anode%elat = 0._r_kind + anode%elon = 0._r_kind + anode%idv =-1 + anode%iob =-1 +_EXIT_(myname_) + return +end subroutine init_ + +subroutine clean_(anode) +!$$$ subprogram documentation block +! . . . . +! subprogram: clean_ +! prgmmr: J. Guo +! +! abstract: a shallow node clean +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + class(obsnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',anode%mytype()) + call anode%init() +_EXIT_(myname_) + return +end subroutine clean_ + +subroutine deepclean_(anode,deep,depth,stat) +!$$$ subprogram documentation block +! . . . . +! subprogram: subroutine deepclean_ +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-04-11 +! +! abstract: a deep node clean +! +! program history log: +! 2018-04-11 j guo - added this document block +! +! 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 + + implicit none + class(obsnode ),pointer ,intent(inout):: anode + logical ,optional,intent(in ):: deep ! with deep=.true., the full + ! linked-list headed by anode + ! will be "deep" cleaned. + integer(i_kind),optional,intent(out):: depth ! depth of deep-cleaned nodes at + ! the return. zero is expected + ! unless in an error. + integer(i_kind),optional,intent(out):: stat ! status return. + + character(len=*),parameter:: myname_=myname//'::deepclean_' + integer(i_kind):: ier,depth_ + logical:: deep_ + + if(present(depth)) depth=0 + if(present(stat )) stat=0 + + if(.not.associated(anode)) return + + deep_=.false. + if(present(deep )) deep_=deep + + if(deep_) then + depth_=0 + call recurs_nodeclean_(anode,depth_,ier) + if(present(depth)) depth=depth_ + + if(ier/=0) then + call perr(myname_,'recurs_nodeclean_(), stat =',ier) + call perr(myname_,' depth =',depth_) + call perr(myname_,' anode%mytype() =',nodetype_(anode)) + if(.not.present(stat)) call die(myname_) + stat=ier + return + endif + + else + ! Full-clean anode itself, but not %llpoint. This includes any dynamic + ! component of anode defined in its type/endtype block. + call anode%clean() + endif + + return +end subroutine deepclean_ + +recursive subroutine recurs_nodeclean_(anode,depth,stat) + implicit none + class(obsnode),pointer,intent(inout):: anode + ! This routine intends to fully erase the contents of argument anode, + ! but not the storage of it. A target attribute is used to prevent any + ! attempt to deallocate. Also see step (2) and (4) below. + integer(i_kind),intent(inout):: depth + integer(i_kind),intent( out):: stat + + character(len=*),parameter:: myname_=myname//"::recurs_nodeclean_" + + stat=0 + if(associated(anode)) then + + if(associated(anode%llpoint)) then + depth=depth+1 + + ! (1) deep-clean the target of %llpoint, a level deeper than anode. + + call recurs_nodeclean_(anode%llpoint,depth,stat) + if(stat/=0) return + + ! (2) deallocate %llpoint to release the memory associated with it. This is + ! in concert with step (4) below. + + deallocate(anode%llpoint,stat=stat) + if(stat/=0) then + call perr(myname_,"deallocate(anode%llpoint), stat =",stat) + call perr(myname_,' depth =',depth) + return + endif + + depth=depth-1 + endif + + ! (3) full-clean anode itself other than %llpoint, including any its dynamic + ! component defined in its type/endtype block. + + call anode%clean() + + ! (4) memory storage of anode itself is NOT expected to be deallocated. + ! This is in concert with step (2) above. + endif + return +end subroutine recurs_nodeclean_ + +subroutine read_(anode,iunit,istat,redistr,diaglookup) +!$$$ subprogram documentation block +! . . . . +! subprogram: read_ +! prgmmr: J. Guo +! +! abstract: read the input for a node. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 m_obsdiagnode, only: obsdiaglookup_locate + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + implicit none + class(obsnode),intent(inout):: anode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + logical ,intent(in ):: redistr + type(obs_diags),intent(in ):: diaglookup + + character(len=*),parameter:: myname_=myname//'::read_' + integer(i_kind):: ier +_ENTRY_(myname_) + + istat=0 + read(iunit,iostat=ier) anode%luse,anode%time,anode%elat,anode%elon, & + !anode%dlat,anode%dlon, & + anode%idv ,anode%iob + if(ier/=0) then + call perr(myname_,'read(%(luse,time,elat,elon,...)), iostat =',ier) + istat=-1 + _EXIT_(myname_) + return + endif + + istat=1 ! Now a complete xread(anode) is expected. + if(redistr) then ! Or additional conditions must be considered. + istat=0 ! A complete xread(anode) is not expected, unless + if(anode%luse) then ! ... .and. ... + if(islocal_(anode)) istat=1 + endif + endif + + call anode%xread(iunit,ier,diaglookup,skip=istat==0) + if(ier/=0) then + call perr(myname_,'anode%xread(), iostat =',ier) + call perr(myname_,' skip =',istat==0) + call perr(myname_,' istat =',istat) + istat=-2 + _EXIT_(myname_) + return + endif + +_EXIT_(myname_) + return +end subroutine read_ + +subroutine write_(anode,junit,jstat) + implicit none +!$$$ subprogram documentation block +! . . . . +! subprogram: write_ +! prgmmr: J. Guo +! +! abstract: write a node for output. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! input argument list: (see Fortran declarations below) +! +! output argument list: (see Fortran declarations below) +! +! attributes: +! language: f90/f95/f2003/f2008 +! machine: +! +!$$$ end documentation block + class(obsnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::write_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) anode%luse,anode%time,anode%elat,anode%elon, & + anode%idv,anode%iob + if(jstat/=0) then + call perr(myname_,'write(%(luse,elat,elon,...)), jstat =',jstat) + _EXIT_(myname_) + return + endif + + call anode%xwrite(junit,jstat) + if (jstat/=0) then + call perr(myname_,'anode%xwrite(), jstat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine write_ + +subroutine show_(anode,iob) +!$$$ subprogram documentation block +! . . . . +! subprogram: show_ +! prgmmr: J. Guo +! +! abstract: show selected obsnode data. +! +! program history log: +! 2015-01-12 guo - constructed for generic obsnode +! +! 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 + implicit none + class(obsnode),intent(inout):: anode + integer(i_kind),intent(in ):: iob + + character(len=*),parameter:: myname_=myname//'::show_' + logical:: isvalid_ +_ENTRY_(myname_) + isvalid_=anode%isvalid() + write(stdout,"(2a,3i4,2x,2l1,3f8.2)") myname,":: iob,%(idv,iob,luse,vald,time,elat,elon) =", & + iob,anode%idv,anode%iob,anode%luse,isvalid_,anode%time,anode%elat,anode%elon +_EXIT_(myname_) + return +end subroutine show_ + +function nodetype_(anode) +!-- Return its type information, even when the argument is a null. + implicit none + character(len=:),allocatable:: nodetype_ + class(obsnode),pointer,intent(in):: anode + nodetype_=".null.[obsnode]" + if(associated(anode)) nodetype_=anode%mytype() +end function nodetype_ + +end module m_obsnode diff --git a/src/gsi/m_obsnodetypemanager.F90 b/src/gsi/m_obsnodetypemanager.F90 new file mode 100644 index 0000000000..64f4a3e663 --- /dev/null +++ b/src/gsi/m_obsnodetypemanager.F90 @@ -0,0 +1,453 @@ +module m_obsnodetypemanager +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_obsnodetypemanager +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2015-08-13 +! +! abstract: obsnode type manager, as an enumerated type molder. +! +! program history log: +! 2015-08-13 j guo - added this document block. +! 2016-05-18 j guo - finished its initial polymorphic implementation, +! with total 33 obs-types. +! 2018-01-23 k apodaca - add a new observation type i.e. lightning (light) +! suitable for the goes/glm instrument +! +! 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_psnode , only: psnode + use m_tnode , only: tnode + use m_wnode , only: wnode + use m_qnode , only: qnode + use m_spdnode , only: spdnode + use m_rwnode , only: rwnode + use m_dwnode , only: dwnode + use m_sstnode , only: sstnode + use m_pwnode , only: pwnode + use m_pcpnode , only: pcpnode + use m_oznode , only: oznode + use m_o3lnode , only: o3lnode + use m_gpsnode , only: gpsnode + use m_radnode , only: radnode + use m_tcpnode , only: tcpnode + use m_lagnode , only: lagnode + use m_colvknode, only: colvknode + use m_aeronode , only: aeronode + use m_aerolnode, only: aerolnode + use m_pm2_5node, only: pm2_5node + use m_gustnode , only: gustnode + use m_visnode , only: visnode + use m_pblhnode , only: pblhnode + + use m_wspd10mnode, only: wspd10mnode + use m_uwnd10mnode, only: uwnd10mnode + use m_vwnd10mnode, only: vwnd10mnode + + use m_td2mnode , only: td2mnode + use m_mxtmnode , only: mxtmnode + use m_mitmnode , only: mitmnode + use m_pmslnode , only: pmslnode + use m_howvnode , only: howvnode + use m_tcamtnode, only: tcamtnode + use m_lcbasnode, only: lcbasnode + use m_pm10node , only: pm10node + use m_cldchnode, only: cldchnode + + use m_swcpnode , only: swcpnode + use m_lwcpnode , only: lwcpnode + + use m_lightnode, only: lightnode + use m_dbznode , only: dbznode + + use kinds, only: i_kind + use m_obsnode, only: obsnode + use mpeu_util, only: perr,die + + implicit none + private ! except + + public:: obsnodetype_undef + public:: obsnodetype_lbound + public:: obsnodetype_ubound + public:: obsnodetype_count + + public:: iobsnode_kind + public:: iobsnode_ps + public:: iobsnode_t + public:: iobsnode_w + public:: iobsnode_q + public:: iobsnode_spd + public:: iobsnode_rw + public:: iobsnode_dw + public:: iobsnode_sst + public:: iobsnode_pw + public:: iobsnode_pcp + public:: iobsnode_oz + public:: iobsnode_o3l + public:: iobsnode_gps + public:: iobsnode_rad + public:: iobsnode_tcp + public:: iobsnode_lag + public:: iobsnode_colvk + public:: iobsnode_aero + public:: iobsnode_aerol + public:: iobsnode_pm2_5 + public:: iobsnode_gust + public:: iobsnode_vis + public:: iobsnode_pblh + public:: iobsnode_wspd10m + public:: iobsnode_uwnd10m + public:: iobsnode_vwnd10m + public:: iobsnode_td2m + public:: iobsnode_mxtm + public:: iobsnode_mitm + public:: iobsnode_pmsl + public:: iobsnode_howv + public:: iobsnode_tcamt + public:: iobsnode_lcbas + public:: iobsnode_pm10 + public:: iobsnode_cldch + public:: iobsnode_swcp + public:: iobsnode_lwcp + + public:: iobsnode_light + public:: iobsnode_dbz + + public :: obsnode_typemold + public :: obsnode_typeindex + + interface obsnode_typemold; module procedure & + index2vmold_, & + vname2vmold_ + end interface + interface obsnode_typeindex; module procedure & + vmold2index_, & + vname2index_ + end interface + + type(psnode ), target, save:: ps_mold + type(tnode ), target, save:: t_mold + type(wnode ), target, save:: w_mold + type(qnode ), target, save:: q_mold + type(spdnode ), target, save:: spd_mold + type(rwnode ), target, save:: rw_mold + type(dwnode ), target, save:: dw_mold + type(sstnode ), target, save:: sst_mold + type(pwnode ), target, save:: pw_mold + type(pcpnode ), target, save:: pcp_mold + type(oznode ), target, save:: oz_mold + type(o3lnode ), target, save:: o3l_mold + type(gpsnode ), target, save:: gps_mold + type(radnode ), target, save:: rad_mold + type(tcpnode ), target, save:: tcp_mold + type(lagnode ), target, save:: lag_mold + type(colvknode), target, save:: colvk_mold + type(aeronode ), target, save:: aero_mold + type(aerolnode), target, save:: aerol_mold + type(pm2_5node), target, save:: pm2_5_mold + type(gustnode ), target, save:: gust_mold + type(visnode ), target, save:: vis_mold + type(pblhnode ), target, save:: pblh_mold + + type(wspd10mnode), target, save:: wspd10m_mold + type(uwnd10mnode), target, save:: uwnd10m_mold + type(vwnd10mnode), target, save:: vwnd10m_mold + + type( td2mnode), target, save:: td2m_mold + type( mxtmnode), target, save:: mxtm_mold + type( mitmnode), target, save:: mitm_mold + type( pmslnode), target, save:: pmsl_mold + type( howvnode), target, save:: howv_mold + type( tcamtnode), target, save:: tcamt_mold + type( lcbasnode), target, save:: lcbas_mold + type( pm10node), target, save:: pm10_mold + type( cldchnode), target, save:: cldch_mold + + type( swcpnode), target, save:: swcp_mold + type( lwcpnode), target, save:: lwcp_mold + type( lightnode), target, save:: light_mold + type( dbznode), target, save:: dbz_mold +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='m_obsnodetypemanager' + +! UseCase 1: configuration of a single mold +! +! use m_obsnodetypemanager, only: obsnode_typemold +! use m_psnode, only: i_psnode +! ... +! allocate(psllist%mold, source=obsnode_typemold(i_psnode)) +! or, for Fortran 2008 allocate() with mold= specifier +! allocate(psllist%mold, mold=obsnode_typemold(i_psnode)) +! +! UseCase 2: configuration of molds in an array +! +! use m_obsllist, only: obsllist_moldconfig +! use m_obsnodetypemanager, only: obsnode_typemold +! ... +! do jtype=lbound(obsdiags,2),ubound(obsdiags,2) +! do ibin=lbound(obsdiags,1),ubound(obsdiags,1) +! call obsllist_moldconfig(obsdiags(ibin,jtype),mold=obsnode_typemold(jtype)) +! enddo +! enddo +! + + enum, bind(C) + enumerator:: iobsnode_zero_ = 0 + + enumerator:: iobsnode_ps + enumerator:: iobsnode_t + enumerator:: iobsnode_w + enumerator:: iobsnode_q + enumerator:: iobsnode_spd + enumerator:: iobsnode_rw + enumerator:: iobsnode_dw + enumerator:: iobsnode_sst + enumerator:: iobsnode_pw + enumerator:: iobsnode_pcp + enumerator:: iobsnode_oz + enumerator:: iobsnode_o3l + enumerator:: iobsnode_gps + enumerator:: iobsnode_rad + enumerator:: iobsnode_tcp + enumerator:: iobsnode_lag + enumerator:: iobsnode_colvk + enumerator:: iobsnode_aero + enumerator:: iobsnode_aerol + enumerator:: iobsnode_pm2_5 + enumerator:: iobsnode_gust + enumerator:: iobsnode_vis + enumerator:: iobsnode_pblh + enumerator:: iobsnode_wspd10m + enumerator:: iobsnode_uwnd10m + enumerator:: iobsnode_vwnd10m + enumerator:: iobsnode_td2m + enumerator:: iobsnode_mxtm + enumerator:: iobsnode_mitm + enumerator:: iobsnode_pmsl + enumerator:: iobsnode_howv + enumerator:: iobsnode_tcamt + enumerator:: iobsnode_lcbas + enumerator:: iobsnode_pm10 + enumerator:: iobsnode_cldch + enumerator:: iobsnode_swcp + enumerator:: iobsnode_lwcp + enumerator:: iobsnode_light + enumerator:: iobsnode_dbz + + enumerator:: iobsnode_extra_ + end enum + + integer(i_kind),parameter:: iobsnode_kind = kind(iobsnode_zero_) + + integer(iobsnode_kind),parameter:: obsnodetype_undef = -1_iobsnode_kind + integer(iobsnode_kind),parameter:: obsnodetype_lbound = iobsnode_zero_ +1 + integer(iobsnode_kind),parameter:: obsnodetype_ubound = iobsnode_extra_-1 + integer(iobsnode_kind),parameter:: obsnodetype_count = obsnodetype_ubound-obsnodetype_lbound+1 + +contains +function vname2index_(vname) result(index_) + use mpeu_util, only: lowercase + implicit none + integer(i_kind):: index_ + character(len=*),intent(in):: vname + character(len=len(vname)):: vname_ + vname_=lowercase(vname) + + index_=0 ! a default return value, if the given name is unknown. + select case(vname_) + case("ps" , "[psnode]"); index_ = iobsnode_ps + case("t" , "[tnode]"); index_ = iobsnode_t + case("w" , "[wnode]"); index_ = iobsnode_w + case("q" , "[qnode]"); index_ = iobsnode_q + case("spd" , "[spdnode]"); index_ = iobsnode_spd + case("rw" , "[rwnode]"); index_ = iobsnode_rw + case("dw" , "[dwnode]"); index_ = iobsnode_dw + case("sst" , "[sstnode]"); index_ = iobsnode_sst + case("pw" , "[pwnode]"); index_ = iobsnode_pw + case("pcp" , "[pcpnode]"); index_ = iobsnode_pcp + case("oz" , "[oznode]"); index_ = iobsnode_oz + case("o3l" , "[o3lnode]"); index_ = iobsnode_o3l + case("gps" , "[gpsnode]"); index_ = iobsnode_gps + case("rad" , "[radnode]"); index_ = iobsnode_rad + case("tcp" , "[tcpnode]"); index_ = iobsnode_tcp + case("lag" , "[lagnode]"); index_ = iobsnode_lag + case("colvk","[colvknode]"); index_ = iobsnode_colvk + case("aero" , "[aeronode]"); index_ = iobsnode_aero + case("aerol","[aerolnode]"); index_ = iobsnode_aerol + case("pm2_5","[pm2_5node]"); index_ = iobsnode_pm2_5 + case("gust" , "[gustnode]"); index_ = iobsnode_gust + case("vis" , "[visnode]"); index_ = iobsnode_vis + case("pblh" , "[pblhnode]"); index_ = iobsnode_pblh + + case("wspd10m", & + "[wspd10mnode]"); index_ = iobsnode_wspd10m + case("uwnd10m", & + "[uwnd10mnode]"); index_ = iobsnode_uwnd10m + case("vwnd10m", & + "[vwnd10mnode]"); index_ = iobsnode_vwnd10m + + case("td2m" , "[td2mnode]"); index_ = iobsnode_td2m + case("mxtm" , "[mxtmnode]"); index_ = iobsnode_mxtm + case("mitm" , "[mitmnode]"); index_ = iobsnode_mitm + case("pmsl" , "[pmslnode]"); index_ = iobsnode_pmsl + case("howv" , "[howvnode]"); index_ = iobsnode_howv + case("tcamt","[tcamtnode]"); index_ = iobsnode_tcamt + case("lcbas","[lcbasnode]"); index_ = iobsnode_lcbas + + case("pm10" , "[pm10node]"); index_ = iobsnode_pm10 + case("cldch","[cldchnode]"); index_ = iobsnode_cldch + + case("swcp" , "[swcpnode]"); index_ = iobsnode_swcp + case("lwcp" , "[lwcpnode]"); index_ = iobsnode_lwcp + + case("light","[lightnode]"); index_ = iobsnode_light + case("dbz" , "[dbznode]"); index_ = iobsnode_dbz + + end select +end function vname2index_ + +function vmold2index_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(obsnode),target,intent(in):: mold + + index_=vname2index_(mold%mytype()) +end function vmold2index_ + +function vmold2index_select_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(obsnode),target,intent(in):: mold + + index_=0 + select type(mold) + type is( psnode); index_ = iobsnode_ps + type is( tnode); index_ = iobsnode_t + type is( wnode); index_ = iobsnode_w + type is( qnode); index_ = iobsnode_q + type is( spdnode); index_ = iobsnode_spd + type is( rwnode); index_ = iobsnode_rw + type is( dwnode); index_ = iobsnode_dw + type is( sstnode); index_ = iobsnode_sst + type is( pwnode); index_ = iobsnode_pw + type is( pcpnode); index_ = iobsnode_pcp + type is( oznode); index_ = iobsnode_oz + type is( o3lnode); index_ = iobsnode_o3l + type is( gpsnode); index_ = iobsnode_gps + type is( radnode); index_ = iobsnode_rad + type is( tcpnode); index_ = iobsnode_tcp + type is( lagnode); index_ = iobsnode_lag + type is(colvknode); index_ = iobsnode_colvk + type is( aeronode); index_ = iobsnode_aero + type is(aerolnode); index_ = iobsnode_aerol + type is(pm2_5node); index_ = iobsnode_pm2_5 + type is( gustnode); index_ = iobsnode_gust + type is( visnode); index_ = iobsnode_vis + type is( pblhnode); index_ = iobsnode_pblh + + type is(wspd10mnode); index_ = iobsnode_wspd10m + type is(uwnd10mnode); index_ = iobsnode_uwnd10m + type is(vwnd10mnode); index_ = iobsnode_vwnd10m + + type is( td2mnode); index_ = iobsnode_td2m + type is( mxtmnode); index_ = iobsnode_mxtm + type is( mitmnode); index_ = iobsnode_mitm + type is( pmslnode); index_ = iobsnode_pmsl + type is( howvnode); index_ = iobsnode_howv + type is(tcamtnode); index_ = iobsnode_tcamt + type is(lcbasnode); index_ = iobsnode_lcbas + + type is( pm10node); index_ = iobsnode_pm10 + type is(cldchnode); index_ = iobsnode_cldch + + type is( swcpnode); index_ = iobsnode_swcp + type is( lwcpnode); index_ = iobsnode_lwcp + + type is(lightnode); index_ = iobsnode_light + type is( dbznode); index_ = iobsnode_dbz + + end select +end function vmold2index_select_ + +function index2vmold_(i_obtype) result(obsmold_) + implicit none + class(obsnode),pointer:: obsmold_ + integer(kind=i_kind),intent(in):: i_obtype + + character(len=*),parameter:: myname_=myname//"::index2vmold_" + + obsmold_ => null() + select case(i_obtype) + case(iobsnode_ps ); obsmold_ => ps_mold + case(iobsnode_t ); obsmold_ => t_mold + case(iobsnode_w ); obsmold_ => w_mold + case(iobsnode_q ); obsmold_ => q_mold + case(iobsnode_spd ); obsmold_ => spd_mold + case(iobsnode_rw ); obsmold_ => rw_mold + case(iobsnode_dw ); obsmold_ => dw_mold + case(iobsnode_sst ); obsmold_ => sst_mold + case(iobsnode_pw ); obsmold_ => pw_mold + case(iobsnode_pcp ); obsmold_ => pcp_mold + case(iobsnode_oz ); obsmold_ => oz_mold + case(iobsnode_o3l ); obsmold_ => o3l_mold + case(iobsnode_gps ); obsmold_ => gps_mold + case(iobsnode_rad ); obsmold_ => rad_mold + case(iobsnode_tcp ); obsmold_ => tcp_mold + case(iobsnode_lag ); obsmold_ => lag_mold + case(iobsnode_colvk); obsmold_ => colvk_mold + case(iobsnode_aero ); obsmold_ => aero_mold + case(iobsnode_aerol); obsmold_ => aerol_mold + case(iobsnode_pm2_5); obsmold_ => pm2_5_mold + case(iobsnode_gust ); obsmold_ => gust_mold + case(iobsnode_vis ); obsmold_ => vis_mold + case(iobsnode_pblh ); obsmold_ => pblh_mold + + case(iobsnode_wspd10m); obsmold_ => wspd10m_mold + case(iobsnode_uwnd10m); obsmold_ => uwnd10m_mold + case(iobsnode_vwnd10m); obsmold_ => vwnd10m_mold + + case(iobsnode_td2m ); obsmold_ => td2m_mold + case(iobsnode_mxtm ); obsmold_ => mxtm_mold + case(iobsnode_mitm ); obsmold_ => mitm_mold + case(iobsnode_pmsl ); obsmold_ => pmsl_mold + case(iobsnode_howv ); obsmold_ => howv_mold + case(iobsnode_tcamt); obsmold_ => tcamt_mold + case(iobsnode_lcbas); obsmold_ => lcbas_mold + + case(iobsnode_pm10 ); obsmold_ => pm10_mold + case(iobsnode_cldch); obsmold_ => cldch_mold + + case(iobsnode_swcp ); obsmold_ => swcp_mold + case(iobsnode_lwcp ); obsmold_ => lwcp_mold + + case(iobsnode_light); obsmold_ => light_mold + case(iobsnode_dbz); obsmold_ => dbz_mold + + end select +end function index2vmold_ + +function vname2vmold_(vname) result(obsmold_) + implicit none + class(obsnode),pointer:: obsmold_ + character(len=*),intent(in):: vname + + character(len=*),parameter:: myname_=myname//"::vname2vmold_" + integer(kind=i_kind):: i_obtype + + i_obtype=vname2index_(vname) + obsmold_ => index2vmold_(i_obtype) +end function vname2vmold_ + +end module m_obsnodetypemanager diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index d3b4a10323..8ec4857c9c 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -5,7 +5,7 @@ module mod_fv3_lola ! prgmmr: parrish ! ! abstract: This module contains routines to interpolate from a single -! fv3 D grid tile to a rotated lat-lon analysis grid which completely +! fv3 d grid tile to a rotated lat-lon analysis grid which completely ! covers the fv3 tile. Points beyond the fv3 tile are ! filled with nearest fv3 edge values, but have no actual ! impact on the analysis. @@ -34,7 +34,7 @@ module mod_fv3_lola ! !$$$ end documentation block -! DIAGRAM: D-Grid layout: +! Diagram: d-grid layout: ! ! 1 nx ! . . (U,H) @@ -42,21 +42,21 @@ module mod_fv3_lola ! 1 nx +1 ! . . (V) -! U U U U U U + ny +1 (for U) -! V H V H V H V H V H V H V + ny (for V,H) -! U U U U U U xh(i) = i dx=1 -! V H V H V H V H V H V H V xu(i) = i -! U U U U U U xv(i) = i-0.5 -! V H V H V H V H V H V H V -! U U U U U U yh(j) = j dy=1 -! V H V H V H V H V H V H V yu(j) = j-0.5 -! U U U U U U yv(j) = j -! V H V H V H V H V H V H V -! U U U U U U -! V H V H V H V H V H V H V + 1 (for V,H) -! U U U U U U + 1 (for U) - -! U(nx ,ny +1),V(nx +1,ny ),H(nx ,ny ) +! u u u u u u + ny +1 (for u) +! v h v h v h v h v h v h v + ny (for v,h) +! u u u u u u xh(i) = i dx=1 +! v h v h v h v h v h v h v xu(i) = i +! u u u u u u xv(i) = i-0.5 +! v h v h v h v h v h v h v +! u u u u u u yh(j) = j dy=1 +! v h v h v h v h v h v h v yu(j) = j-0.5 +! u u u u u u yv(j) = j +! v h v h v h v h v h v h v +! u u u u u u +! v h v h v h v h v h v h v + 1 (for v,h) +! u u u u u u + 1 (for u) + +! u(nx ,ny +1),v(nx +1,ny ),h(nx ,ny ) use kinds, only: r_kind,i_kind implicit none @@ -88,10 +88,10 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) ! ! program history log: ! 2017-05-02 parrish -! 2017-10-10 wu - 1. setup analysis A-grid, -! 2. compute/setup FV3 to A grid interpolation parameters -! 3. compute/setup A to FV3 grid interpolation parameters -! 4. setup weightings for wind conversion from FV3 to earth +! 2017-10-10 wu - 1. setup analysis a-grid, +! 2. compute/setup fv3 to a grid interpolation parameters +! 3. compute/setup A to fv3 grid interpolation parameters +! 4. setup weightings for wind conversion from fv3 to earth ! 2019-11-01 wu - add checks to present the mean longitude correctly to fix ! problem near lon=0 ! @@ -188,7 +188,7 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) centlon,centlat,nx,ny) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! compute analysis A-grid lats, lons +!! compute analysis a-grid lats, lons !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !--------------------------obtain analysis grid dimensions nxa,nya @@ -199,12 +199,12 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) if(mype==0) print *,'nlat,nlon=nya,nxa= ',nlat,nlon !--------------------------obtain analysis grid spacing - dlat=(maxval(gcrlat)-minval(gcrlat))/(ny-1) - dlon=(maxval(gcrlon)-minval(gcrlon))/(nx-1) + dlat=(maxval(gcrlat)-minval(gcrlat))/real((ny-1),r_kind) + dlon=(maxval(gcrlon)-minval(gcrlon))/real((nx-1),r_kind) adlat=dlat*grid_ratio_fv3_regional adlon=dlon*grid_ratio_fv3_regional -!-------setup analysis A-grid; find center of the domain +!-------setup analysis a-grid; find center of the domain nlonh=nlon/2 nlath=nlat/2 @@ -225,11 +225,11 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) endif ! -!-----setup analysis A-grid from center of the domain +!-----setup analysis a-grid from center of the domain ! allocate(rlat_in(nlat,nlon),rlon_in(nlat,nlon)) do j=1,nlon - alon=(j-nlonh)*adlon-clon + alon=real((j-nlonh),r_kind)*adlon-clon do i=1,nlat rlon_in(i,j)=alon enddo @@ -238,7 +238,7 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) do j=1,nlon do i=1,nlat - rlat_in(i,j)=(i-nlath)*adlat-clat + rlat_in(i,j)=real((i-nlath),r_kind)*adlat-clat enddo enddo @@ -318,15 +318,15 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) end do end do -!!!! define analysis A grid !!!!!!!!!!!!! +!!!! define analysis a grid !!!!!!!!!!!!! do j=1,nxa - xa_a(j)=(float(j-nlonh)-cx)*grid_ratio_fv3_regional + xa_a(j)=(real((j-nlonh),r_kind)-cx)*grid_ratio_fv3_regional end do do i=1,nya - ya_a(i)=(float(i-nlath)-cy)*grid_ratio_fv3_regional + ya_a(i)=(real((i-nlath),r_kind)-cy)*grid_ratio_fv3_regional end do -!!!!!compute fv3 to A grid interpolation parameters !!!!!!!!! +!!!!!compute fv3 to a grid interpolation parameters !!!!!!!!! allocate ( fv3dx(nxa,nya),fv3dx1(nxa,nya),fv3dy(nxa,nya),fv3dy1(nxa,nya) ) allocate ( fv3ix(nxa,nya),fv3ixp(nxa,nya),fv3jy(nxa,nya),fv3jyp(nxa,nya) ) allocate(yy(ny)) @@ -336,138 +336,138 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) ib1=1 do j=1,nya do i=1,nxa - do n=1,3 - gxa=xa_a(i) - if(gxa < xbh_b(1,jb1))then - gxa= 1 - else if(gxa > xbh_b(nx,jb1))then - gxa= nx - else - call grdcrd1(gxa,xbh_b(1,jb1),nx,1) - endif - ib2=ib1 - ib1=gxa - do jj=1,ny - yy(jj)=ybh_b(ib1,jj) - enddo - gya=ya_a(j) - if(gya < yy(1))then - gya= 1 - else if(gya > yy(ny))then - gya= ny - else - call grdcrd1(gya,yy,ny,1) - endif - jb2=jb1 - jb1=gya - - if((ib1 == ib2) .and. (jb1 == jb2)) exit - if(n==3 ) then + do n=1,3 + gxa=xa_a(i) + if(gxa < xbh_b(1,jb1))then + gxa= one + else if(gxa > xbh_b(nx,jb1))then + gxa= real(nx,r_kind) + else + call grdcrd1(gxa,xbh_b(1,jb1),nx,1) + endif + ib2=ib1 + ib1=gxa + do jj=1,ny + yy(jj)=ybh_b(ib1,jj) + enddo + gya=ya_a(j) + if(gya < yy(1))then + gya= one + else if(gya > yy(ny))then + gya= real(ny,r_kind) + else + call grdcrd1(gya,yy,ny,1) + endif + jb2=jb1 + jb1=gya + + if((ib1 == ib2) .and. (jb1 == jb2)) exit + if(n==3 ) then !!!!!!! if not converge, find the nearest corner point - d(1)=(xa_a(i)-xbh_b(ib1,jb1))**2+(ya_a(j)-ybh_b(ib1,jb1))**2 - d(2)=(xa_a(i)-xbh_b(ib1+1,jb1))**2+(ya_a(j)-ybh_b(ib1+1,jb1))**2 - d(3)=(xa_a(i)-xbh_b(ib1,jb1+1))**2+(ya_a(j)-ybh_b(ib1,jb1+1))**2 - d(4)=(xa_a(i)-xbh_b(ib1+1,jb1+1))**2+(ya_a(j)-ybh_b(ib1+1,jb1+1))**2 - kk=1 - do k=2,4 - if(d(k) xa_a(nxa))then - gxa= nxa + gxa= real(nxa,r_kind) else call grdcrd1(gxa,xa_a,nxa,1) endif @@ -483,9 +483,9 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) do j=1,ny gya=ybh_b(i,j) if(gya < ya_a(1))then - gya= 1 + gya= one else if(gya > ya_a(nya))then - gya= nya + gya= real(nya,r_kind) else call grdcrd1(gya,ya_a,nya,1) endif @@ -498,7 +498,7 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! find coefficients for wind conversion btw FV3 & earth +!!! find coefficients for wind conversion btw fv3 & earth !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocate ( cangu(nx,ny+1),sangu(nx,ny+1),cangv(nx+1,ny),sangv(nx+1,ny) ) @@ -513,7 +513,7 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) enddo enddo -! 2 find angles to E-W and N-S for U edges +! 2 find angles to e-w and n-s for u edges sq180=180._r_kind**2 do j=1,ny+1 do i=1,nx @@ -542,7 +542,7 @@ subroutine generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) enddo enddo -! 3 find angles to E-W and N-S for V edges +! 3 find angles to e-w and n-s for v edges do j=1,ny do i=1,nx+1 rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) @@ -574,7 +574,7 @@ subroutine earthuv2fv3(u,v,nx,ny,u_out,v_out) ! subprogram: earthuv2fv3 ! prgmmr: wu 2017-06-15 ! -! abstract: project earth UV to fv3 UV and interpolate to edge of the cell +! abstract: project earth uv to fv3 uv and interpolate to edge of the cell ! ! program history log: ! @@ -633,7 +633,7 @@ subroutine fv3uv2earth(u,v,nx,ny,u_out,v_out) ! subprogram: fv3uv2earth ! prgmmr: wu 2017-06-15 ! -! abstract: project fv3 UV to earth UV and interpolate to the center of the cells +! abstract: project fv3 uv to earth uv and interpolate to the center of the cells ! ! program history log: ! @@ -677,10 +677,10 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma) ! subprogram: fv3_h_to_ll ! prgmmr: wu 2017-05-30 ! -! abstract: interpolate from rotated fv3 grid to A grid. +! abstract: interpolate from rotated fv3 grid to a grid. ! Interpolation choices 1)bilinear both ways ! 2)inverse-distance weighting average -! reverse E-W and N-S directions & reverse i,j for output array a(nlat,nlon) +! reverse e-w and n-s directions & reverse i,j for output array a(nlat,nlon) ! ! program history log: ! @@ -711,7 +711,7 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma) integer(i_kind) i,j,ir,jr,mbp,nbp real(r_kind) b(nb,mb) -!!!!!!!!! reverse E-W and N-S +!!!!!!!!! reverse e-w and n-s mbp=mb+1 nbp=nb+1 do j=1,mb @@ -721,7 +721,7 @@ subroutine fv3_h_to_ll(b_in,a,nb,mb,na,ma) b(ir,jr)=b_in(i,j) end do end do -!!!!!!!!! interpolate to A grid & reverse ij for array a(lat,lon) +!!!!!!!!! interpolate to a grid & reverse ij for array a(lat,lon) if(bilinear)then ! bilinear interpolation do j=1,ma do i=1,na @@ -746,8 +746,8 @@ subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) ! subprogram: fv3_ll_to_h ! prgmmr: wu 2017-05-30 ! -! abstract: interpolate from analysis A grid to rotated fv3 grid. -! Interpolation is bilinear both ways. Reverse E-W and N-S and +! abstract: interpolate from analysis a grid to rotated fv3 grid. +! Interpolation is bilinear both ways. Reverse e-w and n-s and ! reverse i,j for output array b(nxb,nyb) ! ! program history log: @@ -780,7 +780,7 @@ subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) integer(i_kind) i,j,ir,jr,nybp,nxbp,ijr if(rev_flg)then -!!!!!!!!!! output in reverse E-W, N-S and reversed i,j !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!! output in reverse e-w, n-s and reversed i,j !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! nybp=nyb+1 nxbp=nxb+1 do i=1,nyb @@ -793,7 +793,7 @@ subroutine fv3_ll_to_h(a,b,nxa,nya,nxb,nyb,rev_flg) end do end do else -!!!!!!!!!! output order as input W-E S-N and (i:lat,j:lon) !!!!!!!!!!! +!!!!!!!!!! output order as input w-e s-n and (i:lat,j:lon) !!!!!!!!!!! do j=1,nxb ijr=(j-1)*nyb do i=1,nyb @@ -822,9 +822,9 @@ subroutine rotate2deg(rlon_in,rlat_in,rlon_out,rlat_out,rlon0,rlat0,nx,ny) ! ! Method is as follows: ! 1. define x,y,z coordinate system with origin at center of sphere, -! x intersecting sphere at 0 deg N, 0 deg E, -! y intersecting sphere at 0 deg N, 90 deg E, -! z intersecting sphere at 90 deg N (north pole). +! x intersecting sphere at 0 deg n, 0 deg e, +! y intersecting sphere at 0 deg n, 90 deg e, +! z intersecting sphere at 90 deg n (north pole). ! 4 steps: @@ -836,7 +836,7 @@ subroutine rotate2deg(rlon_in,rlat_in,rlon_out,rlat_out,rlon0,rlat0,nx,ny) ! 4. compute rlon_out, rlat_out from xtt,ytt,ztt -! This is the desired new orientation, where (0N, 0E) maps to point +! This is the desired new orientation, where (0n, 0e) maps to point ! (rlon0,rlat0) in original coordinate and the new equator is tangent to ! the original latitude circle rlat0 at original longitude rlon0. ! attributes: diff --git a/src/gsi/mod_nmmb_to_a.f90 b/src/gsi/mod_nmmb_to_a.f90 index 84dc84da89..a1c046fa37 100644 --- a/src/gsi/mod_nmmb_to_a.f90 +++ b/src/gsi/mod_nmmb_to_a.f90 @@ -5,14 +5,14 @@ module mod_nmmb_to_a ! prgmmr: parrish ! ! abstract: This module contains routines to interpolate from the nmmb b grid to analysis a grid -! which exactly covers either the H or V component of the nmmb grid, but optionally +! which exactly covers either the h or v component of the nmmb grid, but optionally ! at a coarser resolution. ! The resolution of the a grid is controlled by the variable grid_ratio_nmmb, which is ! an input variable to subroutine init_nmmb_to_a in this module. -! Because the B grid is actually two A grids staggered with respect to each other, one +! Because the b grid is actually two a grids staggered with respect to each other, one ! for mass variables, the other for wind variables, there is an input character variable -! nmmb_reference_grid, which if ="H", then uses H grid as reference for the analysis grid -! and similarly for the V grid. +! nmmb_reference_grid, which if ="H", then uses h grid as reference for the analysis grid +! and similarly for the v grid. ! ! program history log: ! 2009-08-06 lueken - added module doc block @@ -63,7 +63,7 @@ subroutine init_nmmb_to_a(nmmb_reference_grid,grid_ratio_nmmb,nxb_in,nyb_in) ! 2010-09-10 parrish, add more extensive description ! ! input argument list: -! nmmb_reference_grid - character variable, ="H" for H grid as reference, ="V" for V grid as reference +! nmmb_reference_grid - character variable, ="H" for h grid as reference, ="V" for v grid as reference ! grid_ratio_nmmb - analysis grid increment in nmmb grid units ! nxb_in,nyb_in - x and y dimensions of nmmb grid ! @@ -80,8 +80,8 @@ subroutine init_nmmb_to_a(nmmb_reference_grid,grid_ratio_nmmb,nxb_in,nyb_in) use constants, only: half,one,two implicit none - character(1) , intent(in ) :: nmmb_reference_grid ! ='H': use nmmb H grid as reference for analysis grid - ! ='V': use nmmb V grid as reference for analysis grid + character(1) , intent(in ) :: nmmb_reference_grid ! ='H': use nmmb h grid as reference for analysis grid + ! ='V': use nmmb v grid as reference for analysis grid real(r_kind) , intent(in ) :: grid_ratio_nmmb ! analysis grid increment in nmmb grid units integer(i_kind), intent(in ) :: nxb_in,nyb_in ! x and y dimensions of nmmb grid. @@ -106,52 +106,52 @@ subroutine init_nmmb_to_a(nmmb_reference_grid,grid_ratio_nmmb,nxb_in,nyb_in) allocate(ybh_a(nyb),ybh_b(nyb),ybv_a(nyb),ybv_b(nyb),ya_a(nya),ya_b(nya)) do j=1,nxb - xbh_b(j)=j - xbv_b(j)=j+half + xbh_b(j)=real(j,r_kind) + xbv_b(j)=real(j,r_kind)+half end do do j=1,nxa - xa_a(j)=j + xa_a(j)=real(j,r_kind) end do do i=1,nyb - ybh_b(i)=i - ybv_b(i)=i+half + ybh_b(i)=real(i,r_kind) + ybv_b(i)=real(i,r_kind)+half end do do i=1,nya - ya_a(i)=i + ya_a(i)=real(i,r_kind) end do if(nmmb_reference_grid=='H') then - ratio_x=(nxb-one)/(nxa-one) + ratio_x=(real(nxb,r_kind)-one)/(real(nxa,r_kind)-one) do j=1,nxa - xa_b(j)=one+(j-one)*ratio_x + xa_b(j)=one+(real(j,r_kind)-one)*ratio_x end do do j=1,nxb - xbh_a(j)=one+(j-one)/ratio_x - xbv_a(j)=one+(j-half)/ratio_x + xbh_a(j)=one+(real(j,r_kind)-one)/ratio_x + xbv_a(j)=one+(real(j,r_kind)-half)/ratio_x end do - ratio_y=(nyb-one)/(nya-one) + ratio_y=(real(nyb,r_kind)-one)/(real(nya,r_kind)-one) do i=1,nya - ya_b(i)=one+(i-one)*ratio_y + ya_b(i)=one+(real(i,r_kind)-one)*ratio_y end do do i=1,nyb - ybh_a(i)=one+(i-one)/ratio_y - ybv_a(i)=one+(i-half)/ratio_y + ybh_a(i)=one+(real(i,r_kind)-one)/ratio_y + ybv_a(i)=one+(real(i,r_kind)-half)/ratio_y end do else if(nmmb_reference_grid=='V') then - ratio_x=(nxb-two)/(nxa-one) + ratio_x=(real(nxb,r_kind)-two)/(real(nxa,r_kind)-one) do j=1,nxa - xa_b(j)=one+half+(j-one)*ratio_x + xa_b(j)=one+half+(real(j,r_kind)-one)*ratio_x end do do j=1,nxb - xbh_a(j)=one+(j-one-half)/ratio_x - xbv_a(j)=one+(j-one)/ratio_x + xbh_a(j)=one+(real(j,r_kind)-one-half)/ratio_x + xbv_a(j)=one+(real(j,r_kind)-one)/ratio_x end do - ratio_y=(nyb-two)/(nya-one) + ratio_y=(real(nyb,r_kind)-two)/(real(nya,r_kind)-one) do i=1,nya - ya_b(i)=one+half+(i-one)*ratio_y + ya_b(i)=one+half+(real(i,r_kind)-one)*ratio_y end do do i=1,nyb - ybh_a(i)=one+(i-one-half)/ratio_y - ybv_a(i)=one+(i-one)/ratio_y + ybh_a(i)=one+(real(i,r_kind)-one-half)/ratio_y + ybv_a(i)=one+(real(i,r_kind)-one)/ratio_y end do end if @@ -163,14 +163,14 @@ subroutine nmmb_h_to_a(hb,ha) ! subprogram: nmmb_h_to_a ! prgmmr: parrish ! -! abstract: interpolate from nmmb H grid to analysis grid +! abstract: interpolate from nmmb h grid to analysis grid ! ! program history log: ! 2009-08-06 lueken - added subprogram doc block ! 2010-09-10 parrish, add documentation ! ! input argument list: -! hb - input nmmb H grid variable +! hb - input nmmb h grid variable ! ! output argument list: ! ha - output interpolated variable on analysis grid @@ -192,7 +192,7 @@ subroutine nmmb_h_to_a(hb,ha) do j=1,nxb do i=1,nyb - bh(i,j)=hb(j,i) + bh(i,j)=real(hb(j,i),r_kind) end do end do call b_to_a_interpolate(bh,ha,nxb,nyb,nxa,nya,xbh_b,ybh_b,xa_b,ya_b) @@ -212,7 +212,7 @@ subroutine nmmb_h_to_a8(hb,ha) ! 2010-09-10 parrish, add documentation ! ! input argument list: -! hb - input nmmb H grid variable +! hb - input nmmb h grid variable ! ! output argument list: ! ha - output interpolated variable on analysis grid @@ -246,14 +246,14 @@ subroutine nmmb_v_to_a(vb,va) ! subprogram: nmmb_v_to_a ! prgmmr: parrish ! -! abstract: interpolate from nmmb V grid to analysis grid +! abstract: interpolate from nmmb v grid to analysis grid ! ! program history log: ! 2009-08-06 lueken - added subprogram doc block ! 2010-09-10 parrish, add documentation ! ! input argument list: -! vb - variable on nmmb V grid +! vb - variable on nmmb v grid ! ! output argument list: ! va - interolated variable on analysis grid @@ -279,7 +279,7 @@ subroutine nmmb_v_to_a(vb,va) jj=min(j,nxb-1) do i=1,nyb ii=min(i,nyb-1) - bv(i,j)=vb(jj,ii) + bv(i,j)=real(vb(jj,ii),r_kind) end do end do call b_to_a_interpolate(bv,va,nxb,nyb,nxa,nya,xbv_b,ybv_b,xa_b,ya_b) @@ -292,7 +292,7 @@ subroutine nmmb_a_to_h(ha,hb) ! subprogram: nmmb_a_to_h ! prgmmr: parrish ! -! abstract: interpolate from analysis grid to nmmb H grid +! abstract: interpolate from analysis grid to nmmb h grid ! ! program history log: ! 2009-08-06 lueken - added subprogram doc block @@ -302,7 +302,7 @@ subroutine nmmb_a_to_h(ha,hb) ! ha - variable on analysis grid ! ! output argument list: -! hb - interpolated variable on nmmb H grid +! hb - interpolated variable on nmmb h grid ! ! attributes: ! language: f90 @@ -322,7 +322,7 @@ subroutine nmmb_a_to_h(ha,hb) call b_to_a_interpolate(ha,bh,nxa,nya,nxb,nyb,xa_a,ya_a,xbh_a,ybh_a) do j=1,nxb do i=1,nyb - hb(j,i)=bh(i,j) + hb(j,i)=real(bh(i,j),r_single) end do end do @@ -334,7 +334,7 @@ subroutine nmmb_a_to_v(va,vb) ! subprogram: nmmb_a_to_v ! prgmmr: parrish ! -! abstract: interpolate from analysis grid to nmmb V grid +! abstract: interpolate from analysis grid to nmmb v grid ! ! program history log: ! 2009-08-06 lueken - added subprogram doc block @@ -344,7 +344,7 @@ subroutine nmmb_a_to_v(va,vb) ! va - analysis variable ! ! output argument list: -! vb - interpolated nmmb V grid variable +! vb - interpolated nmmb v grid variable ! ! attributes: ! language: f90 @@ -365,17 +365,17 @@ subroutine nmmb_a_to_v(va,vb) call b_to_a_interpolate(va,bv,nxa,nya,nxb,nyb,xa_a,ya_a,xbv_a,ybv_a) do j=1,nxb do i=1,nyb - vb(j,i)=bv(i,j) + vb(j,i)=real(bv(i,j),r_single) end do end do ! set north and east boundaries of output array to zero for variable on v grid do i=1,nyb - vb(nxb,i)=zero + vb(nxb,i)=real(zero,r_single) end do do j=1,nxb-1 - vb(j,nyb)=zero + vb(j,nyb)=real(zero,r_single) end do end subroutine nmmb_a_to_v @@ -387,13 +387,13 @@ subroutine b_to_a_interpolate(b,a,mb,nb,ma,na,xb,yb,xa,ya) ! prgmmr: parrish ! ! abstract: interpolate from variable b to variable a. This routine is -! used for interpolating both ways, nmmb H/V grid to analysis and back. +! used for interpolating both ways, nmmb h/v grid to analysis and back. ! Direction is controlled by input arguments. Interpolation is bilinear ! both ways. ! ! program history log: ! 2009-08-06 lueken - added subprogram doc block -! 2013-01-23 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS) +! 2013-01-23 parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on wcoss) ! ! input argument list: ! mb,nb - b dimensions @@ -413,7 +413,7 @@ subroutine b_to_a_interpolate(b,a,mb,nb,ma,na,xb,yb,xa,ya) ! interpolate from b-grid to a-grid -! NOTE: xa is in xb units, ya is in yb units +! Note: xa is in xb units, ya is in yb units use constants, only: zero,one implicit none diff --git a/src/gsi/mod_strong.f90 b/src/gsi/mod_strong.f90 index ee88d7f7ad..067820b239 100644 --- a/src/gsi/mod_strong.f90 +++ b/src/gsi/mod_strong.f90 @@ -13,7 +13,7 @@ module mod_strong ! ! program history log: ! 2007-02-15 parrish -! 2012-02-08 kleist - add option tlnmc_option to control how TLNMC is applied +! 2012-02-08 kleist - add option tlnmc_option to control how tlnmc is applied ! 2013-07-02 parrish - change tlnmc_type to reg_tlnmc_type. tlnmc_type no ! longer used for global application of tlnmc. ! 2014-12-03 derber - remove unused variables @@ -32,43 +32,43 @@ module mod_strong ! sub dinmi_ad - adjoint of dinmi ! sub dinmi0 - lower level--balance increment from input tendencies ! sub balm_1 - compute balance diagnostic variable -! sub getbcf - compute matrices B,C,F as defined in above reference +! sub getbcf - compute matrices b,c,f as defined in above reference ! sub scale_vars - scale variables as defined in reference ! sub scale_vars_ad - adjoint of scale variables ! sub unscale_vars - unscale variables ! sub unscale_vars_ad - adjoint of unscale variables -! sub f_mult - multiply by F matrix -! sub c_mult - multiply by C matrix +! sub f_mult - multiply by f matrix +! sub c_mult - multiply by c matrix ! sub i_mult - multiply by sqrt(-1) -! sub solve_f2c2 - solve (F*F+C*C)*x = y +! sub solve_f2c2 - solve (f*f+c*c)*x = y ! ! Variable Definitions: -! def l_tlnmc - Logical for TLNMC (set to true if namelist option tlnmc_option +! def l_tlnmc - Logical for tlnmc (set to true if namelist option tlnmc_option ! is 1, 2, or 3 ! def reg_tlnmc_type - =1 for regional 1st version of strong constraint ! =2 for regional 2nd version of strong constraint ! def nstrong - number of iterations of strong constraint initialization -! def scheme - which scheme (B, C or D) is being used (see reference above) +! def scheme - which scheme (b, c or d) is being used (see reference above) ! def period_max - max period (hours) of gravity modes to be balanced ! def period_width - width of smooth transition (hours, centered on period_max) ! from balanced to unbalanced gravity modes ! def baldiag_full - flag to toggle balance diagnostics for the full fields ! def baldiag_inc - flag to toggle balance diagnostics for the analysis increment -! def tlnmc_option - Integer option for Incremental Normal Mode Constraint (inmc) / TLNMC +! def tlnmc_option - Integer option for incremental normal mode constraint (inmc) / tlnmc ! when in hybrid ensemble mode: ! =0: no constraint at all -! =1: TLNMC on static contribution to increment (or if non-hybrid) -! =2: TLNMC on total increment (single time level only, or 3D mode) -! =3: TLNMC on total increment over all nobs_bins (if 4D mode) +! =1: tlnmc on static contribution to increment (or if non-hybrid) +! =2: tlnmc on total increment (single time level only, or 3d mode) +! =3: tlnmc on total increment over all nobs_bins (if 4d mode) ! attributes: ! language: f90 ! machine: ibm RS/6000 SP ! !$$$ end documentation block -use kinds,only: r_kind,i_kind -use constants, only: zero,half,one,two,four,r3600,omega,pi,rearth,one_tenth -implicit none + use kinds,only: r_kind,i_kind + use constants, only: zero,half,one,two,four,r3600,omega,pi,rearth,one_tenth + implicit none ! set default to private private @@ -158,10 +158,10 @@ subroutine gproj_diag_update(vort,div,phi,vort_g,div_g,phi_g,rmstend,rmstend_g,r ! ! scale: vort,div,phi --> vort_hat,div_hat,phi_hat ! -! solve: (F*F+C*C)*x = F*vort_hat + C*phi_hat +! solve: (f*f+c*c)*x = f*vort_hat + c*phi_hat ! then: -! phi_hat_g = C*x -! vort_hat_g = F*x +! phi_hat_g = c*x +! vort_hat_g = f*x ! div_hat_g = div_hat ! ! unscale: vort_hat_g, div_hat_g, phi_hat_g --> vort_g, div_g, phi_g @@ -224,10 +224,10 @@ subroutine gproj_diag(vort,div,phi,rmstend,rmstend_g,rmstend_f,rmstend_fg,& ! ! scale: vort,div,phi --> vort_hat,div_hat,phi_hat ! -! solve: (F*F+C*C)*x = F*vort_hat + C*phi_hat +! solve: (f*f+c*c)*x = f*vort_hat + c*phi_hat ! then: -! phi_hat_g = C*x -! vort_hat_g = F*x +! phi_hat_g = c*x +! vort_hat_g = f*x ! div_hat_g = div_hat ! ! unscale: vort_hat_g, div_hat_g, phi_hat_g --> vort_g, div_g, phi_g @@ -286,10 +286,10 @@ subroutine gproj(vort,div,phi,vort_g,div_g,phi_g,m,mmax,gspeed) ! ! scale: vort,div,phi --> vort_hat,div_hat,phi_hat ! -! solve: (F*F+C*C)*x = F*vort_hat + C*phi_hat +! solve: (f*f+c*c)*x = f*vort_hat + c*phi_hat ! then: -! phi_hat_g = C*x -! vort_hat_g = F*x +! phi_hat_g = c*x +! vort_hat_g = f*x ! div_hat_g = div_hat ! ! unscale: vort_hat_g, div_hat_g, phi_hat_g --> vort_g, div_g, phi_g @@ -343,11 +343,11 @@ subroutine gproj0(vort_hat,phi_hat,vort_hat_g,phi_hat_g,c,f,m,mmax) ! for gravity wave projection: vort,div,phi --> vort_g,div_g,phi_g ! ----------------------------------------------------------------------------- ! -! solve: (F*F+C*C)*x = F*vort_hat + C*phi_hat +! solve: (f*f+c*c)*x = f*vort_hat + c*phi_hat ! ! then: -! phi_hat_g = C*x -! vort_hat_g = F*x +! phi_hat_g = c*x +! vort_hat_g = f*x ! div_hat_g = div_hat ! ! program history log: @@ -397,11 +397,11 @@ subroutine gproj_ad(vort,div,phi,vort_g,div_g,phi_g,m,mmax,gspeed) ! ! scale: vort,div,phi --> vort_hat,div_hat,phi_hat ! -! solve: (F*F+C*C)*x = F*vort_hat + C*phi_hat +! solve: (f*f+c*c)*x = f*vort_hat + c*phi_hat ! ! then: -! phi_hat_g = C*x -! vort_hat_g = F*x +! phi_hat_g = c*x +! vort_hat_g = f*x ! div_hat_g = div_hat ! ! unscale: vort_hat_g, div_hat_g, phi_hat_g --> vort_g, div_g, phi_g @@ -452,13 +452,13 @@ subroutine dinmi(vort_t,div_t,phi_t,del_vort,del_div,del_phi,m,mmax,gspeed) ! ! scale: vort_t,div_t,phi_t --> vort_t_hat,div_t_hat,phi_t_hat ! -! solve: (F*F+C*C)*del_div_hat = sqrt(-1)*(F*vort_t_hat + C*phi_t_hat) +! solve: (f*f+c*c)*del_div_hat = sqrt(-1)*(f*vort_t_hat + c*phi_t_hat) ! -! solve: (F*F+C*C)*x = sqrt(-1)*div_t_hat - B*del_div_hat +! solve: (f*f+c*c)*x = sqrt(-1)*div_t_hat - b*del_div_hat ! ! then: -! del_phi_hat = C*x -! del_vort_hat = F*x +! del_phi_hat = c*x +! del_vort_hat = f*x ! ! unscale: del_vort_hat,del_div_hat,del_phi_hat --> del_vort,del_div,del_phi ! @@ -509,13 +509,13 @@ subroutine dinmi_ad(vort_t,div_t,phi_t,del_vort,del_div,del_phi,m,mmax,gspeed) ! ! scale: vort_t,div_t,phi_t --> vort_t_hat,div_t_hat,phi_t_hat ! -! solve: (F*F+C*C)*del_div_hat = sqrt(-1)*(F*vort_t_hat + C*phi_t_hat) +! solve: (f*f+c*c)*del_div_hat = sqrt(-1)*(f*vort_t_hat + c*phi_t_hat) ! -! solve: (F*F+C*C)*x = sqrt(-1)*div_t_hat - B*del_div_hat +! solve: (f*f+c*c)*x = sqrt(-1)*div_t_hat - b*del_div_hat ! ! then: -! del_phi_hat = C*x -! del_vort_hat = F*x +! del_phi_hat = c*x +! del_vort_hat = f*x ! ! unscale: del_vort_hat,del_div_hat,del_phi_hat --> del_vort,del_div,del_phi ! @@ -573,13 +573,13 @@ subroutine dinmi0(vort_t_hat,div_t_hat,phi_t_hat,del_vort_hat,del_div_hat,del_ph ! abstract: ! for implicit nmi correction: vort_t,div_t,phi_t --> del_vort,del_div,del_phi ! -! solve: (F*F+C*C)*del_div_hat = sqrt(-1)*(F*vort_t_hat + C*phi_t_hat) +! solve: (f*f+c*c)*del_div_hat = sqrt(-1)*(f*vort_t_hat + c*phi_t_hat) ! -! solve: (F*F+C*C)*x = sqrt(-1)*div_t_hat - B*del_div_hat +! solve: (f*f+c*c)*x = sqrt(-1)*div_t_hat - b*del_div_hat ! ! then: -! del_phi_hat = C*x -! del_vort_hat = F*x +! del_phi_hat = c*x +! del_vort_hat = f*x ! ! program history log: ! 2008-05-05 safford -- add subprogram doc block, rm unused uses @@ -629,7 +629,7 @@ subroutine balm_1(vort_t_hat,div_t_hat,phi_t_hat,balnm1,m,mmax) ! prgrmmr: ! ! abstract: obtain balance diagnostic for each wave number n,m using -! method 1 (eq 4.23 of Temperton,1989) +! method 1 (eq 4.23 of temperton,1989) ! ! balnm1 = abs(vort_t_hat)(n,m)**2 + abs(div_t_hat)(n,m)**2 + ! abs(phi_t_hat)(n,m)**2 @@ -700,24 +700,24 @@ subroutine getbcf(b,c,f,c2,c3,m,mmax,gspeed) integer(i_kind) n,nstart real(r_kind) eps,rn,rm,rn1 -! scheme B: b = 2*omega*m/(n*(n+1)) +! scheme b: b = 2*omega*m/(n*(n+1)) ! f = 2*omega*sqrt(n*n-1)*eps/n ! c = gspeed*sqrt(n*(n+1))/erad -! scheme C: b = 0 +! scheme c: b = 0 ! f = 2*omega*sqrt(n*n-1)*eps/n ! c = gspeed*sqrt(n*(n+1))/erad -! scheme D: b = 0 +! scheme d: b = 0 ! f = 2*omega*eps ! c = gspeed*sqrt(n*(n+1))/erad ! in the above, eps = sqrt((n*n-m*m)/(4*n*n-1)) nstart=max(m,1) - rm=m + rm=real(m,r_kind) do n=nstart,mmax - rn=n + rn=real(n,r_kind) eps=sqrt((rn*rn-rm*rm )/(four*rn*rn-one)) rn1=sqrt(rn*(rn+one)) if(scheme=='B') then @@ -757,12 +757,12 @@ subroutine scale_vars(vort,div,phi,vort_hat,div_hat,phi_hat,filtered,c2,c3,& ! abstract: ! input scaling: ! -! for schemes B, C: +! for schemes b, c: ! vort_hat(n) = erad*vort(n)/sqrt(n*(n+1)) ! div_hat(n) = sqrt(-1)*erad*div(n)/sqrt(n*(n+1)) ! phi_hat(n) = phi(n)/gspeed ! -! for scheme D: +! for scheme d: ! vort_hat(n) = erad*vort(n) ! div_hat(n) = sqrt(-1)*erad*div(n) ! phi_hat(n) = phi(n)*sqrt(n*(n+1))/gspeed @@ -830,12 +830,12 @@ subroutine scale_vars_ad(vort,div,phi,vort_hat,div_hat,phi_hat,c2,c3,& ! ! abstract: ! input scaling: -! for schemes B, C: +! for schemes b, c: ! vort_hat(n) = erad*vort(n)/sqrt(n*(n+1)) ! div_hat(n) = sqrt(-1)*erad*div(n)/sqrt(n*(n+1)) ! phi_hat(n) = phi(n)/gspeed ! -! for scheme D: +! for scheme d: ! vort_hat(n) = erad*vort(n) ! div_hat(n) = sqrt(-1)*erad*div(n) ! phi_hat(n) = phi(n)*sqrt(n*(n+1))/gspeed @@ -892,11 +892,11 @@ subroutine unscale_vars(vort_hat,div_hat,phi_hat,vort,div,phi,c2,c3,m,mmax) ! ! abstract: ! output scaling: -! for schemes B, C: +! for schemes b, c: ! vort(n,m) = sqrt(n*(n+1))*vort_hat(n,m)/erad ! div(n,m) = -sqrt(-1)*sqrt(n*(n+1))*div_hat(n,m)/erad ! phi(n,m) = gspeed*phi_hat(n,m) -! for scheme C: +! for scheme c: ! vort(n,m) = vort_hat(n,m)/erad ! div(n,m) = -sqrt(-1)*div_hat(n,m)/erad ! phi(n,m) = gspeed*phi_hat(n,m)/sqrt(n*(n+1)) @@ -955,11 +955,11 @@ subroutine unscale_vars_ad(vort_hat,div_hat,phi_hat,vort,div,phi,c2,c3,m,mmax) ! ! abstract: ! output scaling: -! for schemes B, C: +! for schemes b, c: ! vort(n,m) = sqrt(n*(n+1))*vort_hat(n,m)/erad ! div(n,m) = -sqrt(-1)*sqrt(n*(n+1))*div_hat(n,m)/erad ! phi(n,m) = gspeed*phi_hat(n,m) -! for scheme C: +! for scheme c: ! vort(n,m) = vort_hat(n,m)/erad ! div(n,m) = -sqrt(-1)*div_hat(n,m)/erad ! phi(n,m) = gspeed*phi_hat(n,m)/sqrt(n*(n+1)) @@ -1017,7 +1017,7 @@ subroutine f_mult(x,y,f,m,mmax) ! ! prgrmmr: ! -! abstract: x = F*y +! abstract: x = f*y ! ! program history log: ! 2008-05-05 safford -- add subprogram doc block, rm unused uses @@ -1078,7 +1078,7 @@ subroutine c_mult(x,y,c,m,mmax) ! ! prgrmmr: ! -! abstract: x = C*y +! abstract: x = c*y ! ! program history log: ! 2008-05-05 safford -- add subprogram doc block, rm unused uses @@ -1173,7 +1173,7 @@ subroutine solve_f2c2(x,y,f,c,m,mmax) ! ! prgrmmr: ! -! abstract: solve (F*F+C*C)*x = y +! abstract: solve (f*f+c*c)*x = y ! ! program history log: ! 2008-05-05 safford -- add subprogram doc block, rm unused uses @@ -1223,7 +1223,7 @@ subroutine solve_f2c2(x,y,f,c,m,mmax) x(2,nstart)=z(2,nstart)/a(nstart) else -! compute main diagonal of F*F + C*C +! compute main diagonal of f*f + c*c a(nstart)=f(nstart+1)*f(nstart+1)+c(nstart)*c(nstart) if(nstart+1 < mmax) then @@ -1233,7 +1233,7 @@ subroutine solve_f2c2(x,y,f,c,m,mmax) end if a(mmax)=f(mmax)*f(mmax)+c(mmax)*c(mmax) -! compute only non-zero off-diagonal of F*F + C*C +! compute only non-zero off-diagonal of f*f + c*c if(nstart+2<=mmax) then do n=nstart+2,mmax diff --git a/src/gsi/model_ad.F90 b/src/gsi/model_ad.F90 index f030274e0d..935a037223 100644 --- a/src/gsi/model_ad.F90 +++ b/src/gsi/model_ad.F90 @@ -20,7 +20,7 @@ subroutine model_ad(xini,xobs,ldprt) use state_vectors, only: allocate_state,deallocate_state,dot_product use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer -use gsi_bundlemod, only: gsi_bundleAddMul +use gsi_bundlemod, only: gsi_bundleaddmul use gsi_bundlemod, only: self_add,assignment(=) use gsi_4dcouplermod, only: gsi_4dcoupler_init_model_ad use gsi_4dcouplermod, only: gsi_4dcoupler_model_ad @@ -30,11 +30,11 @@ subroutine model_ad(xini,xobs,ldprt) use mpeu_util,only: die,tell use mpimod, only: mype -#ifdef _LAG_MODEL_ +#ifdef _LAG_modEL_ use lag_fields, only: nlocal_orig_lag, ntotal_orig_lag use lag_fields, only: lag_ad_vec,lag_tl_spec_i,lag_tl_spec_r use lag_fields, only: lag_u_full,lag_v_full -use lag_fields, only: lag_ADscatter_stateuv +use lag_fields, only: lag_adscatter_stateuv use lag_traj, only: lag_rk2iter_ad #endif ! use lag_traj, only: lag_rk4iter_ad @@ -50,17 +50,17 @@ subroutine model_ad(xini,xobs,ldprt) type(gsi_bundle), target, intent(inout) :: xini(nsubwin) ! Adjoint state variable at control times -! !DESCRIPTION: Run AGCM adjoint model. +! !DESCRIPTION: Run agcm adjoint model. ! ! !REVISION HISTORY: ! ! 19Apr2007 tremolet - initial code -! 29May2007 todling - add actual calls to interface and AGCM AD model +! 29May2007 todling - add actual calls to interface and agcm ad model ! 29Jun2007 todling - adm verified against tlm ! 30Sep2007 todling - add timer ! 30Apr2009 meunier - add trajectory model for lagrangian data ! 13May2010 todling - update to use gsi_bundle -! 27May2010 todling - gsi_4dcoupler; remove all user-specific TL-related references +! 27May2010 todling - gsi_4dcoupler; remove all user-specific tl-related references ! 31Aug2010 Guo - new implementation of model_ad, which separates ! full perturbation vector xx, to become xini for ! a output increment perturbation and xobs for an @@ -75,7 +75,7 @@ subroutine model_ad(xini,xobs,ldprt) ! Declare local variables character(len=*), parameter :: myname = 'model_ad' -#ifdef _LAG_MODEL_ +#ifdef _LAG_modEL_ integer(i_kind) :: ii,jj real(r_kind),pointer,dimension(:,:,:) :: xx_u,xx_v real(r_kind),dimension(3):: ad_tmp_locvect @@ -85,7 +85,7 @@ subroutine model_ad(xini,xobs,ldprt) real(r_kind) :: d0,tstep type(gsi_bundle),pointer:: p_xini type(gsi_bundle),pointer:: p_xobs -type(gsi_bundle) :: xxpert ! perturbation state, persistent between steps +type(gsi_bundle) :: xxpert ! perturbation state, persistent between steps logical:: ldprt_,iau_on_ ! Temporary vector for lagrangian backward integration @@ -95,40 +95,40 @@ subroutine model_ad(xini,xobs,ldprt) ! Initialize timer call timer_ini('model_ad') - n=size(xobs) - if(n<1) call die(myname,'unexpected size, size(xobs) =',n) +n=size(xobs) +if(n<1) call die(myname,'unexpected size, size(xobs) =',n) -ldprt_=ldprt ! .or.mype==0 !! in case one needs to debug locally +ldprt_=ldprt ! .or.mype==0 !! in case one needs to debug locally iau_on_=liauon -! Initialize AD model - ! Get [date,time] +! Initialize ad model +! Get [date,time] nymdi = iadateend/100 nhmsi = (iadateend-100*nymdi)*10000 !---- call gsi_4dcoupler_init_model_ad(nymdi,nhmsi,ndtpert) - ! Get ndtpert for pertmod_AD time step in seconds; - ! Create and initialize a persistent state +! Get ndtpert for pertmod_ad time step in seconds; +! Create and initialize a persistent state call gsi_4dcoupler_init_model_ad(xxpert,xobs(1),nymdi,nhmsi,ndtpert,rc=ierr) - if(ierr/=0) call die(myname,'gsi_4dcoupler_init_model_ad(), rc =',ierr) +if(ierr/=0) call die(myname,'gsi_4dcoupler_init_model_ad(), rc =',ierr) do n=1,nsubwin - xini(n)=0._r_kind + xini(n)=0._r_kind enddo -! Determine corresponding GSI time step parameters. -! A GSI time step is a hr_obsbin time interval. -ndt = NINT(hr_obsbin*r3600/ndtpert) ! count of pertmod_TL time step in 1 hr_obsbin -dt = ndt*ndtpert ! one GSI time step in seconds -tstep = dt ! one GSI time step in seconds +! Determine corresponding gsi time step parameters. +! A gsi time step is a hr_obsbin time interval. +ndt = nint(hr_obsbin*r3600/ndtpert) ! count of pertmod_tl time step in 1 hr_obsbin +dt = ndt*ndtpert ! one gsi time step in seconds +tstep = dt ! one gsi time step in seconds -nstep = NINT(winlen*r3600/tstep) ! e.g. 6 -nfrctl = NINT(winsub*r3600/tstep) ! e.g. 6 -nfrobs = NINT(hr_obsbin*r3600/tstep) ! e.g. 1 +nstep = nint(winlen*r3600/tstep) ! e.g. 6 +nfrctl = nint(winsub*r3600/tstep) ! e.g. 6 +nfrobs = nint(hr_obsbin*r3600/tstep) ! e.g. 1 -wt=0. +wt=0._r_kind if(iau_on_) then - wt=1._r_kind/nfrctl - if(ldprt_.and.mype==0) call tell(myname,'increment weighting, wt =',wt) + wt=1._r_kind/nfrctl + if(ldprt_.and.mype==0) call tell(myname,'increment weighting, wt =',wt) endif if (ldprt_.and.mype==0) write(6,'(a,3(1x,i4))')'model_ad: nstep,nfrctl,nfrobs=',nstep,nfrctl,nfrobs @@ -136,109 +136,109 @@ subroutine model_ad(xini,xobs,ldprt) ! Locate (nstep) in xobs, if any. Then add this adjoint increment to ! the current state (xxpert). - p_xobs => istep_locate_(xobs,nstep,nfrobs, & - ldprt_.and.mype==0,myname//".xobs-",nymdi,nhmsi) +p_xobs => istep_locate_(xobs,nstep,nfrobs, & + ldprt_.and.mype==0,myname//".xobs-",nymdi,nhmsi) -if(associated(p_xobs)) call self_add(xxpert,p_xobs) ! xxpert += p_xobs +if(associated(p_xobs)) call self_add(xxpert,p_xobs) ! xxpert += p_xobs ! Locate (nstep) in xini, if any. Then store the current adjoint state ! (xxpert) to xini. - if(iau_on_) then - p_xini => iau_locate_(xini,nstep,nfrctl, & - ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) - else - p_xini => istep_locate_(xini,nstep,nfrctl, & - ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) - endif +if(iau_on_) then + p_xini => iau_locate_(xini,nstep,nfrctl, & + ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) +else + p_xini => istep_locate_(xini,nstep,nfrctl, & + ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) +endif if(associated(p_xini)) then - if(iau_on_) then - call gsi_bundleAddMul(p_xini,wt,xxpert) ! p_xini += wt*xxpert - else - call self_add(p_xini,xxpert) ! p_xini += xxpert - endif + if(iau_on_) then + call gsi_bundleaddmul(p_xini,wt,xxpert) ! p_xini += wt*xxpert + else + call self_add(p_xini,xxpert) ! p_xini += xxpert + endif endif -! Run AD model +! Run ad model do istep=nstep-1,0,-1 - ! Locate (istep+1) in xobs, if any. Then apply AD model from istep+1 + ! Locate (istep+1) in xobs, if any. Then apply ad model from istep+1 ! (xxpert, p_xobs) to istep (xxpert). - p_xobs => istep_locate_(xobs,istep+1,nfrobs, & - ldprt_.and.mype==0,myname//".xobs+",nymdi,nhmsi) + p_xobs => istep_locate_(xobs,istep+1,nfrobs, & + ldprt_.and.mype==0,myname//".xobs+",nymdi,nhmsi) - ! get (date,time) at (istep). - call tick(nymdi,nhmsi,-dt) + ! get (date,time) at (istep). + call tick(nymdi,nhmsi,-dt) - call gsi_4dcoupler_model_ad(xxpert,p_xobs,nymdi,nhmsi,ndt,rc=ierr) - if(ierr/=0) call die(myname,'gsi_4dcoupler_model_ad(), rc =',ierr) + call gsi_4dcoupler_model_ad(xxpert,p_xobs,nymdi,nhmsi,ndt,rc=ierr) + if(ierr/=0) call die(myname,'gsi_4dcoupler_model_ad(), rc =',ierr) -#ifdef _LAG_MODEL_ -! Apply AD trajectory model (same time steps as obsbin) - if(ntotal_orig_lag>0) then - ! When there is a lagmod to do , adjoint integrate from istep+1 back - ! to istep, using xxpert at time (istep) - ii=istep ! step count for lagmod is off by 1. +#ifdef _LAG_modEL_ +! Apply ad trajectory model (same time steps as obsbin) + if(ntotal_orig_lag>0) then + ! When there is a lagmod to do , adjoint integrate from istep+1 back + ! to istep, using xxpert at time (istep) + ii=istep ! step count for lagmod is off by 1. - ! Execute AD model for each balloon (loop step insensitive) + ! Execute ad model for each balloon (loop step insensitive) do jj=1,nlocal_orig_lag ad_tmp_locvect = lag_ad_vec(jj,ii+1,:) ! if (.not.idmodel) then call lag_rk2iter_ad(lag_tl_spec_i(jj,ii,:),lag_tl_spec_r(jj,ii,:),& - &ad_tmp_locvect(1),ad_tmp_locvect(2),ad_tmp_locvect(3),& - &lag_u_full(:,:,ii),lag_v_full(:,:,ii)) - print '(A,I3,A,F16.6,F16.6)',"ADiter: ",ii," location",lag_ad_vec(jj,ii,1),lag_ad_vec(jj,ii,2) + ad_tmp_locvect(1),ad_tmp_locvect(2),ad_tmp_locvect(3),& + lag_u_full(:,:,ii),lag_v_full(:,:,ii)) + print '(A,I3,A,F16.6,F16.6)',"aditer: ",ii," location",lag_ad_vec(jj,ii,1),lag_ad_vec(jj,ii,2) ! end if lag_ad_vec(jj,ii,:)=lag_ad_vec(jj,ii,:)+ad_tmp_locvect end do - ! Give the sensitivity back to the GCM + ! Give the sensitivity back to the gcm call gsi_bundlegetpointer(xxpert,'u',xx_u,ierr) call gsi_bundlegetpointer(xxpert,'v',xx_v,ierr) - call lag_ADscatter_stateuv(xx_u,xx_v,ii) + call lag_adscatter_stateuv(xx_u,xx_v,ii) ! To not add the contribution 2 times lag_u_full(:,:,ii)=zero; lag_v_full(:,:,ii)=zero; - endif + endif #endif - ! Locate (istep) in xobs, if any. Then add adjoint increment to - ! the current adjoint state (xxpert). - p_xobs => istep_locate_(xobs,istep,nfrobs, & - ldprt_.and.mype==0,myname//".xobs-",nymdi,nhmsi) + ! Locate (istep) in xobs, if any. Then add adjoint increment to + ! the current adjoint state (xxpert). + p_xobs => istep_locate_(xobs,istep,nfrobs, & + ldprt_.and.mype==0,myname//".xobs-",nymdi,nhmsi) + + if(associated(p_xobs)) call self_add(xxpert,p_xobs) ! xxpert += p_xobs - if(associated(p_xobs)) call self_add(xxpert,p_xobs) ! xxpert += p_xobs + ! Locate (istep) in xini, if any. Then store the current adjoint + ! state (xxpert) to xini. + if(iau_on_) then + p_xini => iau_locate_(xini,istep,nfrctl, & + ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) + else + p_xini => istep_locate_(xini,istep,nfrctl, & + ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) + endif - ! Locate (istep) in xini, if any. Then store the current adjoint - ! state (xxpert) to xini. + if(associated(p_xini)) then if(iau_on_) then - p_xini => iau_locate_(xini,istep,nfrctl, & - ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) + call gsi_bundleaddmul(p_xini,wt,xxpert) ! p_xini += wt*xxpert else - p_xini => istep_locate_(xini,istep,nfrctl, & - ldprt_.and.mype==0,myname//".xini-",nymdi,nhmsi) + call self_add(p_xini,xxpert) ! p_xini += xxpert endif - - if(associated(p_xini)) then - if(iau_on_) then - call gsi_bundleAddMul(p_xini,wt,xxpert) ! p_xini += wt*xxpert - else - call self_add(p_xini,xxpert) ! p_xini += xxpert - endif - endif + endif enddo d0 = zero do n=lbound(xini,1),ubound(xini,1) - d0 = d0+dot_product(xini(n),xini(n)) + d0 = d0+dot_product(xini(n),xini(n)) enddo if(ldprt_) print *, myname, ': total (gsi) dot product ', d0 -! Finalize AD model, and destroy xxpert at the same time. +! Finalize ad model, and destroy xxpert at the same time. call gsi_4dcoupler_final_model_ad(xxpert,xobs(1),nymdi,nhmsi,rc=ierr) - if(ierr/=0) call die(myname,'gsi_rccoupler_final_model_ad(), rc =',ierr) +if(ierr/=0) call die(myname,'gsi_rccoupler_final_model_ad(), rc =',ierr) ! Finalize timer call timer_fnl('model_ad') @@ -247,60 +247,60 @@ subroutine model_ad(xini,xobs,ldprt) contains function istep_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) - !-- locate istep-th element in x, which is defined only at every intvl - !-- isteps. i.e., p_ => x(1), if istep=0; - !-- x(2), if istep=1*intvl; - !-- x(3), if istep=2*intvl; etc. - !-- null, otherwise. + !-- locate istep-th element in x, which is defined only at every intvl + !-- isteps. i.e., p_ => x(1), if istep=0; + !-- x(2), if istep=1*intvl; + !-- x(3), if istep=2*intvl; etc. + !-- null, otherwise. use mpeu_util,only: tell,warn,stdout implicit none type(gsi_bundle),pointer:: p_ type(gsi_bundle),target,dimension(:),intent(in):: x integer(i_kind),intent(in):: istep - integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements + integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements - logical ,intent(in):: verbose ! if information is needed - character(len=*),intent(in):: which ! for which this call is made. - integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time + logical ,intent(in):: verbose ! if information is needed + character(len=*),intent(in):: which ! for which this call is made. + integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time - integer:: i,isize_,intvl_ + integer(i_kind):: i,isize_,intvl_ isize_= size(x) intvl_= max(1,intvl) p_ =>null() - if (MOD(istep,intvl_)/=0) return + if (mod(istep,intvl_)/=0) return i=istep/intvl_+1 if (i<1.or.i>isize_) return if(verbose) write(stdout,'(1x,2a,i8.8,i7.6,2(i6,"/",i2.2))') which, & - '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ + '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ p_ => x(i) end function istep_locate_ function iau_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) - !-- locate IAU istep-th element in x, which is defined at corresponding - !-- istep values. i.e., p_=> null, if istep=0; - !-- x(1), if istep=0*intvl+1 .. 1*intvl; - !-- x(2), if istep=1*intvl+1 .. 2*intvl; etc. - !-- x(3), if istep=2*intvl+1 .. 3*intvl; etc. - !-- null, otherwise. + !-- locate iau istep-th element in x, which is defined at corresponding + !-- istep values. i.e., p_=> null, if istep=0; + !-- x(1), if istep=0*intvl+1 .. 1*intvl; + !-- x(2), if istep=1*intvl+1 .. 2*intvl; etc. + !-- x(3), if istep=2*intvl+1 .. 3*intvl; etc. + !-- null, otherwise. use mpeu_util,only: tell,warn,stdout implicit none type(gsi_bundle),pointer:: p_ type(gsi_bundle),target,dimension(:),intent(in):: x integer(i_kind),intent(in):: istep - integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements + integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements - logical ,intent(in):: verbose ! if information is needed - character(len=*),intent(in):: which ! for which this call is made. - integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time + logical ,intent(in):: verbose ! if information is needed + character(len=*),intent(in):: which ! for which this call is made. + integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time - integer:: i,isize_,intvl_ + integer(i_kind):: i,isize_,intvl_ isize_= size(x) intvl_= max(1,intvl) @@ -311,7 +311,7 @@ function iau_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) if (i<1.or.i>isize_) return if(verbose) write(stdout,'(1x,2a,i8.8,i7.6,2(i6,"/",i2.2))') which, & - '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ + '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ p_ => x(i) end function iau_locate_ diff --git a/src/gsi/model_tl.F90 b/src/gsi/model_tl.F90 index b5bd773358..c3bc456a8c 100644 --- a/src/gsi/model_tl.F90 +++ b/src/gsi/model_tl.F90 @@ -3,7 +3,7 @@ !------------------------------------------------------------------------- !BOP ! -! !ROUTINE: model_tl: Main interface to AGCM tangent linear model +! !ROUTINE: model_tl: Main interface to agcm tangent linear model ! ! !INTERFACE: @@ -20,8 +20,8 @@ subroutine model_tl(xini,xobs,ldprt) use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer use gsi_bundlemod, only: self_add,assignment(=) -use gsi_bundlemod, only: gsi_bundleDup -use gsi_bundlemod, only: gsi_bundleDestroy +use gsi_bundlemod, only: gsi_bundledup +use gsi_bundlemod, only: gsi_bundledestroy use gsi_4dcouplermod, only: gsi_4dcoupler_init_model_tl use gsi_4dcouplermod, only: gsi_4dcoupler_model_tl use gsi_4dcouplermod, only: gsi_4dcoupler_final_model_tl @@ -29,7 +29,7 @@ subroutine model_tl(xini,xobs,ldprt) use timermod, only: timer_ini,timer_fnl use mpeu_util,only: die,tell -#ifdef _LAG_MODEL_ +#ifdef _LAG_modEL_ use lag_fields, only: nlocal_orig_lag, ntotal_orig_lag use lag_fields, only: lag_tl_vec,lag_ad_vec,lag_tl_spec_i,lag_tl_spec_r use lag_fields, only: lag_u_full,lag_v_full @@ -49,18 +49,18 @@ subroutine model_tl(xini,xobs,ldprt) type(gsi_bundle), target, intent(inout) :: xobs(nobs_bins) ! State variable at observations times -! !DESCRIPTION: Run AGCM tangent linear model. +! !DESCRIPTION: Run agcm tangent linear model. ! ! !REMARKS: ! ! !REVISION HISTORY: ! ! 19Apr2007 tremolet - initial code -! 29May2007 todling - add actual calls to interface and AGCM TL model +! 29May2007 todling - add actual calls to interface and agcm tl model ! 30Sep2007 todling - add timer ! 30Apr2009 meunier - add trajectory model for lagrangian data ! 13May2010 todling - update to use gsi_bundle -! 27May2010 todling - gsi_4dcoupler; remove all user-specific TL-related references +! 27May2010 todling - gsi_4dcoupler; remove all user-specific tl-related references ! 31Aug2010 Guo - new implementation of model_tl, which separates ! full perturbation vector xx, to become xini for ! an input increment perturbation and xobs for an @@ -75,7 +75,7 @@ subroutine model_tl(xini,xobs,ldprt) ! Declare local variables character(len=*), parameter :: myname = 'model_tl' -#ifdef _LAG_MODEL_ +#ifdef _LAG_modEL_ integer(i_kind) :: ii,jj real(r_kind),pointer,dimension(:,:,:) :: xx_u,xx_v #endif @@ -85,7 +85,7 @@ subroutine model_tl(xini,xobs,ldprt) type(gsi_bundle), pointer :: p_xini, q_xini type(gsi_bundle), pointer :: p_xobs -type(gsi_bundle) :: xxpert ! perturbation state, persistent between steps +type(gsi_bundle) :: xxpert ! perturbation state, persistent between steps logical:: ldprt_, iau_on_ real(r_kind):: wt @@ -93,40 +93,40 @@ subroutine model_tl(xini,xobs,ldprt) ! Initialize timer call timer_ini('model_tl') - n = size(xini) - if(n<1) call die(myname,'unexpected size, size(xini) =',n) +n = size(xini) +if(n<1) call die(myname,'unexpected size, size(xini) =',n) -ldprt_=ldprt ! .or.mype==0 !! in case one needs to debug locally +ldprt_=ldprt ! .or.mype==0 !! in case one needs to debug locally iau_on_=liauon q_xini => null() -! Initialize TL model - ! Get [date,time] +! Initialize tl model +! Get [date,time] nymdi = iadatebgn/100 nhmsi = (iadatebgn-100*nymdi)*10000 !---- call gsi_4dcoupler_init_model_tl() - ! Get ndtpert for pertmod_TL time step in seconds. Then create a - ! persistent state (xxpert) and initialize it to zero. +! Get ndtpert for pertmod_tl time step in seconds. Then create a +! persistent state (xxpert) and initialize it to zero. call gsi_4dcoupler_init_model_tl(xini(1),xxpert,nymdi,nhmsi,ndtpert,rc=ierr) - if(ierr/=0) call die(myname,'gsi_4dcoupler_init_model_tl(), rc =',ierr) +if(ierr/=0) call die(myname,'gsi_4dcoupler_init_model_tl(), rc =',ierr) -xxpert = zero ! this initialization is made explicit +xxpert = zero ! this initialization is made explicit -! Determine corresponding GSI time step parameters. -! A GSI time step is a hr_obsbin time interval. -ndt = NINT(hr_obsbin*r3600/ndtpert) ! count of pertmod_TL time step in 1 hr_obsbin -dt = ndt*ndtpert ! one GSI time step in seconds -tstep = dt ! one GSI time step in seconds +! Determine corresponding gsi time step parameters. +! A gsi time step is a hr_obsbin time interval. +ndt = nint(hr_obsbin*r3600/ndtpert) ! count of pertmod_tl time step in 1 hr_obsbin +dt = ndt*ndtpert ! one gsi time step in seconds +tstep = dt ! one gsi time step in seconds -nstep = NINT(winlen*r3600/tstep) -nfrctl = NINT(winsub*r3600/tstep) -nfrobs = NINT(hr_obsbin*r3600/tstep) +nstep = nint(winlen*r3600/tstep) +nfrctl = nint(winsub*r3600/tstep) +nfrobs = nint(hr_obsbin*r3600/tstep) -wt= 0. +wt= 0._r_kind if(iau_on_) then - wt=1._r_kind/nfrctl - if(ldprt_) call tell(myname,'increment weighting, wt =',wt) + wt=1._r_kind/nfrctl + if(ldprt_) call tell(myname,'increment weighting, wt =',wt) endif @@ -134,17 +134,17 @@ subroutine model_tl(xini,xobs,ldprt) ! Checks zz=real(nstep,r_kind)*tstep -if (ABS(winlen*r3600 -zz)>epsilon(zz)) then +if (abs(winlen*r3600 -zz)>epsilon(zz)) then write(6,*)'model_tl: error nstep',winlen,zz call stop2(147) end if zz=real(nfrctl,r_kind)*tstep -if (ABS(winsub*r3600 -zz)>epsilon(zz)) then +if (abs(winsub*r3600 -zz)>epsilon(zz)) then write(6,*)'model_tl: error nfrctl',winsub,zz call stop2(148) end if zz=real(nfrobs,r_kind)*tstep -if (ABS(hr_obsbin*r3600-zz)>epsilon(zz)) then +if (abs(hr_obsbin*r3600-zz)>epsilon(zz)) then write(6,*)'model_tl: error nfrobs',hr_obsbin,zz call stop2(149) end if @@ -153,147 +153,148 @@ subroutine model_tl(xini,xobs,ldprt) call stop2(150) end if -#ifdef _LAG_MODEL_ -! Initialize trajectory TLM and vectors - lag_tl_vec(:,:,:)=zero - lag_ad_vec(:,:,:)=zero +#ifdef _LAG_modEL_ +! Initialize trajectory tlm and vectors +lag_tl_vec(:,:,:)=zero +lag_ad_vec(:,:,:)=zero #endif ! Locate (istep=0) in xini, if any. Then add this increment to the ! current state (xxpert). - if(iau_on_) then - p_xini => iau_locate_(xini,0,nfrctl, & - ldprt_,myname//'.xini+',nymdi,nhmsi) - if(associated(p_xini)) then - if(associated(q_xini)) then - call gsi_bundleDestroy(q_xini) - else - allocate(q_xini) - endif - call gsi_bundleDup(wt,p_xini,q_xini) ! q_xini = wt*p_xini - p_xini => q_xini ! p_xini => q_xini - endif - +if(iau_on_) then + p_xini => iau_locate_(xini,0,nfrctl, & + ldprt_,myname//'.xini+',nymdi,nhmsi) + if(associated(p_xini)) then + if(associated(q_xini)) then + call gsi_bundledestroy(q_xini) else - p_xini => istep_locate_(xini,0,nfrctl, & - ldprt_,myname//'.xini+',nymdi,nhmsi) + allocate(q_xini) endif + call gsi_bundledup(wt,p_xini,q_xini) ! q_xini = wt*p_xini + p_xini => q_xini ! p_xini => q_xini + endif + +else + p_xini => istep_locate_(xini,0,nfrctl, & + ldprt_,myname//'.xini+',nymdi,nhmsi) +endif if(associated(p_xini)) call self_add(xxpert,p_xini) ! Locate (istep=0) in xobs, if any. Then store the current state (xxpert) ! to xobs. - p_xobs => istep_locate_(xobs,0,nfrobs, & - ldprt_,myname//'.xobs+',nymdi,nhmsi) +p_xobs => istep_locate_(xobs,0,nfrobs, & + ldprt_,myname//'.xobs+',nymdi,nhmsi) if(associated(p_xobs)) then - p_xobs = xxpert + p_xobs = xxpert endif -! Run TL model +! Run tl model do istep=0,nstep-1 -#ifdef _LAG_MODEL_ -! Apply TL trajectory model (same time steps as obsbin) - if (ntotal_orig_lag>0) then - ! When there is a lagmod to do, integrate from this istep to the next - ! istep. - ii=istep+1 ! off the lagmod array index by one +#ifdef _LAG_modEL_ +! Apply tl trajectory model (same time steps as obsbin) + if (ntotal_orig_lag>0) then + ! When there is a lagmod to do, integrate from this istep to the next + ! istep. + ii=istep+1 ! off the lagmod array index by one + ! Gather winds from the istep perturnation state call gsi_bundlegetpointer(xxpert,'u',xx_u,ierr) call gsi_bundlegetpointer(xxpert,'v',xx_v,ierr) call lag_gather_stateuv(xx_u,xx_v,ii) - ! Execute TL model + ! Execute tl model do jj=1,nlocal_orig_lag lag_tl_vec(jj,ii+1,:)=lag_tl_vec(jj,ii,:) ! if (.not.idmodel) then call lag_rk2iter_tl(lag_tl_spec_i(jj,ii,:),lag_tl_spec_r(jj,ii,:),& - &lag_tl_vec(jj,ii+1,1),lag_tl_vec(jj,ii+1,2),lag_tl_vec(jj,ii+1,3),& - &lag_u_full(:,:,ii),lag_v_full(:,:,ii)) - print '(A,I3,A,F14.6,F14.6)',"TLiter: ",ii+1," location",lag_tl_vec(jj,ii+1,1),lag_tl_vec(jj,ii+1,2) + lag_tl_vec(jj,ii+1,1),lag_tl_vec(jj,ii+1,2),lag_tl_vec(jj,ii+1,3),& + lag_u_full(:,:,ii),lag_v_full(:,:,ii)) + print '(A,I3,A,F14.6,F14.6)',"tliter: ",ii+1," location",lag_tl_vec(jj,ii+1,1),lag_tl_vec(jj,ii+1,2) ! endif end do - endif + endif #endif - ! Locate (istep) in xini, if any. Then apply TL model from istep - ! (p_xini and xxpert) to istep+1 (xxpert). - if(iau_on_) then - p_xini => iau_locate_(xini,istep,nfrctl, & - ldprt_,myname//'.xini-',nymdi,nhmsi) - if(associated(p_xini)) then - if(associated(q_xini)) then - call gsi_bundleDestroy(q_xini) - else - allocate(q_xini) - endif - call gsi_bundleDup(wt,p_xini,q_xini) ! q_xini = wt*p_xini - p_xini => q_xini ! p_xini => q_xini - endif - - else - p_xini => istep_locate_(xini,istep,nfrctl, & - ldprt_,myname//'.xini-',nymdi,nhmsi) + ! Locate (istep) in xini, if any. Then apply tl model from istep + ! (p_xini and xxpert) to istep+1 (xxpert). + if(iau_on_) then + p_xini => iau_locate_(xini,istep,nfrctl, & + ldprt_,myname//'.xini-',nymdi,nhmsi) + if(associated(p_xini)) then + if(associated(q_xini)) then + call gsi_bundledestroy(q_xini) + else + allocate(q_xini) + endif + call gsi_bundledup(wt,p_xini,q_xini) ! q_xini = wt*p_xini + p_xini => q_xini ! p_xini => q_xini endif - call gsi_4dcoupler_model_tl(p_xini,xxpert,nymdi,nhmsi,ndt,rc=ierr) - if(ierr/=0) call die(myname,'gsi_4dcoupler_model_tl(), rc =',ierr) - - ! Update the clock to (istep+1) - call tick (nymdi,nhmsi,dt) - - ! Locate (istep+1) in xini, if any. Then add this increment to the - ! current state (xxpert). - if(iau_on_) then - p_xini => iau_locate_(xini,istep+1,nfrctl, & - ldprt_,myname//'.xini+',nymdi,nhmsi) - if(associated(p_xini)) then - if(associated(q_xini)) then - call gsi_bundleDestroy(q_xini) - else - allocate(q_xini) - endif - call gsi_bundleDup(wt,p_xini,q_xini) ! q_xini = wt*p_xini - p_xini => q_xini ! p_xini => q_xini - endif - - else - p_xini => istep_locate_(xini,istep+1,nfrctl, & - ldprt_,myname//'.xini+',nymdi,nhmsi) + else + p_xini => istep_locate_(xini,istep,nfrctl, & + ldprt_,myname//'.xini-',nymdi,nhmsi) + endif + + call gsi_4dcoupler_model_tl(p_xini,xxpert,nymdi,nhmsi,ndt,rc=ierr) + if(ierr/=0) call die(myname,'gsi_4dcoupler_model_tl(), rc =',ierr) + + ! Update the clock to (istep+1) + call tick (nymdi,nhmsi,dt) + + ! Locate (istep+1) in xini, if any. Then add this increment to the + ! current state (xxpert). + if(iau_on_) then + p_xini => iau_locate_(xini,istep+1,nfrctl, & + ldprt_,myname//'.xini+',nymdi,nhmsi) + if(associated(p_xini)) then + if(associated(q_xini)) then + call gsi_bundledestroy(q_xini) + else + allocate(q_xini) + endif + call gsi_bundledup(wt,p_xini,q_xini) ! q_xini = wt*p_xini + p_xini => q_xini ! p_xini => q_xini endif - if(associated(p_xini)) call self_add(xxpert,p_xini) + else + p_xini => istep_locate_(xini,istep+1,nfrctl, & + ldprt_,myname//'.xini+',nymdi,nhmsi) + endif + + if(associated(p_xini)) call self_add(xxpert,p_xini) - ! Locate istep in xobs at (istep+1), if any. Then store the current - ! state (xxpert) to xobs. - p_xobs => istep_locate_(xobs,istep+1,nfrobs, & - ldprt_,myname//'.xobs+',nymdi,nhmsi) + ! Locate istep in xobs at (istep+1), if any. Then store the current + ! state (xxpert) to xobs. + p_xobs => istep_locate_(xobs,istep+1,nfrobs, & + ldprt_,myname//'.xobs+',nymdi,nhmsi) - if(associated(p_xobs)) then - p_xobs = xxpert - endif + if(associated(p_xobs)) then + p_xobs = xxpert + endif enddo if(iau_on_) then - if(associated(q_xini)) then - call gsi_bundleDestroy(q_xini) - deallocate(q_xini) - endif + if(associated(q_xini)) then + call gsi_bundledestroy(q_xini) + deallocate(q_xini) + endif endif d0 = zero do n=lbound(xobs,1),ubound(xobs,1) - d0 = d0+dot_product(xobs(n),xobs(n)) + d0 = d0+dot_product(xobs(n),xobs(n)) enddo if(ldprt_) print *, myname, ': total (gsi) dot product ', d0 -! Finalize TL model, and destroy xxpert at the same time. +! Finalize tl model, and destroy xxpert at the same time. call gsi_4dcoupler_final_model_tl(xini(1),xxpert,nymdi,nhmsi,rc=ierr) - if(ierr/=0) call die(myname,'gsi_4dcoupler_final_model_tl(), rc =',ierr) +if(ierr/=0) call die(myname,'gsi_4dcoupler_final_model_tl(), rc =',ierr) ! Finalize timer call timer_fnl('model_tl') @@ -302,60 +303,60 @@ subroutine model_tl(xini,xobs,ldprt) contains function istep_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) - !-- locate istep-th element in x, which is defined only at every intvl - !-- isteps. i.e., p_ => x(1), if istep=0; - !-- x(2), if istep=1*intvl; - !-- x(3), if istep=2*intvl; etc. - !-- null, otherwise. + !-- locate istep-th element in x, which is defined only at every intvl + !-- isteps. i.e., p_ => x(1), if istep=0; + !-- x(2), if istep=1*intvl; + !-- x(3), if istep=2*intvl; etc. + !-- null, otherwise. use mpeu_util,only: tell,warn,stdout implicit none type(gsi_bundle),pointer:: p_ type(gsi_bundle),target,dimension(:),intent(in):: x integer(i_kind),intent(in):: istep - integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements + integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements - logical ,intent(in):: verbose ! if information is needed - character(len=*),intent(in):: which ! for which this call is made. - integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time + logical ,intent(in):: verbose ! if information is needed + character(len=*),intent(in):: which ! for which this call is made. + integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time - integer:: i,isize_,intvl_ + integer(i_kind):: i,isize_,intvl_ isize_= size(x) intvl_= max(1,intvl) p_ =>null() - if (MOD(istep,intvl_)/=0) return + if (mod(istep,intvl_)/=0) return i=istep/intvl_+1 if (i<1.or.i>isize_) return if(verbose) write(stdout,'(1x,2a,i9.8,i7.6,2(i6,"/",i2.2))') which, & - '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ + '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ p_ => x(i) end function istep_locate_ function iau_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) - !-- locate IAU istep-th element in x, which is defined at corresponding - !-- istep values. i.e., p_=> null, if istep=0; - !-- x(1), if istep=0*intvl+1 .. 1*intvl; - !-- x(2), if istep=1*intvl+1 .. 2*intvl; etc. - !-- x(3), if istep=2*intvl+1 .. 3*intvl; etc. - !-- null, otherwise. + !-- locate iau istep-th element in x, which is defined at corresponding + !-- istep values. i.e., p_=> null, if istep=0; + !-- x(1), if istep=0*intvl+1 .. 1*intvl; + !-- x(2), if istep=1*intvl+1 .. 2*intvl; etc. + !-- x(3), if istep=2*intvl+1 .. 3*intvl; etc. + !-- null, otherwise. use mpeu_util,only: tell,warn,stdout implicit none type(gsi_bundle),pointer:: p_ type(gsi_bundle),target,dimension(:),intent(in):: x integer(i_kind),intent(in):: istep - integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements + integer(i_kind),intent(in):: intvl ! istep interval of two x(:) elements - logical ,intent(in):: verbose ! if information is needed - character(len=*),intent(in):: which ! for which this call is made. - integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time + logical ,intent(in):: verbose ! if information is needed + character(len=*),intent(in):: which ! for which this call is made. + integer(i_kind) ,intent(in):: nymdi,nhmsi ! current clock time - integer:: i,isize_,intvl_ + integer(i_kind):: i,isize_,intvl_ isize_= size(x) intvl_= max(1,intvl) @@ -366,7 +367,7 @@ function iau_locate_(x,istep,intvl, verbose,which,nymdi,nhmsi) result(p_) if (i<1.or.i>isize_) return if(verbose) write(stdout,'(1x,2a,i9.8,i7.6,2(i6,"/",i2.2))') which, & - '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ + '() -- (nymd,nhms,istep/intvl,i/size) =',nymdi,nhmsi,istep,intvl_,i,isize_ p_ => x(i) end function iau_locate_