module gsi_lightOper !$$$ subprogram documentation block ! . . . . ! subprogram: module gsi_lightOper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! ! abstract: an obOper extension for lightNode type ! ! program history log: ! 2018-08-10 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 ! module interface: use gsi_obOper, only: obOper use m_lightNode, only: lightNode use kinds , only: i_kind implicit none public:: lightOper ! data stracture public:: lightOper_config interface lightOper_config; module procedure config_; end interface type,extends(obOper):: lightOper contains procedure,nopass:: mytype procedure,nopass:: nodeMold procedure:: setup_ procedure:: intjo1_ procedure:: stpjo1_ end type lightOper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='gsi_lightOper' type(lightNode),save,target:: myNodeMold_ !> Configurations specific to this observation operator. logical,parameter:: DEFAULT_USE_NSIG_SAVED_=.false. logical ,save:: use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ integer(kind=i_kind),save:: nsig_saved_ !> At gsi_obOpers coupling time, e.g. !> !> > call obopers_config() !> !> which does !> !> > use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save !> > if (use_gfs_stratosphere) then !> > call lightOper_config(nsig_save=nsig_save) !> > endif !> contains subroutine config_(nsig_save,use_nsig_save) !> config_() is the place to couple configurations external to !> gsi_lwOper and gsi_obOper. Some of these external configurations will !> gradually become obsolete through refactorings. !> call implicit none integer(i_kind),optional:: nsig_save ! set nsig_save if present logical ,optional:: use_nsig_save ! switch the use of nsig_save logical:: reset_ reset_=.true. if(present(use_nsig_save)) then use_nsig_saved_=use_nsig_save reset_=.false. endif if(present( nsig_save)) then nsig_saved_=nsig_save use_nsig_saved_=.true. reset_=.false. endif if(reset_) use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ end subroutine config_ !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype mytype="[lightOper]" if(present(nodetype)) then if(nodetype) mytype=myNodeMold_%mytype() endif end function mytype function nodeMold() !> %nodeMold() returns a mold of its corresponding obsNode use m_obsNode, only: obsNode implicit none class(obsNode),pointer:: nodeMold nodeMold => myNodeMold_ end function nodeMold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use light_setup, only: setup use kinds, only: i_kind use gsi_obOper, only: len_obstype use gsi_obOper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork use m_rhs , only: iwork => i_light use obsmod , only: write_diag use lightinfo,only: diag_light use jfunc , only: jiter use mpeu_util, only: die implicit none class(lightOper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is integer(i_kind), intent(in):: nobs logical , intent(in):: init_pass ! supporting multi-pass setup() logical , intent(in):: last_pass ! with incremental backgrounds. !---------------------------------------- character(len=*),parameter:: myname_=myname//"::setup_" character(len=len_obstype):: obstype character(len=len_isis ):: isis integer(i_kind):: nreal,nchanl,ier,nele logical:: diagsave if(nobs == 0) return read(lunin,iostat=ier) obstype,isis,nreal,nchanl if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) nele = nreal+nchanl diagsave = write_diag(jiter) .and. diag_light call setup(self%obsLL(:), self%odiagLL(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) end subroutine setup_ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intlightmod, only: intjo => intlight use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use m_obsNode , only: obsNode use m_obsLList, only: obsLList_headNode use kinds , only: i_kind, r_quad implicit none class(lightOper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) real(r_quad ),target,dimension(:),intent(inout):: qpred ! (ibin) type(predictors),target, intent(in ):: sbias !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" class(obsNode),pointer:: headNode headNode => obsLList_headNode(self%obsLL(ibin)) call intjo(headNode, rval,sval) headNode => null() end subroutine intjo1_ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stplightmod, only: stpjo => stplight use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors use m_obsNode , only: obsNode use m_obsLList, only: obsLList_headNode use kinds, only: r_quad,r_kind,i_kind implicit none class(lightOper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval real(r_quad ),dimension(:),intent(inout):: pbcjo ! (1:4) real(r_kind ),dimension(:),intent(in ):: sges integer(i_kind),intent(in):: nstep type(predictors),target, intent(in):: dbias type(predictors),target, intent(in):: xbias !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" class(obsNode),pointer:: headNode headNode => obsLList_headNode(self%obsLL(ibin)) call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) headNode => null() end subroutine stpjo1_ end module gsi_lightOper