module m_obsdiags !$$$ subprogram documentation block ! . . . . ! subprogram: module m_obsdiags ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2015-02-04 ! ! abstract: a bundle of GSI multiple obstypes and the obsdiags linked-lists ! ! 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, ! 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 ! []_mread() to skip unnecessary read() of some files ! containing no relevant observations. ! . 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 ! specific sections of obsdiags(:,:). ! . 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 ! ! 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: 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 m_obsLList, only: obsLList use m_psNode , only: psNode ! 1 use m_tNode , only: tNode ! 2 use m_wNode , only: wNode ! 3 use m_qNode , only: qNode ! 4 use m_spdNode , only: spdNode ! 5 use m_rwNode , only: rwNode ! 6 use m_dwNode , only: dwNode ! 7 use m_sstNode , only: sstNode ! 8 use m_pwNode , only: pwNode ! 9 use m_pcpNode , only: pcpNode ! 10 use m_ozNode , only: ozNode ! 11 use m_o3lNode , only: o3lNode ! 12 use m_gpsNode , only: gpsNode ! 13 use m_radNode , only: radNode ! 14 use m_tcpNode , only: tcpNode ! 15 use m_lagNode , only: lagNode ! 16 use m_colvkNode, only: colvkNode ! 17 use m_aeroNode , only: aeroNode ! 18 use m_aerolNode, only: aerolNode ! 19 use m_pm2_5Node, only: pm2_5Node ! 20 use m_gustNode , only: gustNode ! 21 use m_visNode , only: visNode ! 22 use m_pblhNode , only: pblhNode ! 23 use m_wspd10mNode , only: wspd10mNode ! 24 use m_td2mNode , only: td2mNode ! 25 use m_mxtmNode , only: mxtmNode ! 26 use m_mitmNode , only: mitmNode ! 27 use m_pmslNode , only: pmslNode ! 28 use m_howvNode , only: howvNode ! 29 use m_tcamtNode, only: tcamtNode ! 30 use m_lcbasNode, only: lcbasNode ! 31 use m_uwnd10mNode , only: uwnd10mNode use m_vwnd10mNode , only: vwnd10mNode use m_pm10Node , only: pm10Node ! 32 use m_cldchNode, only: cldchNode ! 33 use m_dbzNode, only: dbzNode ! 34 use m_swcpNode , only: swcpNode ! 34 use m_lwcpNode , only: lwcpNode ! 35 use m_lightNode, only: lightNode ! 36 use m_obsNodeTypeManager, only: nobs_type use gsi_4dvar , only: nobs_bins use obsmod, only: obsdiags ! (nobs_type,nobs_bins) implicit none private ! except 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 public:: obsdiags_create public:: obsdiags_destroy interface obsdiags_create ; module procedure create_obsmod_vars; end interface interface obsdiags_destroy; module procedure destroy_obsmod_vars; end interface public:: obsdiags_summary interface obsdiags_summary ; module procedure summary_ ; end interface public:: obsdiags_alwaysLocal logical,save:: obsdiags_alwaysLocal = .false. ! Note: User configurables ! ! (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 ! highest count of the actually accessible files. ! ! 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 ! 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: ! ! obsdiags_alwaysLocal sets an alternative default value of the optional ! argument of obsdiags_mread(..,alwaysLocal). ! ! 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+ ! reading some files. ! obsdiags_alwaysLocal==.true., override latlonRange_islocal(iPE). ! It let obsdiags_mread() to always open+read all file. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='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 ! 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. !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 :: pshead public :: tcphead public :: thead public :: whead public :: qhead public :: spdhead public :: rwhead public :: dbzhead public :: dwhead public :: ssthead public :: pcphead public :: pwhead public :: ozhead public :: o3lhead public :: aerohead public :: aerolhead public :: pm2_5head public :: gpshead public :: radhead public :: laghead public :: colvkhead public :: gusthead public :: vishead public :: pblhhead public :: wspd10mhead public :: uwnd10mhead public :: vwnd10mhead public :: td2mhead public :: mxtmhead public :: mitmhead public :: pmslhead public :: howvhead public :: tcamthead public :: lcbashead public :: pm10head public :: cldchhead public :: swcphead public :: lwcphead public :: lighthead type(obsLList),dimension(:),pointer :: pshead => null() type(obsLList),dimension(:),pointer :: tcphead => null() type(obsLList),dimension(:),pointer :: thead => null() type(obsLList),dimension(:),pointer :: whead => null() type(obsLList),dimension(:),pointer :: qhead => null() type(obsLList),dimension(:),pointer :: spdhead => null() type(obsLList),dimension(:),pointer :: rwhead => null() type(obsLList),dimension(:),pointer :: dbzhead => null() type(obsLList),dimension(:),pointer :: dwhead => null() type(obsLList),dimension(:),pointer :: ssthead => null() type(obsLList),dimension(:),pointer :: pcphead => null() type(obsLList),dimension(:),pointer :: pwhead => null() type(obsLList),dimension(:),pointer :: ozhead => null() type(obsLList),dimension(:),pointer :: o3lhead => null() type(obsLList),dimension(:),pointer :: aerohead => null() type(obsLList),dimension(:),pointer :: aerolhead => null() type(obsLList),dimension(:),pointer :: pm2_5head => null() type(obsLList),dimension(:),pointer :: gpshead => null() type(obsLList),dimension(:),pointer :: radhead => null() type(obsLList),dimension(:),pointer :: laghead => null() type(obsLList),dimension(:),pointer :: colvkhead => null() type(obsLList),dimension(:),pointer :: gusthead => null() type(obsLList),dimension(:),pointer :: vishead => null() type(obsLList),dimension(:),pointer :: pblhhead => null() type(obsLList),dimension(:),pointer :: wspd10mhead => null() type(obsLList),dimension(:),pointer :: uwnd10mhead => null() type(obsLList),dimension(:),pointer :: vwnd10mhead => null() type(obsLList),dimension(:),pointer :: td2mhead => null() type(obsLList),dimension(:),pointer :: mxtmhead => null() type(obsLList),dimension(:),pointer :: mitmhead => null() type(obsLList),dimension(:),pointer :: pmslhead => null() type(obsLList),dimension(:),pointer :: howvhead => null() type(obsLList),dimension(:),pointer :: tcamthead => null() type(obsLList),dimension(:),pointer :: lcbashead => null() type(obsLList),dimension(:),pointer :: pm10head => null() type(obsLList),dimension(:),pointer :: cldchhead => null() type(obsLList),dimension(:),pointer :: swcphead => null() type(obsLList),dimension(:),pointer :: lwcphead => null() type(obsLList),dimension(:),pointer :: lighthead => null() type(obsLList),dimension(:,:),pointer :: obsLLists => null() !type(obs_diags),dimension(:,:),pointer :: obsdiags => null() ! (nobs_type,nobs_bins) !#define DEBUG_TRACE #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 #else #define _TIMER_ON_(id) #define _TIMER_OFF_(id) #define _TIMER_USE_ #endif logical,parameter:: CHECK_SIZES_=.false. !logical,parameter:: CHECK_SIZES_=.true. !-- if(CHECK_SIZES_) then !-- these size counters, integer(i_kind),allocatable,dimension(:),save:: lsize_type ! luse counts of ob_type integer(i_kind),allocatable,dimension(:),save:: nsize_type ! total counts of ob_type integer(i_kind),allocatable,dimension(:),save:: lsize_diag ! luse counts of obs_diags integer(i_kind),allocatable,dimension(:),save:: msize_diag ! muse counts of obs_diags 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. !-- endif contains subroutine lobsdiags_statusCheck_(who,allocated) !-- check the allocation status of basic obsdiags components. use obsmod, only: luse_obsdiag implicit none character(len=*),intent(in):: who logical,intent(in):: 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 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 endif end subroutine lobsdiags_statusCheck_ subroutine mread_(cdfile,mPEs,force,ignore_iter,alwaysLocal) !$$$ subprogram documentation block ! . . . . ! subprogram: m_obdiags::mread_ ! prgmmr: tremolet ! ! abstract: Read obsdiags data structure from file. ! ! program history log: ! 2007-07-05 tremolet ! 2007-08-04 todling - using get_lun to determine file unit number ! 2007-10-03 todling - expanded to account for full observer ! 2009-01-08 todling - remove reference to ozohead ! 2009-01-23 todling - add read_gpshead ! 2009-04-02 meunier - add read_laghead ! 2010-04-27 tangborn - addded read_colvkhead ! 2010-05-26 treadon - add read_tcphead ! 2011-05-18 todling - aero, aerol, and pm2_5 ! 2011-09-20 hclin - 1d wij for aero ! 2015-02-04 j guo - Re-implemented to support re-configurable observation ! operators. read_() is split to read_() for a single ! file, and mread_() for one file only or all files for ! redistribution ! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. ! ! input argument list: ! cdfile - filename to read data from ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block use mpeu_util, only: tell,perr,die,stdout_open,stdout_close,stdout _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 implicit none character(len=*), intent(in) :: cdfile ! prefix, "obsdiags." 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. logical ,optional,intent(in):: ignore_iter ! ignore iter checking 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):: jtyp,jread logical:: force_read logical:: alwaysLocal_ logical:: fileislocal type(latlonRange),allocatable,dimension(:):: allRanges _ENTRY_(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 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 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 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 endif ! 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. 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") #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, & ignore_iter=ignore_iter, & 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. ! ! 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 latlonRange_reset(allRanges) deallocate(allRanges) else ! of if(redistr) call read_(cdfile,myPE,redistr,fileislocal=.true., & force=force, & ignore_iter=ignore_iter, & verbose=.true.) endif ! of if(redistr) 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( 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(lobserver) then if(.not.force_read) then !call destroyobs( skipit=.true.) call reset_(obsdiags_keep=.true.) endif endif !call stdout_close() _TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine mread_ subroutine reset_(obsdiags_keep) use obsmod, only: obsdiags use obsmod, only: luse_obsdiag use obsmod, only: lobsdiag_allocated use m_obsdiagNode, only: obsdiagLList_reset use m_obsLList, only: obsLList_reset use m_obsNode , only: obsNode use m_obsNodeTypeManager, only: obsNode_typeMold ! use m_wspd10mNode, only: obsLList_reset ! use m_td2mNode, only: obsLList_reset ! use m_mxtmNode, only: obsLList_reset ! use m_mitmNode, only: obsLList_reset ! use m_pmslNode, only: obsLList_reset ! use m_howvNode, only: obsLList_reset ! use m_tcamtNode, only: obsLList_reset ! use m_lcbasNode, only: obsLList_reset ! use m_pm10Node, only: obsLList_reset ! use m_cldchNode, only: obsLList_reset _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_ _ENTRY_(myname_) _TIMER_ON_(myname_) _TRACEV_(myname_,'lobsdiag_allocated =',lobsdiag_allocated) _TRACEV_(myname_,'lobsdiags_allocated_ =',lobsdiags_allocated_) if(luse_obsdiag) then if(.not.lobsdiags_allocated_) then lobsdiags_allocated_=.true. if(.not.associated(obsdiags)) then; call die(myname_,'associated(obsdiags)=',associated(obsdiags)); endif !allocate( obsdiags(nobs_type,nobs_bins)) endif ASSERT(all(shape(obsdiags)==shape(obsLLists))) ASSERT(size(obsdiags,1)==size(obsLLists,1)) ASSERT(size(obsdiags,2)==size(obsLLists,2)) endif if(.not.lobstypes_allocated_) then lobstypes_allocated_=.true. if(.not.associated(obsLLists)) call die(myname_,'.not.associated(obsLLists)') endif 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. endif endif mNode_ => obsNode_typeMold(jj) ! get the ob_type of jj if(.not.associated(mNode_)) then call perr(myname_,'obsNode_typeMold(jtype) not associated, jtype =',jj) call perr(myname_,' ubound(obsLLists,1) =',size(obsLLists,1)) call perr(myname_,' ibin =',ii) call perr(myname_,' ubound(obsLLists,2) =',size(obsLLists,2)) call die(myname_) endif 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_) endif mNode_ => null() enddo enddo _TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine reset_ function ptr_obsbins_(oll,vname) result(ptr_) !-- returns a pointer to the list of vname, from array oll. use m_obsNodeTypeManager, only: obsNode_typeIndex implicit none type(obsLList),pointer,dimension(:):: ptr_ type(obsLList),dimension(:,:),target, intent(in):: oll character(len=*) , intent(in):: vname character(len=*),parameter:: myname_=myname//"::ptr_obsbins_" integer(i_kind):: itype _ENTRY_(myname_) itype = obsNode_typeIndex(vname) ! e.g. vname="ps" ptr_ => null() ! e.g. if(.not.associated(ptr_)) ... ASSERT(itype>0) ASSERT(itype<=size(oll,1)) ptr_ => oll(itype,:) _EXIT_(myname_) return end function ptr_obsbins_ subroutine aliasesCreate_() implicit none character(len=*),parameter:: myname_=myname//"aliasesCreate_" _ENTRY_(myname_) !! too much to declare, if use enumerated index value directly ! pshead => obsllists(i_ps_ob_type,:) ! too much to declare ! pshead => ptr_obsLList(obsllists,i_ps_ob_type) ! too much to declare ! pshead => ptr_obsLList(obsllists,iobstype_ps) ! too much to declare !! use a vname may be a balance ! pshead => ptr_obsLList(obsllists,'ps') ! name is less explicit ! pshead => ptr_psbins(obsllists) ! too many to implement ! pshead => ptr_obsbins(obsllists,'ps') ! explicit and minimal-ism !! an example of m_obsNodeTypeManager implementation ! use m_obsNodeTypeManager, only: obsType_mold ! ! index_mold(index=i_ps_ob_type) ! ! vname_mold(vname="ps"|"[psNode]") ! use m_obsNodeTypeManager, only: obsType_index ! ! vname_index(vname='ps'|'[psNode]') ! ! vmold_index(vmold=psNode()) !! to implement ptr_obsbins() ! function ptr_obsbins(obsllists,vname) result(ptr_) ! use m_obsNodeTypeManager, only: obsType_index ! iobstype = obsType_index(vname) ! e.g. vname="ps" ! ptr_ => obsllists(iobstype,:) pshead => ptr_obsbins_(obsllists,'ps') thead => ptr_obsbins_(obsllists,'t') whead => ptr_obsbins_(obsllists,'w') qhead => ptr_obsbins_(obsllists,'q') spdhead => ptr_obsbins_(obsllists,'spd') rwhead => ptr_obsbins_(obsllists,'rw') dbzhead => ptr_obsbins_(obsllists,'dbz') dwhead => ptr_obsbins_(obsllists,'dw') ssthead => ptr_obsbins_(obsllists,'sst') pwhead => ptr_obsbins_(obsllists,'pw') ozhead => ptr_obsbins_(obsllists,'oz') o3lhead => ptr_obsbins_(obsllists,'o3l') pcphead => ptr_obsbins_(obsllists,'pcp') gpshead => ptr_obsbins_(obsllists,'gps') radhead => ptr_obsbins_(obsllists,'rad') tcphead => ptr_obsbins_(obsllists,'tcp') laghead => ptr_obsbins_(obsllists,'lag') colvkhead => ptr_obsbins_(obsllists,'colvk') aerohead => ptr_obsbins_(obsllists,'aero') aerolhead => ptr_obsbins_(obsllists,'aerol') pm2_5head => ptr_obsbins_(obsllists,'pm2_5') vishead => ptr_obsbins_(obsllists,'vis') gusthead => ptr_obsbins_(obsllists,'gust') pblhhead => ptr_obsbins_(obsllists,'pblh') wspd10mhead => ptr_obsbins_(obsllists,'wspd10m') uwnd10mhead => ptr_obsbins_(obsllists,'uwnd10m') vwnd10mhead => ptr_obsbins_(obsllists,'vwnd10m') td2mhead => ptr_obsbins_(obsllists,'td2m') mxtmhead => ptr_obsbins_(obsllists,'mxtm') mitmhead => ptr_obsbins_(obsllists,'mitm') pmslhead => ptr_obsbins_(obsllists,'pmsl') howvhead => ptr_obsbins_(obsllists,'howv') tcamthead => ptr_obsbins_(obsllists,'tcamt') lcbashead => ptr_obsbins_(obsllists,'lcbas') pm10head => ptr_obsbins_(obsllists,'pm10') cldchhead => ptr_obsbins_(obsllists,'cldch') swcphead => ptr_obsbins_(obsllists,'swcp') lwcphead => ptr_obsbins_(obsllists,'lwcp') lighthead => ptr_obsbins_(obsllists,'light') _EXIT_(myname_) return end subroutine aliasesCreate_ subroutine aliasesDestroy_() implicit none character(len=*),parameter:: myname_=myname//"aliasesDestroy_" _ENTRY_(myname_) pshead => null() thead => null() whead => null() qhead => null() spdhead => null() rwhead => null() dbzhead => null() dwhead => null() ssthead => null() pwhead => null() ozhead => null() o3lhead => null() pcphead => null() gpshead => null() radhead => null() tcphead => null() laghead => null() colvkhead => null() aerohead => null() aerolhead => null() pm2_5head => null() vishead => null() gusthead => null() pblhhead => null() wspd10mhead => null() uwnd10mhead => null() vwnd10mhead => null() td2mhead => null() mxtmhead => null() mitmhead => null() pmslhead => null() howvhead => null() tcamthead => null() lcbashead => null() pm10head => null() cldchhead => null() swcphead => null() lwcphead => null() lighthead => null() _EXIT_(myname_) return end subroutine aliasesDestroy_ subroutine lsort_() !$$$ subprogram documentation block ! ! abstract: sort entries of obsdiags(:,:) and obsLLists(:,:) ! ! program history log: ! ! input argument list: ! !$$$ 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 _TIMER_USE_ implicit none character(len=*), parameter :: myname_=myname//"::lsort_" integer(i_kind) :: ii,jj !,iobs,lobs,ierr _ENTRY_(myname_) _TIMER_ON_(myname_) ! ---------------------------------------------------------- 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)) endif do jj=1,size(obsdiags,1) do ii=1,size(obsdiags,2) 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) enddo enddo ! ---------------------------------------------------------- _TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine lsort_ subroutine write_(cdfile,luseonly,force) !$$$ subprogram documentation block ! ! abstract: Write obsdiags data structure to file. ! ! program history log: ! 2007-07-05 tremolet ! 2007-10-03 todling - expanded to account for full observer ! 2007-10-24 todling - add parameter nchnperobs to obsdiag ! 2009-01-08 todling - remove reference to ozohead ! 2009-01-27 todling - add gps write ! 2010-05-26 treadon - add write_tcphead ! 2010-06-03 todling - add write_colvkhead ! 2011-05-18 todling - aero, aerol, and pm2_5 ! 2015-02-04 j guo - Re-implemented to support re-configurable observation ! operators. ! 2015-10-09 j guo - Now it uses Fortran 2003 dynamic polymorphism. ! ! input argument list: ! cdfile - filename to write data ! !$$$ 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: nobs_bins,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_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." logical,optional, intent(in) :: luseonly ! output only if(%luse) logical,optional, intent(in) :: force ! write all out regardlessly 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 ! ---------------------------------------------------------- _ENTRY_(myname_) _TIMER_ON_(myname_) !call stdout_open("obsdiags_write") force_write=.false. if(present(force)) force_write=force 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)) luseonly_=.false. if(present(luseonly)) luseonly_=luseonly call unformatted_open( unit=iunit, & 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(DO_SUMMARY) call summary_(myname_) do ii=1,nobs_bins do jj=1,nobs_type 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 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) #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) #endif 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)) ! ---------------------------------------------------------- !call stdout_close() _TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine write_ subroutine read_(cdfile,iPE,redistr,fileislocal,force,ignore_iter,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_ use obsmod, only: lobserver use obsmod, only: obs_diag use m_obsLList, only: obsLList_read use m_obsLList, only: obsLList_lsize use m_obsLList, only: obsLList_lcount 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 logical , intent(in ):: redistr ! data redistribution is expected logical , intent(in ):: fileislocal ! the file to read, is known local logical,optional, intent(in ):: force ! (force to read ob_type data logical,optional, intent(in ):: ignore_iter ! ignore checking of iter logical,optional, intent(in ):: verbose ! report each reading 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' 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() logical:: force_read logical:: verbose_ _ENTRY_(myname_) _TIMER_ON_(myname_) 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 call unformatted_open( unit=iunit, & 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() 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,ignore_iter=ignore_iter) 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_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 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 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_ 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 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 enddo ! jj=1,nobs_type enddo ! ii=1,nobs_bins close(iunit) ! ---------------------------------------------------------- _TIMER_OFF_(myname_) _EXIT_(myname_) return end subroutine read_ function filename_(prefix,iPE) implicit none character(len=:),allocatable:: filename_ character(len=*) , intent(in ):: prefix integer(kind=i_kind), intent(in ):: iPE character(len=4):: chPE write(chPE,'(i4.4)') iPE filename_=trim(adjustl(prefix))//'.'//trim(chPE) end function filename_ function hdfilename_(prefix) use kinds, only: i_kind implicit none character(len=:),allocatable:: hdfilename_ character(len=*) , intent(in ):: prefix hdfilename_=trim(adjustl(prefix))//'.headers' 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_ 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 implicit none character(len=*), intent(in) :: title character(len=*), parameter :: myname_=myname//"::summary_" integer(i_kind) :: ii,jj 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_) ! ---------------------------------------------------------- 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)) 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 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_) _EXIT_(myname_) return end subroutine summary_ subroutine gather_write_(title,lobss,ldiag,nobss,ndiag,root,comm) use mpimod , only: mype,nPE use kinds , only: i_kind 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 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),allocatable,dimension(:,:,:):: ldiagm,ndiagm integer(kind=i_kind),allocatable,dimension(:,:,:):: lobssm,nobssm _ENTRY_(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 endif deallocate(lobssm) deallocate(ldiagm) deallocate(nobssm) deallocate(ndiagm) _TIMER_OFF_(myname_) _EXIT_(myname_) end subroutine gather_write_ subroutine iMPI_barrier_(comm) use mpeu_mpif, only: MPI_ikind use mpeu_util, only: die implicit none integer(kind=MPI_ikind),intent(in):: comm 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_ 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 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, & irecv,isize,itype, root,comm,ierr) 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 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 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) !iredu(:)=irecv(:) end subroutine iMPI_reduceSUM_ subroutine create_obsmod_vars() !$$$ subprogram documentation block ! . . . . ! subprogram: create_obsmod_vars ! prgmmr: derber org: np23 date: 2003-09-25 ! ! abstract: allocate arrays to hold observation related information ! ! program history log: ! 2003-09-25 derber ! 2004-05-13 treadon, documentation ! 2015-10-09 j guo - moved here from MODULE OBSMOD with modifcations ! ! input argument list: ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ibm rs/6000 sp ! !$$$ end documentation block use gsi_4dvar, only: nobs_bins implicit none !ALLOCATE(obsdiags(nobs_type,nobs_bins)) allocate(obsllists(nobs_type,nobs_bins)) call aliasesCreate_() return end subroutine create_obsmod_vars subroutine destroy_obsmod_vars() !-- Created to pair with create_obsmod_vars(). implicit none call aliasesDestroy_() deallocate(obsllists) !deallocate(obsdiags) return end subroutine destroy_obsmod_vars end module m_obsdiags