diff --git a/src/gsi/m_tNode.F90 b/src/gsi/m_tNode.F90 deleted file mode 100644 index 8ddb9fb1ed..0000000000 --- a/src/gsi/m_tNode.F90 +++ /dev/null @@ -1,395 +0,0 @@ -module m_tNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_tNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type tNode ((virtual) temperature) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2019-09-20 X.Su - add new variational QC parameters -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: tNode - - type,extends(obsNode):: tNode - !type(t_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! temperature residual - real(r_kind) :: err2 ! temperature error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: jb ! variational quality control parameter - integer(i_kind) :: ib ! new variational quality control parameter - integer(i_kind) :: ik ! new variational quality control parameter - real(r_kind) :: tlm_tsfc(6) ! sensitivity vector for sfc temp - ! forward model - real(r_kind) :: wij(8) ! horizontal interpolation weights - real(r_kind) :: tpertb ! random number adding to the obs - !logical :: luse ! flag indicating if ob is used in pen. - logical :: use_sfc_model ! logical flag for using boundary model - logical :: tv_ob ! logical flag for virtual temperature or - integer(i_kind) :: idx ! index of tail number - real(r_kind),dimension(:),pointer :: pred => NULL() - ! predictor for aircraft temperature bias - integer(i_kind) :: k1 ! level of errtable 1-33 - integer(i_kind) :: kx ! ob type - integer(i_kind) :: ij(8) ! horizontal locations - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - real (r_kind) :: dlev ! reference to the vertical grid - - integer(i_kind) :: ich0=0 ! ich code to mark derived data. See - ! tNode_ich0 and tNode_ich0_PBL_Pseudo below - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - procedure:: init => obsNode_init_ - procedure:: clean => obsNode_clean_ - end type tNode - - public:: tNode_typecast - public:: tNode_nextcast - interface tNode_typecast; module procedure typecast_ ; end interface - interface tNode_nextcast; module procedure nextcast_ ; end interface - - public:: tNode_appendto - interface tNode_appendto; module procedure appendto_ ; end interface - - public:: tNode_ich0 - public:: tNode_ich0_pbl_pseudo - integer(i_kind),parameter:: tNode_ich0 = 0 - integer(i_kind),parameter:: tNode_ich0_pbl_pseudo = tNode_ich0+1 - - character(len=*),parameter:: MYNAME="m_tNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(tNode) - use m_obsNode, only: obsNode - implicit none - type(tNode ),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(tNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(tNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(tNode ),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(tNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[tNode]" -end function mytype - -subroutine obsNode_init_(aNode) - use aircraftinfo, only: npredt,aircraft_t_bc,aircraft_t_bc_pof - implicit none - class(tNode),intent(out):: aNode - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_init_' -_ENTRY_(myname_) - - !aNode = _obsNode_() - aNode%llpoint => null() - aNode%luse = .false. - aNode%elat = 0._r_kind - aNode%elon = 0._r_kind - aNode%time = 0._r_kind - aNode%idv =-1 - aNode%iob =-1 - !-aNode%dlev = 0._r_kind - !-aNode%ich =-1._i_kind - - if(aircraft_t_bc_pof .or. aircraft_t_bc) then - allocate(aNode%pred(npredt)) - else - allocate(aNode%pred(0)) - endif -_EXIT_(myname_) -return -end subroutine obsNode_init_ - -subroutine obsNode_clean_(aNode) - implicit none - class(tNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_clean_' -_ENTRY_(myname_) -!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) - if(associated(aNode%pred)) deallocate(aNode%pred) -_EXIT_(myname_) -return -end subroutine obsNode_clean_ - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof - implicit none - class(tNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent( out):: istat - type(obs_diags),intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - skip_=.false. - if(present(skip)) skip_=skip - - istat=0 - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - if (.not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%use_sfc_model, & - aNode%tlm_tsfc , & - aNode%tpertb , & - aNode%tv_ob , & - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if(istat/=0) then - call perr(myname_,'read(%(res,err2,...), iostat =',istat) - call perr(myname_,' .not.(aircraft_t_bc_pof =',aircraft_t_bc_pof) - call perr(myname_,' .or.aircraft_t_bc) =',aircraft_t_bc) - _EXIT_(myname_) - return - endif - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%use_sfc_model, & - aNode%tlm_tsfc , & - aNode%tpertb , & - aNode%tv_ob , & - aNode%idx , & ! - aNode%pred(:) , & ! (1:npred) - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if(istat/=0) then - call perr(myname_,'read(%res,err2,...), iostat =',istat) - call perr(myname_,' aircraft_t_bc_pof =',aircraft_t_bc_pof) - call perr(myname_,' .or.aircraft_t_bc =',aircraft_t_bc) - _EXIT_(myname_) - return - endif - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+1_i_kind) - if(.not.associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call perr(myname_,' %ich0 =',aNode%ich0) - call die(myname_) - endif - endif -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof - implicit none - class(tNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' -_ENTRY_(myname_) - - jstat=0 - if (.not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%use_sfc_model, & - aNode%tlm_tsfc , & - aNode%tpertb , & - aNode%tv_ob , & - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if(jstat/=0) then - call perr(myname_,'write(%(res,err2,...), iostat =',jstat) - call perr(myname_,' .not.(aircraft_t_bc_pof =',aircraft_t_bc_pof) - call perr(myname_,' .or.aircraft_t_bc) =',aircraft_t_bc) - _EXIT_(myname_) - return - endif - else - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2 , & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%use_sfc_model, & - aNode%tlm_tsfc , & - aNode%tpertb , & - aNode%tv_ob , & - aNode%idx , & ! - aNode%pred(:) , & ! (1:npredt) - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if(jstat/=0) then - call perr(myname_,'write(%res,err2,...), iostat =',jstat) - call perr(myname_,' aircraft_t_bc_pof =',aircraft_t_bc_pof) - call perr(myname_,' .or.aircraft_t_bc =',aircraft_t_bc) - _EXIT_(myname_) - return - endif - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(tNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij) -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(tNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -_ENTRY_(myname_) - isvalid_=associated(aNode%diags) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(tNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_tNode diff --git a/src/gsi/m_tcpNode.F90 b/src/gsi/m_tcpNode.F90 deleted file mode 100644 index 6a5edf5e70..0000000000 --- a/src/gsi/m_tcpNode.F90 +++ /dev/null @@ -1,248 +0,0 @@ -module m_tcpNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_tcpNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type tcpNode (TC MSLP data) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: tcpNode - - type,extends(obsNode):: tcpNode - !type(tcp_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! surface pressure residual - real(r_kind) :: err2 ! surface pressure error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - real(r_kind) :: ppertb ! random number adding to the obs - integer(i_kind) :: ij(4) ! horizontal locations - integer(i_kind) :: kx ! ob type - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type tcpNode - - public:: tcpNode_typecast - public:: tcpNode_nextcast - interface tcpNode_typecast; module procedure typecast_ ; end interface - interface tcpNode_nextcast; module procedure nextcast_ ; end interface - - public:: tcpNode_appendto - interface tcpNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_tcpNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(tcpNode) - use m_obsNode, only: obsNode - implicit none - type(tcpNode ),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(tcpNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(tcpNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(tcpNode ),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(tcpNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[tcpNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(tcpNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%ppertb , & - aNode%kx , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(tcpNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%ppertb , & - aNode%kx , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(tcpNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(tcpNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(tcpNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_tcpNode diff --git a/src/gsi/m_tcpnode.F90 b/src/gsi/m_tcpnode.F90 new file mode 100644 index 0000000000..a00826d923 --- /dev/null +++ b/src/gsi/m_tcpnode.F90 @@ -0,0 +1,248 @@ +module m_tcpnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_tcpnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type tcpnode (tc mslp data) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: tcpnode + + type,extends(obsnode):: tcpnode + !type(tcp_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! surface pressure residual + real(r_kind) :: err2 ! surface pressure error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + real(r_kind) :: ppertb ! random number adding to the obs + integer(i_kind) :: ij(4) ! horizontal locations + integer(i_kind) :: kx ! ob type + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type tcpnode + + public:: tcpnode_typecast + public:: tcpnode_nextcast + interface tcpnode_typecast; module procedure typecast_ ; end interface + interface tcpnode_nextcast; module procedure nextcast_ ; end interface + + public:: tcpnode_appendto + interface tcpnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_tcpnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(tcpnode) + use m_obsnode, only: obsnode + implicit none + type(tcpnode ),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(tcpnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(tcpnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(tcpnode ),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(tcpnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[tcpnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(tcpnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%ppertb , & + anode%kx , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(tcpnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%ppertb , & + anode%kx , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(tcpnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(tcpnode),intent(in):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +_ENTRY_(myname_) + isvalid_= associated(anode%diags) +_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(tcpnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_tcpnode diff --git a/src/gsi/m_td2mNode.F90 b/src/gsi/m_td2mNode.F90 deleted file mode 100644 index 3ad005dc69..0000000000 --- a/src/gsi/m_td2mNode.F90 +++ /dev/null @@ -1,244 +0,0 @@ -module m_td2mNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_td2mNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type td2mNode (2-m dew point temperature) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: td2mNode - - type,extends(obsNode):: td2mNode - ! private - !type(td2m_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! td2m residual - real(r_kind) :: err2 ! td2m error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type td2mNode - - public:: td2mNode_typecast - public:: td2mNode_nextcast - interface td2mNode_typecast; module procedure typecast_ ; end interface - interface td2mNode_nextcast; module procedure nextcast_ ; end interface - - public:: td2mNode_appendto - interface td2mNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_td2mNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(td2mNode) - use m_obsNode, only: obsNode - implicit none - type(td2mNode),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(td2mNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(td2mNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(td2mNode),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(td2mNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[td2mNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(td2mNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(td2mNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(td2mNode),intent(inout):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -!_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -!_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(td2mNode),intent(in):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -!_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -!_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(td2mNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_td2mNode diff --git a/src/gsi/m_td2mnode.F90 b/src/gsi/m_td2mnode.F90 new file mode 100644 index 0000000000..c79b0ddd52 --- /dev/null +++ b/src/gsi/m_td2mnode.F90 @@ -0,0 +1,244 @@ +module m_td2mnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_td2mnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type td2mnode (2-m dew point temperature) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: td2mnode + + type,extends(obsnode):: td2mnode + ! private + !type(td2m_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! td2m residual + real(r_kind) :: err2 ! td2m error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type td2mnode + + public:: td2mnode_typecast + public:: td2mnode_nextcast + interface td2mnode_typecast; module procedure typecast_ ; end interface + interface td2mnode_nextcast; module procedure nextcast_ ; end interface + + public:: td2mnode_appendto + interface td2mnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_td2mnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(td2mnode) + use m_obsnode, only: obsnode + implicit none + type(td2mnode),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(td2mnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(td2mnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(td2mnode),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(td2mnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[td2mnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(td2mnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(td2mnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(td2mnode),intent(inout):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +!_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +!_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(td2mnode),intent(in):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +!_ENTRY_(myname_) + isvalid_= associated(anode%diags) +!_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(td2mnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_td2mnode diff --git a/src/gsi/m_tick.F90 b/src/gsi/m_tick.F90 index b2285f5788..5f5eb5d63d 100644 --- a/src/gsi/m_tick.F90 +++ b/src/gsi/m_tick.F90 @@ -12,7 +12,7 @@ module m_tick ! ! subroutines included: ! sub tick -! sub INCYMD +! sub incymd ! sub leap_year ! ! attributes: @@ -20,9 +20,9 @@ module m_tick ! machine: ! !$$$ end documentation block -use kinds, only: i_kind + use kinds, only: i_kind -implicit none + implicit none ! set default to private private @@ -33,7 +33,7 @@ module m_tick #ifdef ibm_sp - subroutine tick (nymd, nhms, ndt) +subroutine tick (nymd, nhms, ndt) !$$$ subprogram documentation block ! . . . . ! subprogram: tick @@ -68,7 +68,7 @@ end subroutine tick #else - subroutine tick (nymd, nhms, ndt) +subroutine tick (nymd, nhms, ndt) !$$$ subprogram documentation block ! . . . . ! subprogram: tick @@ -96,48 +96,48 @@ subroutine tick (nymd, nhms, ndt) implicit none ! Input: - integer(i_kind),intent(in ) :: ndt ! TIME-STEP + integer(i_kind),intent(in ) :: ndt ! Time-step ! Input/Output: - integer(i_kind),intent(inout) :: nymd ! CURRENT YYYYMMDD - integer(i_kind),intent(inout) :: nhms ! CURRENT HHMMSS + integer(i_kind),intent(inout) :: nymd ! Current yyyymmdd + integer(i_kind),intent(inout) :: nhms ! Current hhmmss ! Local: - integer(i_kind) :: NSECF, NHMSF, NSEC, N + integer(i_kind) :: nsecf, nhmsf, nsec, n ! Origin: L.L. Takacs ! Revision: S.-J. Lin Mar 2000 - NSECF(N) = N/10000*3600 + MOD(N,10000)/100* 60 + MOD(N,100) - NHMSF(N) = N/3600*10000 + MOD(N,3600 )/ 60*100 + MOD(N, 60) + nsecf(n) = n/10000*3600 + mod(n,10000)/100* 60 + mod(n,100) + nhmsf(n) = n/3600*10000 + mod(n,3600 )/ 60*100 + mod(n, 60) - NSEC = NSECF(NHMS) + ndt + nsec = nsecf(nhms) + ndt - IF (NSEC>86400) THEN - DO WHILE (NSEC>86400) - NSEC = NSEC - 86400 - NYMD = INCYMD (NYMD,1) - ENDDO - ENDIF + if (nsec>86400) then + do while (nsec>86400) + nsec = nsec - 86400 + nymd = invymd (nymd,1) + enddo + endif - IF (NSEC==86400) THEN - NSEC = 0 - NYMD = INCYMD (NYMD,1) - ENDIF + if (nsec==86400) then + nsec = 0 + nymd = invymd (nymd,1) + endif - IF (NSEC < 0) THEN - DO WHILE (NSEC < 0) - NSEC = 86400 + NSEC - NYMD = INCYMD (NYMD,-1) - ENDDO - ENDIF + if (nsec < 0) then + do while (nsec < 0) + nsec = 86400 + nsec + nymd = invymd (nymd,-1) + enddo + endif - NHMS = NHMSF (NSEC) - return - end subroutine tick + nhms = nhmsf (nsec) + return +end subroutine tick - integer(i_kind) FUNCTION INCYMD (NYMD,M) +integer(i_kind) function invymd (nymd,m) !$$$ subprogram documentation block ! . . . . -! subprogram: INCYMD +! subprogram: invymd ! prgmmr: ! ! abstract: @@ -146,7 +146,7 @@ integer(i_kind) FUNCTION INCYMD (NYMD,M) ! 2009-08-06 lueken - added subprogram doc block ! ! input argument list: -! NYMD +! nymd ! M ! ! output argument list: @@ -158,50 +158,50 @@ integer(i_kind) FUNCTION INCYMD (NYMD,M) !$$$ end documentation block implicit none -! PURPOSE -! INCYMD: NYMD CHANGED BY ONE DAY -! MODYMD: NYMD CONVERTED TO JULIAN DATE -! DESCRIPTION OF PARAMETERS -! NYMD CURRENT DATE IN YYMMDD FORMAT -! M +/- 1 (DAY ADJUSTMENT) - - INTEGER(i_kind) NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, & - 31, 31, 30, 31, 30, 31/ - INTEGER(i_kind),intent(in):: NYMD, M - INTEGER(i_kind) NY, NM, ND - - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - - IF (ND==0) THEN - NM = NM - 1 - IF (NM==0) THEN - NM = 12 - NY = NY - 1 - ENDIF - ND = NDPM(NM) - IF (NM==2 .AND. leap_year(NY)) ND = 29 - ENDIF - - IF (.not. (ND==29 .AND. NM==2 .AND. leap_year(ny))) then - - IF (ND>NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM>12) THEN - NM = 1 - NY = NY + 1 - ENDIF - ENDIF - - end if - INCYMD = NY*10000 + NM*100 + ND - RETURN - END function INCYMD - - logical function leap_year(ny) +! Purpose +! invymd: nymd changed by one day +! modymd: nymd converted to julian date +! Description of parameters +! nymd current date in yymmdd format +! m +/- 1 (day adjustment) + + integer(i_kind) ndpm(12) + data ndpm /31, 28, 31, 30, 31, 30, & + 31, 31, 30, 31, 30, 31/ + integer(i_kind),intent(in):: nymd, m + integer(i_kind) ny, nm, nd + + ny = nymd / 10000 + nm = mod(nymd,10000) / 100 + nd = mod(nymd,100) + m + + if (nd==0) then + nm = nm - 1 + if (nm==0) then + nm = 12 + ny = ny - 1 + endif + nd = ndpm(nm) + if (nm==2 .and. leap_year(ny)) nd = 29 + endif + + if (.not. (nd==29 .and. nm==2 .and. leap_year(ny))) then + + if (nd>ndpm(nm)) then + nd = 1 + nm = nm + 1 + if (nm>12) then + nm = 1 + ny = ny + 1 + endif + endif + + end if + invymd = ny*10000 + nm*100 + nd + return +end function invymd + +logical function leap_year(ny) !$$$ subprogram documentation block ! . . . . ! subprogram: leap_year @@ -226,24 +226,24 @@ logical function leap_year(ny) ! Determine if year ny is a leap year ! ! Author: S.-J. Lin - implicit none + implicit none - integer(i_kind),intent(in ) :: ny + integer(i_kind),intent(in ) :: ny - integer(i_kind) ny00 + integer(i_kind) ny00 ! ! No leap years prior to 1900 ! - parameter ( ny00 = 1900 ) ! The threshold for starting leap-year + parameter ( ny00 = 1900 ) ! The threshold for starting leap-year - if( mod(ny,4) == 0 .and. ny >= ny00 ) then - leap_year = .true. - else - leap_year = .false. - endif + if( mod(ny,4) == 0 .and. ny >= ny00 ) then + leap_year = .true. + else + leap_year = .false. + endif - return - end function leap_year + return +end function leap_year #endif end module m_tick diff --git a/src/gsi/m_tnode.F90 b/src/gsi/m_tnode.F90 new file mode 100644 index 0000000000..2a251afbab --- /dev/null +++ b/src/gsi/m_tnode.F90 @@ -0,0 +1,395 @@ +module m_tnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_tnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type tnode ((virtual) temperature) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2019-09-20 X.Su - add new variational qc parameters +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: tnode + + type,extends(obsnode):: tnode + !type(t_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! temperature residual + real(r_kind) :: err2 ! temperature error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: jb ! variational quality control parameter + integer(i_kind) :: ib ! new variational quality control parameter + integer(i_kind) :: ik ! new variational quality control parameter + real(r_kind) :: tlm_tsfc(6) ! sensitivity vector for sfc temp + ! forward model + real(r_kind) :: wij(8) ! horizontal interpolation weights + real(r_kind) :: tpertb ! random number adding to the obs + !logical :: luse ! flag indicating if ob is used in pen. + logical :: use_sfc_model ! logical flag for using boundary model + logical :: tv_ob ! logical flag for virtual temperature or + integer(i_kind) :: idx ! index of tail number + real(r_kind),dimension(:),pointer :: pred => null() + ! predictor for aircraft temperature bias + integer(i_kind) :: k1 ! level of errtable 1-33 + integer(i_kind) :: kx ! ob type + integer(i_kind) :: ij(8) ! horizontal locations + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + real (r_kind) :: dlev ! reference to the vertical grid + + integer(i_kind) :: ich0=0 ! ich code to mark derived data. See + ! tnode_ich0 and tnode_ich0_pbl_pseudo below + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + procedure:: init => obsnode_init_ + procedure:: clean => obsnode_clean_ + end type tnode + + public:: tnode_typecast + public:: tnode_nextcast + interface tnode_typecast; module procedure typecast_ ; end interface + interface tnode_nextcast; module procedure nextcast_ ; end interface + + public:: tnode_appendto + interface tnode_appendto; module procedure appendto_ ; end interface + + public:: tnode_ich0 + public:: tnode_ich0_pbl_pseudo + integer(i_kind),parameter:: tnode_ich0 = 0 + integer(i_kind),parameter:: tnode_ich0_pbl_pseudo = tnode_ich0+1 + + character(len=*),parameter:: myname="m_tnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(tnode) + use m_obsnode, only: obsnode + implicit none + type(tnode ),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(tnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(tnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(tnode ),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(tnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[tnode]" +end function mytype + +subroutine obsnode_init_(anode) + use aircraftinfo, only: npredt,aircraft_t_bc,aircraft_t_bc_pof + implicit none + class(tnode),intent(out):: anode + + character(len=*),parameter:: myname_=myname//'.obsnode_init_' +_ENTRY_(myname_) + + !anode = _obsnode_() + anode%llpoint => null() + anode%luse = .false. + anode%elat = 0._r_kind + anode%elon = 0._r_kind + anode%time = 0._r_kind + anode%idv =-1 + anode%iob =-1 + !-anode%dlev = 0._r_kind + !-anode%ich =-1._i_kind + + if(aircraft_t_bc_pof .or. aircraft_t_bc) then + allocate(anode%pred(npredt)) + else + allocate(anode%pred(0)) + endif +_EXIT_(myname_) + return +end subroutine obsnode_init_ + +subroutine obsnode_clean_(anode) + implicit none + class(tnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'.obsnode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',anode%mytype()) + if(associated(anode%pred)) deallocate(anode%pred) +_EXIT_(myname_) + return +end subroutine obsnode_clean_ + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof + implicit none + class(tnode),intent(inout):: anode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'.obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + if (.not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2 , & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%use_sfc_model, & + anode%tlm_tsfc , & + anode%tpertb , & + anode%tv_ob , & + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%ich0 , & + anode%wij , & + anode%ij + if(istat/=0) then + call perr(myname_,'read(%(res,err2,...), iostat =',istat) + call perr(myname_,' .not.(aircraft_t_bc_pof =',aircraft_t_bc_pof) + call perr(myname_,' .or.aircraft_t_bc) =',aircraft_t_bc) + _EXIT_(myname_) + return + endif + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2 , & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%use_sfc_model, & + anode%tlm_tsfc , & + anode%tpertb , & + anode%tv_ob , & + anode%idx , & ! + anode%pred(:) , & ! (1:npred) + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%ich0 , & + anode%wij , & + anode%ij + if(istat/=0) then + call perr(myname_,'read(%res,err2,...), iostat =',istat) + call perr(myname_,' aircraft_t_bc_pof =',aircraft_t_bc_pof) + call perr(myname_,' .or.aircraft_t_bc =',aircraft_t_bc) + _EXIT_(myname_) + return + endif + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,anode%ich0+1) + if(.not.associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call perr(myname_,' %ich0 =',anode%ich0) + call die(myname_) + endif + endif +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + use aircraftinfo, only: aircraft_t_bc,aircraft_t_bc_pof + implicit none + class(tnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'.obsnode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + if (.not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2 , & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%use_sfc_model, & + anode%tlm_tsfc , & + anode%tpertb , & + anode%tv_ob , & + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%ich0 , & + anode%wij , & + anode%ij + if(jstat/=0) then + call perr(myname_,'write(%(res,err2,...), iostat =',jstat) + call perr(myname_,' .not.(aircraft_t_bc_pof =',aircraft_t_bc_pof) + call perr(myname_,' .or.aircraft_t_bc) =',aircraft_t_bc) + _EXIT_(myname_) + return + endif + else + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2 , & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%use_sfc_model, & + anode%tlm_tsfc , & + anode%tpertb , & + anode%tv_ob , & + anode%idx , & ! + anode%pred(:) , & ! (1:npredt) + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%ich0 , & + anode%wij , & + anode%ij + if(jstat/=0) then + call perr(myname_,'write(%res,err2,...), iostat =',jstat) + call perr(myname_,' aircraft_t_bc_pof =',aircraft_t_bc_pof) + call perr(myname_,' .or.aircraft_t_bc =',aircraft_t_bc) + _EXIT_(myname_) + return + endif + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(tnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%dlev,anode%ij,anode%wij) +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(tnode),intent(in):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(anode%diags) +_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(tnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_tnode diff --git a/src/gsi/m_uniq.f90 b/src/gsi/m_uniq.f90 index dfb9472a24..02033548b0 100644 --- a/src/gsi/m_uniq.f90 +++ b/src/gsi/m_uniq.f90 @@ -9,13 +9,13 @@ module m_uniq ! assimilation ! ! program history log: -! 1996-10-01 Joiner/Karki - initial coding from NASA/GMAO -! 2012-02-15 eliu - reformat to use in GSI +! 1996-10-01 Joiner/Karki - initial coding from nasa/gmao +! 2012-02-15 eliu - reformat to use in gsi ! 2013-06-10 treadon - comment out i_uniq and i_nuniq ! -! SPECIAL NOTE: GSI devlopers on S4 and WCOSS found that compilation +! Special note: gsi devlopers on s4 and wcoss found that compilation ! of m_uniq.f90 generated a "catastrophic error" when using certain -! versions of Intel fortran compilers. This message is generated +! versions of intel fortran compilers. This message is generated ! with the following Intel compiler versions ! * ifort 12.1.0 20110811 ! * ifort 12.1.4 20120410 @@ -25,14 +25,14 @@ module m_uniq ! compiled with the above compilers with -fp-model strict. The ! code successfully compiles with -fp-model precise. This is a ! known bug (Intel issue id DPD200178252). The problem was -! resolved the Intel Composer XE 2013 suite of compilers. +! resolved the intel composer xe 2013 suite of compilers. ! ! The code has been successfully compiled as-is with -fp-model -! strict with the following Intel compilers +! strict with the following intel compilers ! * ifort 12.0.4 20110427 ! * ifort 13.1.1 20130313 ! -! The default WCOSS compiler is 12.1.5 20120612. Thus, for +! The default wcoss compiler is 12.1.5 20120612. Thus, for ! the time being, comment out i_uniq and i_nuniq. ! ! subroutines included: @@ -53,12 +53,12 @@ module m_uniq public nuniq interface uniq - module procedure r_uniq + module procedure r_uniq !! module procedure i_uniq end interface interface nuniq - module procedure r_nuniq + module procedure r_nuniq !! module procedure i_nuniq end interface @@ -66,26 +66,26 @@ module m_uniq function r_uniq( array, counter, idx ) result (unique) - use m_find - implicit NONE + use m_find + implicit none ! input parameters: ! Array: The array to be scanned. The type and number of dimensions ! of the array are not important. The array must be sorted - ! into monotonic order unless the optional parameter Idx is + ! into monotonic order unless the optional parameter idx is ! supplied. - real(r_kind), dimension(:):: array - integer(i_kind):: counter ! number of elements in unique + real(r_kind), dimension(:):: array + integer(i_kind):: counter ! number of elements in unique ! optional input parameters: - integer(i_kind), dimension(:), optional :: idx + integer(i_kind), dimension(:), optional :: idx ! idx: This optional parameter is an array of indices into Array ! that order the elements into monotonic order. ! That is, the expression: ! ! array(idx) ! - ! yields an array in which the elements of Array are + ! yields an array in which the elements of array are ! rearranged into monotonic order. If the array is not ! already in monotonic order, use the command: ! @@ -98,124 +98,124 @@ function r_uniq( array, counter, idx ) result (unique) ! ! output parameters: - real(r_kind), dimension(0:counter-1) :: unique - ! An array of indicies into ARRAY is returned. The expression: + real(r_kind), dimension(0:counter-1) :: unique + ! An array of indicies into array is returned. The expression: ! ! array(uniq(array)) ! - ! will be a copy of the sorted Array with duplicate adjacent + ! will be a copy of the sorted array with duplicate adjacent ! elements removed. ! - real(r_kind), dimension(:), allocatable :: q - integer(i_kind), dimension(:), allocatable :: indices - - if (present(idx)) then !IDX supplied? - allocate(q(0:size(array)-1)) - q = array(idx) - allocate(indices(0:counter-1)) - if (counter == 1) then - indices = 1 - else - indices = find(q .ne. cshift(q,1), counter) + real(r_kind), dimension(:), allocatable :: q + integer(i_kind), dimension(:), allocatable :: indices + + if (present(idx)) then !idx supplied? + allocate(q(0:size(array)-1)) + q = array(idx) + allocate(indices(0:counter-1)) + if (counter == 1) then + indices = 1 + else + indices = find(q /= cshift(q,1), counter) + endif + unique = idx(indices) + deallocate(q) + deallocate(indices) + else + if (count(array /= cshift(array, 1)) /= counter .and. & + counter > 1) then + print *, 'uniq: error dimensions not correct ',counter, & + count(array /= cshift(array, 1)) + return + endif + if (counter == 1) then + unique = 1 + else + unique = find(array /= cshift(array, 1), counter) + endif endif - unique = idx(indices) - deallocate(q) - deallocate(indices) - else - if (count(array .ne. cshift(array, 1)) /= counter .and. & - counter > 1) then - print *, 'uniq: error dimensions not correct ',counter, & - count(array .ne. cshift(array, 1)) - return - endif - if (counter == 1) then - unique = 1 - else - unique = find(array .ne. cshift(array, 1), counter) - endif - endif end function r_uniq !! function i_uniq( array, counter, idx ) result (unique) -!! use m_find -!! implicit none - -!! integer(i_kind), dimension(:) :: array -!! integer(i_kind), dimension(:), optional :: idx -!! integer(i_kind) :: counter -!! integer(i_kind), dimension(0:counter-1) :: unique - -!! integer(i_kind), dimension(:), allocatable :: q -!! integer(i_kind), dimension(:), allocatable :: indices - -!! if (present(idx)) then !IDX supplied? -!! allocate(q(0:size(array)-1)) -!! q = array(idx) -!! allocate(indices(0:counter-1)) -!! if (counter == 1) then -!! indices = 1 -!! else -!! indices = find(q .ne. eoshift(q,1), counter) -!! endif -!! unique = idx(indices) -!! deallocate(q) -!! deallocate(indices) -!! else -!! if (count(array .ne. eoshift(array, 1)) /= counter & -!! .and. counter > 1) then -!! print *, 'uniq: error dimensions not correct ',counter, & -!! count(array .ne. eoshift(array, 1)) -!! return -!! endif -!! if (counter == 1) then -!! unique = 1 -!! else -!! unique = find(array .ne. eoshift(array, 1), counter) -!! endif -!! endif +!! use m_find +!! implicit none + +!! integer(i_kind), dimension(:) :: array +!! integer(i_kind), dimension(:), optional :: idx +!! integer(i_kind) :: counter +!! integer(i_kind), dimension(0:counter-1) :: unique + +!! integer(i_kind), dimension(:), allocatable :: q +!! integer(i_kind), dimension(:), allocatable :: indices + +!! if (present(idx)) then !idx supplied? +!! allocate(q(0:size(array)-1)) +!! q = array(idx) +!! allocate(indices(0:counter-1)) +!! if (counter == 1) then +!! indices = 1 +!! else +!! indices = find(q /= eoshift(q,1), counter) +!! endif +!! unique = idx(indices) +!! deallocate(q) +!! deallocate(indices) +!! else +!! if (count(array /= eoshift(array, 1)) /= counter & +!! .and. counter > 1) then +!! print *, 'uniq: error dimensions not correct ',counter, & +!! count(array /= eoshift(array, 1)) +!! return +!! endif +!! if (counter == 1) then +!! unique = 1 +!! else +!! unique = find(array /= eoshift(array, 1), counter) +!! endif +!! endif !! end function i_uniq function r_nuniq( array, idx ) result (counter) - implicit NONE + implicit none - real(r_kind), dimension(:) :: array - integer(i_kind), dimension(:), optional :: idx - integer(i_kind) :: counter + real(r_kind), dimension(:) :: array + integer(i_kind), dimension(:), optional :: idx + integer(i_kind) :: counter - real(r_kind), dimension(:), allocatable :: q + real(r_kind), dimension(:), allocatable :: q - if (present(idx)) then !IDX supplied? - allocate(q(0:size(array)-1)) - q = array(idx) - counter = count(q .ne. cshift(q,1) ) - else - counter = count(array .ne. cshift(array,1) ) - endif - counter = max(1,counter) + if (present(idx)) then !idx supplied? + allocate(q(0:size(array)-1)) + q = array(idx) + counter = count(q /= cshift(q,1) ) + else + counter = count(array /= cshift(array,1) ) + endif + counter = max(1,counter) end function r_nuniq !! function i_nuniq( array, idx ) result (counter) -!! implicit NONE +!! implicit none -!! integer(i_kind), dimension(:) :: array -!! integer(i_kind), dimension(:), optional :: idx -!! integer(i_kind) :: counter +!! integer(i_kind), dimension(:) :: array +!! integer(i_kind), dimension(:), optional :: idx +!! integer(i_kind) :: counter -!! integer(i_kind), dimension(:), allocatable :: q +!! integer(i_kind), dimension(:), allocatable :: q - ! Check the arguments. -!! if (present(idx)) then !IDX supplied? -!! allocate(q(0:size(array)-1)) -!! q = array(idx) -!! counter = count(q .ne. eoshift(q,1) ) -!! else -!! counter = count(array .ne. eoshift(array,1) ) -!! endif -!! counter = max(1,counter) + ! Check the arguments. +!! if (present(idx)) then !idx supplied? +!! allocate(q(0:size(array)-1)) +!! q = array(idx) +!! counter = count(q /= eoshift(q,1) ) +!! else +!! counter = count(array /= eoshift(array,1) ) +!! endif +!! counter = max(1,counter) !! end function i_nuniq end module m_uniq diff --git a/src/gsi/m_uwnd10mNode.F90 b/src/gsi/m_uwnd10mNode.F90 deleted file mode 100644 index b41cc4da4d..0000000000 --- a/src/gsi/m_uwnd10mNode.F90 +++ /dev/null @@ -1,245 +0,0 @@ -module m_uwnd10mNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_uwnd10mNode -! prgmmr: Runhua Yang, following Jing Guo's m_wspd10mNode. -! Jing's org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2017-03-15 -! -! abstract: class-module of obs-type uwnd10mNode (10m u component) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). -! 2017-03-15 R Yang - create code based on Jing Guo's m_wspd10mNode -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: uwnd10mNode - - type,extends(obsNode):: uwnd10mNode - ! private - !type(uwnd10m_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! uwnd10m residual - real(r_kind) :: err2 ! uwnd10m error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type uwnd10mNode - - public:: uwnd10mNode_typecast - public:: uwnd10mNode_nextcast - interface uwnd10mNode_typecast; module procedure typecast_ ; end interface - interface uwnd10mNode_nextcast; module procedure nextcast_ ; end interface - - public:: uwnd10mNode_appendto - interface uwnd10mNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_uwnd10mNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(uwnd10mNode) - use m_obsNode, only: obsNode - implicit none - type(uwnd10mNode),pointer:: ptr_ - class(obsNode ),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(uwnd10mNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(uwnd10mNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(uwnd10mNode),pointer:: ptr_ - class(obsNode ),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(uwnd10mNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[uwnd10mNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(uwnd10mNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(uwnd10mNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(uwnd10mNode),intent(inout):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -!_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -!_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(uwnd10mNode),intent(in):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -!_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -!_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(uwnd10mNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_uwnd10mNode diff --git a/src/gsi/m_uwnd10mnode.F90 b/src/gsi/m_uwnd10mnode.F90 new file mode 100644 index 0000000000..18940d76b5 --- /dev/null +++ b/src/gsi/m_uwnd10mnode.F90 @@ -0,0 +1,245 @@ +module m_uwnd10mnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_uwnd10mnode +! prgmmr: Runhua Yang, following Jing Guo's m_wspd10mnode. +! Jing's org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2017-03-15 +! +! abstract: class-module of obs-type uwnd10mnode (10m u component) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). +! 2017-03-15 R Yang - create code based on jing guo's m_wspd10mnode +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: uwnd10mnode + + type,extends(obsnode):: uwnd10mnode + ! private + !type(uwnd10m_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! uwnd10m residual + real(r_kind) :: err2 ! uwnd10m error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type uwnd10mnode + + public:: uwnd10mnode_typecast + public:: uwnd10mnode_nextcast + interface uwnd10mnode_typecast; module procedure typecast_ ; end interface + interface uwnd10mnode_nextcast; module procedure nextcast_ ; end interface + + public:: uwnd10mnode_appendto + interface uwnd10mnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_uwnd10mnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(uwnd10mnode) + use m_obsnode, only: obsnode + implicit none + type(uwnd10mnode),pointer:: ptr_ + class(obsnode ),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(uwnd10mnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(uwnd10mnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(uwnd10mnode),pointer:: ptr_ + class(obsnode ),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(uwnd10mnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[uwnd10mnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(uwnd10mnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(uwnd10mnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(uwnd10mnode),intent(inout):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +!_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +!_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(uwnd10mnode),intent(in):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +!_ENTRY_(myname_) + isvalid_= associated(anode%diags) +!_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(uwnd10mnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_uwnd10mnode diff --git a/src/gsi/m_visNode.F90 b/src/gsi/m_visNode.F90 deleted file mode 100644 index 525deb1005..0000000000 --- a/src/gsi/m_visNode.F90 +++ /dev/null @@ -1,242 +0,0 @@ -module m_visNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_visNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type visNode (surface vis(ibility)) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: visNode - - type,extends(obsNode):: visNode - !type(vis_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! vis residual - real(r_kind) :: err2 ! vis error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type visNode - - public:: visNode_typecast - public:: visNode_nextcast - interface visNode_typecast; module procedure typecast_ ; end interface - interface visNode_nextcast; module procedure nextcast_ ; end interface - - public:: visNode_appendto - interface visNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_visNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(visNode) - use m_obsNode, only: obsNode - implicit none - type(visNode ),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(visNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(visNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(visNode ),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(visNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[visNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(visNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(visNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(visNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(visNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(visNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_visNode diff --git a/src/gsi/m_visnode.F90 b/src/gsi/m_visnode.F90 new file mode 100644 index 0000000000..8b89922da8 --- /dev/null +++ b/src/gsi/m_visnode.F90 @@ -0,0 +1,242 @@ +module m_visnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_visnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type visnode (surface vis(ibility)) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: visnode + + type,extends(obsnode):: visnode + !type(vis_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! vis residual + real(r_kind) :: err2 ! vis error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type visnode + + public:: visnode_typecast + public:: visnode_nextcast + interface visnode_typecast; module procedure typecast_ ; end interface + interface visnode_nextcast; module procedure nextcast_ ; end interface + + public:: visnode_appendto + interface visnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_visnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(visnode) + use m_obsnode, only: obsnode + implicit none + type(visnode ),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(visnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(visnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(visnode ),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(visnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[visnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(visnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(visnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(visnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(visnode),intent(in):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +_ENTRY_(myname_) + isvalid_= associated(anode%diags) +_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(visnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_visnode diff --git a/src/gsi/m_vwnd10mNode.F90 b/src/gsi/m_vwnd10mNode.F90 deleted file mode 100644 index c5b09da814..0000000000 --- a/src/gsi/m_vwnd10mNode.F90 +++ /dev/null @@ -1,245 +0,0 @@ -module m_vwnd10mNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_vwnd10mlNode -! prgmmr: Runhua Yang, following Jing Guo's m_wspd10mNode. -! Jing's org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2017-03-15 -! -! abstract: class-module of obs-type vwnd10mNode (10m u component) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). -! 2017-03-15 R Yang - create code based on Jing Guo's m_wspd10mNode -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: vwnd10mNode - - type,extends(obsNode):: vwnd10mNode - ! private - !type(vwnd10m_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! vwnd10m residual - real(r_kind) :: err2 ! vwnd10m error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type vwnd10mNode - - public:: vwnd10mNode_typecast - public:: vwnd10mNode_nextcast - interface vwnd10mNode_typecast; module procedure typecast_ ; end interface - interface vwnd10mNode_nextcast; module procedure nextcast_ ; end interface - - public:: vwnd10mNode_appendto - interface vwnd10mNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_vwnd10mNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(vwnd10mNode) - use m_obsNode, only: obsNode - implicit none - type(vwnd10mNode),pointer:: ptr_ - class(obsNode ),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(vwnd10mNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(vwnd10mNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(vwnd10mNode),pointer:: ptr_ - class(obsNode),target,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(vwnd10mNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[vwnd10mNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(vwnd10mNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(vwnd10mNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(vwnd10mNode),intent(inout):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -!_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -!_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(vwnd10mNode),intent(in):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -!_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -!_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(vwnd10mNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_vwnd10mNode diff --git a/src/gsi/m_vwnd10mnode.F90 b/src/gsi/m_vwnd10mnode.F90 new file mode 100644 index 0000000000..093a17e8b9 --- /dev/null +++ b/src/gsi/m_vwnd10mnode.F90 @@ -0,0 +1,245 @@ +module m_vwnd10mnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_vwnd10mlnode +! prgmmr: Runhua Yang, following Jing Guo's m_wspd10mnode. +! Jing's org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2017-03-15 +! +! abstract: class-module of obs-type vwnd10mnode (10m u component) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). +! 2017-03-15 R Yang - create code based on jing guo's m_wspd10mnode +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: vwnd10mnode + + type,extends(obsnode):: vwnd10mnode + ! private + !type(vwnd10m_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! vwnd10m residual + real(r_kind) :: err2 ! vwnd10m error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type vwnd10mnode + + public:: vwnd10mnode_typecast + public:: vwnd10mnode_nextcast + interface vwnd10mnode_typecast; module procedure typecast_ ; end interface + interface vwnd10mnode_nextcast; module procedure nextcast_ ; end interface + + public:: vwnd10mnode_appendto + interface vwnd10mnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_vwnd10mnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(vwnd10mnode) + use m_obsnode, only: obsnode + implicit none + type(vwnd10mnode),pointer:: ptr_ + class(obsnode ),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(vwnd10mnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(vwnd10mnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(vwnd10mnode),pointer:: ptr_ + class(obsnode),target,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(vwnd10mnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[vwnd10mnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(vwnd10mnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(vwnd10mnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(vwnd10mnode),intent(inout):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +!_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +!_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(vwnd10mnode),intent(in):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +!_ENTRY_(myname_) + isvalid_= associated(anode%diags) +!_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(vwnd10mnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_vwnd10mnode diff --git a/src/gsi/m_wNode.F90 b/src/gsi/m_wNode.F90 deleted file mode 100644 index 2cfdf67b44..0000000000 --- a/src/gsi/m_wNode.F90 +++ /dev/null @@ -1,299 +0,0 @@ -module m_wNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_wNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type wNode (wind components) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2019-09-20 X.Su - add new variational QC parameters -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: wNode - - type,extends(obsNode):: wNode - !type(w_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diagu => NULL() - type(obs_diag), pointer :: diagv => NULL() - real(r_kind) :: ures ! u component residual - real(r_kind) :: vres ! v component residual - real(r_kind) :: err2 ! surface pressure error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: jb ! variational quality control parameter - integer(i_kind) :: ib ! new variational quality control parameter - integer(i_kind) :: ik ! new variational quality control parameter - real(r_kind) :: wij(8) ! horizontal interpolation weights - real(r_kind) :: upertb ! random number adding to the obs - real(r_kind) :: vpertb ! random number adding to the obs - integer(i_kind) :: ij(8) ! horizontal locations - integer(i_kind) :: k1 ! level of errtable 1-33 - integer(i_kind) :: kx ! ob type - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - real (r_kind) :: dlev ! reference to the vertical grid - real (r_kind) :: factw ! factor of 10m wind - - integer(i_kind) :: ich0=0 ! ich code to mark derived data. See - ! wNode_ich0 and wNode_ich0_PBL_Pseudo below - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type wNode - - public:: wNode_typecast - public:: wNode_nextcast - interface wNode_typecast; module procedure typecast_ ; end interface - interface wNode_nextcast; module procedure nextcast_ ; end interface - - public:: wNode_appendto - interface wNode_appendto; module procedure appendto_ ; end interface - - ! Because there are two components in wNode for an ordinary wind obs, - ! ich values are set to (1,2). Therefore, ich values for PBL_pseudo_surfobsUV - ! are set to (3,4), and wNode_ich0_pbl_pseudo is set to 2. - - public:: wNode_ich0 - public:: wNode_ich0_PBL_pseudo - integer(i_kind),parameter :: wNode_ich0 = 0 ! (1,2) - integer(i_kind),parameter :: wNode_ich0_PBL_pseudo = wNode_ich0+2 ! (3,4) - - character(len=*),parameter:: MYNAME="m_wNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(wNode) - use m_obsNode, only: obsNode - implicit none - type(wNode ),pointer:: ptr_ - class(obsNode),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(wNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(wNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(wNode ),pointer:: ptr_ - class(obsNode),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(wNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[wNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(wNode),intent(inout):: aNode - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent( out):: istat - type(obs_diags),intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - skip_=.false. - if(present(skip)) skip_=skip - - istat=0 - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%ures , & - aNode%vres , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%upertb , & - aNode%vpertb , & - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%factw , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,err2,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diagu => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+1_i_kind) - aNode%diagv => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,aNode%ich0+2_i_kind) - - if(.not. (associated(aNode%diagu) .and. & - associated(aNode%diagv) ) ) then - call perr(myname_,'obsdiagLookup_locate(u,v), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call perr(myname_,' %ich0 =',aNode%ich0) - if(.not.associated(aNode%diagu)) & - call perr(myname_,' .not.associated(%diagu), ich =',aNode%ich0+1_i_kind) - if(.not.associated(aNode%diagv)) & - call perr(myname_,' .not.associated(%diagv), ich =',aNode%ich0+2_i_kind) - call die(myname_) - endif - endif -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(wNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'.obsNode_xwrite_' -_ENTRY_(myname_) - - jstat=0 - write(junit,iostat=jstat) aNode%ures , & - aNode%vres , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%jb , & - aNode%ib , & - aNode%ik , & - aNode%upertb , & - aNode%vpertb , & - aNode%k1 , & - aNode%kx , & - aNode%dlev , & - aNode%factw , & - aNode%ich0 , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(wNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%dlev,aNode%ij,aNode%wij) - aNode%wij(1:8) = aNode%wij(1:8)*aNode%factw -_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(wNode),intent(in):: aNode - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -_ENTRY_(myname_) - isvalid_=associated(aNode%diagu) .and. & - associated(aNode%diagv) -_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(wNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diagu%tldepart(jiter)*aNode%diagu%tldepart(jiter) - tlddp = tlddp + aNode%diagv%tldepart(jiter)*aNode%diagv%tldepart(jiter) - if(present(nob)) nob=nob+2 -return -end subroutine gettlddp_ - -end module m_wNode diff --git a/src/gsi/m_wnode.F90 b/src/gsi/m_wnode.F90 new file mode 100644 index 0000000000..808ea86d2e --- /dev/null +++ b/src/gsi/m_wnode.F90 @@ -0,0 +1,299 @@ +module m_wnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_wnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type wnode (wind components) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2019-09-20 X.Su - add new variational qc parameters +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: wnode + + type,extends(obsnode):: wnode + !type(w_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diagu => null() + type(obs_diag), pointer :: diagv => null() + real(r_kind) :: ures ! u component residual + real(r_kind) :: vres ! v component residual + real(r_kind) :: err2 ! surface pressure error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: jb ! variational quality control parameter + integer(i_kind) :: ib ! new variational quality control parameter + integer(i_kind) :: ik ! new variational quality control parameter + real(r_kind) :: wij(8) ! horizontal interpolation weights + real(r_kind) :: upertb ! random number adding to the obs + real(r_kind) :: vpertb ! random number adding to the obs + integer(i_kind) :: ij(8) ! horizontal locations + integer(i_kind) :: k1 ! level of errtable 1-33 + integer(i_kind) :: kx ! ob type + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + real (r_kind) :: dlev ! reference to the vertical grid + real (r_kind) :: factw ! factor of 10m wind + + integer(i_kind) :: ich0=0 ! ich code to mark derived data. See + ! wnode_ich0 and wnode_ich0_pbl_pseudo below + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type wnode + + public:: wnode_typecast + public:: wnode_nextcast + interface wnode_typecast; module procedure typecast_ ; end interface + interface wnode_nextcast; module procedure nextcast_ ; end interface + + public:: wnode_appendto + interface wnode_appendto; module procedure appendto_ ; end interface + + ! Because there are two components in wnode for an ordinary wind obs, + ! ich values are set to (1,2). Therefore, ich values for pbl_pseudo_surfobsuv + ! are set to (3,4), and wnode_ich0_pbl_pseudo is set to 2. + + public:: wnode_ich0 + public:: wnode_ich0_pbl_pseudo + integer(i_kind),parameter :: wnode_ich0 = 0 ! (1,2) + integer(i_kind),parameter :: wnode_ich0_pbl_pseudo = wnode_ich0+2 ! (3,4) + + character(len=*),parameter:: myname="m_wnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(wnode) + use m_obsnode, only: obsnode + implicit none + type(wnode ),pointer:: ptr_ + class(obsnode),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(wnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(wnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(wnode ),pointer:: ptr_ + class(obsnode),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(wnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[wnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(wnode),intent(inout):: anode + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent( out):: istat + type(obs_diags),intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'.obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + skip_=.false. + if(present(skip)) skip_=skip + + istat=0 + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%ures , & + anode%vres , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%upertb , & + anode%vpertb , & + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%factw , & + anode%ich0 , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diagu => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,anode%ich0+1) + anode%diagv => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,anode%ich0+2) + + if(.not. (associated(anode%diagu) .and. & + associated(anode%diagv) ) ) then + call perr(myname_,'obsdiaglookup_locate(u,v), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call perr(myname_,' %ich0 =',anode%ich0) + if(.not.associated(anode%diagu)) & + call perr(myname_,' .not.associated(%diagu), ich =',anode%ich0+1) + if(.not.associated(anode%diagv)) & + call perr(myname_,' .not.associated(%diagv), ich =',anode%ich0+2) + call die(myname_) + endif + endif +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(wnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'.obsnode_xwrite_' +_ENTRY_(myname_) + + jstat=0 + write(junit,iostat=jstat) anode%ures , & + anode%vres , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%jb , & + anode%ib , & + anode%ik , & + anode%upertb , & + anode%vpertb , & + anode%k1 , & + anode%kx , & + anode%dlev , & + anode%factw , & + anode%ich0 , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,err2,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(wnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%dlev,anode%ij,anode%wij) + anode%wij(1:8) = anode%wij(1:8)*anode%factw +_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(wnode),intent(in):: anode + + character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +_ENTRY_(myname_) + isvalid_=associated(anode%diagu) .and. & + associated(anode%diagv) +_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(wnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diagu%tldepart(jiter)*anode%diagu%tldepart(jiter) + tlddp = tlddp + anode%diagv%tldepart(jiter)*anode%diagv%tldepart(jiter) + if(present(nob)) nob=nob+2 + return +end subroutine gettlddp_ + +end module m_wnode diff --git a/src/gsi/m_wspd10mNode.F90 b/src/gsi/m_wspd10mNode.F90 deleted file mode 100644 index 646ab2d993..0000000000 --- a/src/gsi/m_wspd10mNode.F90 +++ /dev/null @@ -1,244 +0,0 @@ -module m_wspd10mNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_wspd10mNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type wspd10mNode (10m wind speed) -! -! program history log: -! 2016-05-18 j guo - added this document block for the initial polymorphic -! implementation. -! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - use m_obsdiagNode, only: obs_diag - use m_obsdiagNode, only: obs_diags - use kinds , only: i_kind,r_kind - use mpeu_util, only: assert_,die,perr,warn,tell - use m_obsNode, only: obsNode - implicit none - private - - public:: wspd10mNode - - type,extends(obsNode):: wspd10mNode - ! private - !type(wspd10m_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: res ! wspd10m residual - real(r_kind) :: err2 ! wspd10m error squared - real(r_kind) :: raterr2 ! square of ratio of final obs error - ! to original obs error - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: b ! variational quality control parameter - real(r_kind) :: pg ! variational quality control parameter - real(r_kind) :: wij(4) ! horizontal interpolation weights - integer(i_kind) :: ij(4) ! horizontal locations - !logical :: luse ! flag indicating if ob is used in pen. - - !integer(i_kind) :: idv,iob ! device id and obs index for sorting - !real (r_kind) :: elat, elon ! earth lat-lon for redistribution - !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution - contains - procedure,nopass:: mytype - procedure:: setHop => obsNode_setHop_ - procedure:: xread => obsNode_xread_ - procedure:: xwrite => obsNode_xwrite_ - procedure:: isvalid => obsNode_isvalid_ - procedure:: gettlddp => gettlddp_ - - ! procedure, nopass:: headerRead => obsHeader_read_ - ! procedure, nopass:: headerWrite => obsHeader_write_ - ! procedure:: init => obsNode_init_ - ! procedure:: clean => obsNode_clean_ - end type wspd10mNode - - public:: wspd10mNode_typecast - public:: wspd10mNode_nextcast - interface wspd10mNode_typecast; module procedure typecast_ ; end interface - interface wspd10mNode_nextcast; module procedure nextcast_ ; end interface - - public:: wspd10mNode_appendto - interface wspd10mNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_wspd10mNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(wspd10mNode) - use m_obsNode, only: obsNode - implicit none - type(wspd10mNode),pointer:: ptr_ - class(obsNode ),pointer,intent(in):: aNode - ptr_ => null() - if(.not.associated(aNode)) return - ! logically, typecast of a null-reference is a null pointer. - select type(aNode) - type is(wspd10mNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(wspd10mNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(wspd10mNode),pointer:: ptr_ - class(obsNode ),target ,intent(in):: aNode - - class(obsNode),pointer:: inode_ - inode_ => obsNode_next(aNode) - ptr_ => typecast_(inode_) -return -end function nextcast_ - -subroutine appendto_(aNode,oll) -!-- append aNode to linked-list oLL - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList,obsLList_appendNode - implicit none - type(wspd10mNode),pointer,intent(in):: aNode - type(obsLList),intent(inout):: oLL - - class(obsNode),pointer:: inode_ - inode_ => aNode - call obsLList_appendNode(oLL,inode_) - inode_ => null() -end subroutine appendto_ - -! obsNode implementations - -function mytype() - implicit none - character(len=:),allocatable:: mytype - mytype="[wspd10mNode]" -end function mytype - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(wspd10mNode), intent(inout):: aNode - integer(i_kind), intent(in ):: iunit - integer(i_kind), intent( out):: istat - type(obs_diags), intent(in ):: diagLookup - logical,optional,intent(in ):: skip - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xread_' - logical:: skip_ -_ENTRY_(myname_) - - skip_=.false. - if(present(skip)) skip_=skip - - if(skip_) then - read(iunit,iostat=istat) - if(istat/=0) then - call perr(myname_,'skipping read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - endif - - else - read(iunit,iostat=istat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (istat/=0) then - call perr(myname_,'read(%(res,...)), iostat =',istat) - _EXIT_(myname_) - return - end if - - aNode%diags => obsdiagLookup_locate(diagLookup,aNode%idv,aNode%iob,1_i_kind) - if(.not. associated(aNode%diags)) then - call perr(myname_,'obsdiagLookup_locate(), %idv =',aNode%idv) - call perr(myname_,' %iob =',aNode%iob) - call die(myname_) - endif - endif ! if(skip_); else -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(wspd10mNode),intent(in):: aNode - integer(i_kind),intent(in ):: junit - integer(i_kind),intent( out):: jstat - - character(len=*),parameter:: myname_=MYNAME//'::obsNode_xwrite_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) aNode%res , & - aNode%err2 , & - aNode%raterr2, & - aNode%b , & - aNode%pg , & - aNode%wij , & - aNode%ij - if (jstat/=0) then - call perr(myname_,'write(%(res,...)), iostat =',jstat) - _EXIT_(myname_) - return - end if -_EXIT_(myname_) -return -end subroutine obsNode_xwrite_ - -subroutine obsNode_setHop_(aNode) - use m_cvgridLookup, only: cvgridLookup_getiw - implicit none - class(wspd10mNode),intent(inout):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_setHop_' -!_ENTRY_(myname_) - call cvgridLookup_getiw(aNode%elat,aNode%elon,aNode%ij,aNode%wij) -!_EXIT_(myname_) -return -end subroutine obsNode_setHop_ - -function obsNode_isvalid_(aNode) result(isvalid_) - implicit none - logical:: isvalid_ - class(wspd10mNode),intent(in):: aNode - -! character(len=*),parameter:: myname_=MYNAME//'::obsNode_isvalid_' -!_ENTRY_(myname_) - isvalid_= associated(aNode%diags) -!_EXIT_(myname_) -return -end function obsNode_isvalid_ - -pure subroutine gettlddp_(aNode,jiter,tlddp,nob) - use kinds, only: r_kind - implicit none - class(wspd10mNode), intent(in):: aNode - integer(kind=i_kind),intent(in):: jiter - real(kind=r_kind),intent(inout):: tlddp - integer(kind=i_kind),optional,intent(inout):: nob - - tlddp = tlddp + aNode%diags%tldepart(jiter)*aNode%diags%tldepart(jiter) - if(present(nob)) nob=nob+1 -return -end subroutine gettlddp_ - -end module m_wspd10mNode diff --git a/src/gsi/m_wspd10mnode.F90 b/src/gsi/m_wspd10mnode.F90 new file mode 100644 index 0000000000..49fc2642d9 --- /dev/null +++ b/src/gsi/m_wspd10mnode.F90 @@ -0,0 +1,244 @@ +module m_wspd10mnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_wspd10mnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type wspd10mnode (10m wind speed) +! +! program history log: +! 2016-05-18 j guo - added this document block for the initial polymorphic +! implementation. +! 2017-01-19 j guo - fixed a null reference bug in nextcast_(). +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + use m_obsdiagnode, only: obs_diag + use m_obsdiagnode, only: obs_diags + use kinds , only: i_kind,r_kind + use mpeu_util, only: assert_,die,perr,warn,tell + use m_obsnode, only: obsnode + implicit none + private + + public:: wspd10mnode + + type,extends(obsnode):: wspd10mnode + ! private + !type(wspd10m_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: res ! wspd10m residual + real(r_kind) :: err2 ! wspd10m error squared + real(r_kind) :: raterr2 ! square of ratio of final obs error + ! to original obs error + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: b ! variational quality control parameter + real(r_kind) :: pg ! variational quality control parameter + real(r_kind) :: wij(4) ! horizontal interpolation weights + integer(i_kind) :: ij(4) ! horizontal locations + !logical :: luse ! flag indicating if ob is used in pen. + + !integer(i_kind) :: idv,iob ! device id and obs index for sorting + !real (r_kind) :: elat, elon ! earth lat-lon for redistribution + !real (r_kind) :: dlat, dlon ! earth lat-lon for redistribution + contains + procedure,nopass:: mytype + procedure:: sethop => obsnode_sethop_ + procedure:: xread => obsnode_xread_ + procedure:: xwrite => obsnode_xwrite_ + procedure:: isvalid => obsnode_isvalid_ + procedure:: gettlddp => gettlddp_ + + ! procedure, nopass:: headerread => obsheader_read_ + ! procedure, nopass:: headerwrite => obsheader_write_ + ! procedure:: init => obsnode_init_ + ! procedure:: clean => obsnode_clean_ + end type wspd10mnode + + public:: wspd10mnode_typecast + public:: wspd10mnode_nextcast + interface wspd10mnode_typecast; module procedure typecast_ ; end interface + interface wspd10mnode_nextcast; module procedure nextcast_ ; end interface + + public:: wspd10mnode_appendto + interface wspd10mnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_wspd10mnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(wspd10mnode) + use m_obsnode, only: obsnode + implicit none + type(wspd10mnode),pointer:: ptr_ + class(obsnode ),pointer,intent(in):: anode + ptr_ => null() + if(.not.associated(anode)) return + ! logically, typecast of a null-reference is a null pointer. + select type(anode) + type is(wspd10mnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(wspd10mnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(wspd10mnode),pointer:: ptr_ + class(obsnode ),target ,intent(in):: anode + + class(obsnode),pointer:: inode_ + inode_ => obsnode_next(anode) + ptr_ => typecast_(inode_) + return +end function nextcast_ + +subroutine appendto_(anode,oll) +!-- append anode to linked-list oll + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist,obsllist_appendnode + implicit none + type(wspd10mnode),pointer,intent(in):: anode + type(obsllist),intent(inout):: oll + + class(obsnode),pointer:: inode_ + inode_ => anode + call obsllist_appendnode(oll,inode_) + inode_ => null() +end subroutine appendto_ + +! obsnode implementations + +function mytype() + implicit none + character(len=:),allocatable:: mytype + mytype="[wspd10mnode]" +end function mytype + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(wspd10mnode), intent(inout):: anode + integer(i_kind), intent(in ):: iunit + integer(i_kind), intent( out):: istat + type(obs_diags), intent(in ):: diaglookup + logical,optional,intent(in ):: skip + + character(len=*),parameter:: myname_=myname//'::obsnode_xread_' + logical:: skip_ +_ENTRY_(myname_) + + skip_=.false. + if(present(skip)) skip_=skip + + if(skip_) then + read(iunit,iostat=istat) + if(istat/=0) then + call perr(myname_,'skipping read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + endif + + else + read(iunit,iostat=istat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (istat/=0) then + call perr(myname_,'read(%(res,...)), iostat =',istat) + _EXIT_(myname_) + return + end if + + anode%diags => obsdiaglookup_locate(diaglookup,anode%idv,anode%iob,1) + if(.not. associated(anode%diags)) then + call perr(myname_,'obsdiaglookup_locate(), %idv =',anode%idv) + call perr(myname_,' %iob =',anode%iob) + call die(myname_) + endif + endif ! if(skip_); else +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(wspd10mnode),intent(in):: anode + integer(i_kind),intent(in ):: junit + integer(i_kind),intent( out):: jstat + + character(len=*),parameter:: myname_=myname//'::obsnode_xwrite_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) anode%res , & + anode%err2 , & + anode%raterr2, & + anode%b , & + anode%pg , & + anode%wij , & + anode%ij + if (jstat/=0) then + call perr(myname_,'write(%(res,...)), iostat =',jstat) + _EXIT_(myname_) + return + end if +_EXIT_(myname_) + return +end subroutine obsnode_xwrite_ + +subroutine obsnode_sethop_(anode) + use m_cvgridlookup, only: cvgridlookup_getiw + implicit none + class(wspd10mnode),intent(inout):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_sethop_' +!_ENTRY_(myname_) + call cvgridlookup_getiw(anode%elat,anode%elon,anode%ij,anode%wij) +!_EXIT_(myname_) + return +end subroutine obsnode_sethop_ + +function obsnode_isvalid_(anode) result(isvalid_) + implicit none + logical:: isvalid_ + class(wspd10mnode),intent(in):: anode + +! character(len=*),parameter:: myname_=myname//'::obsnode_isvalid_' +!_ENTRY_(myname_) + isvalid_= associated(anode%diags) +!_EXIT_(myname_) + return +end function obsnode_isvalid_ + +pure subroutine gettlddp_(anode,jiter,tlddp,nob) + use kinds, only: r_kind + implicit none + class(wspd10mnode), intent(in):: anode + integer(kind=i_kind),intent(in):: jiter + real(kind=r_kind),intent(inout):: tlddp + integer(kind=i_kind),optional,intent(inout):: nob + + tlddp = tlddp + anode%diags%tldepart(jiter)*anode%diags%tldepart(jiter) + if(present(nob)) nob=nob+1 + return +end subroutine gettlddp_ + +end module m_wspd10mnode diff --git a/src/gsi/native_endianness.f90 b/src/gsi/native_endianness.f90 index 6444eb7792..f635018ef8 100644 --- a/src/gsi/native_endianness.f90 +++ b/src/gsi/native_endianness.f90 @@ -1,11 +1,11 @@ - module native_endianness +module native_endianness !$$$ module documentation block ! . . . . ! module: native_endianness ! prgmmr: parrish org: wx22 date: 2012-10-11 ! -! abstract: This module was written by Dusan Jovic and has been adapted to GSI for internal translation -! of WRF ARW and NMM binary restart files as required to match the machine native +! abstract: This module was written by dusan jovic and has been adapted to gsi for internal translation +! of wrf arw and nmm binary restart files as required to match the machine native ! endian storage format. The original code only converted from big-endian to little-endian. ! There are no restrictions in this version. ! This is required for these two types of files, because they are read/written to using mpi-io, @@ -13,7 +13,7 @@ module native_endianness ! for fortran unformatted read/write. ! ! program history log: -! 2012-10-11 parrish - copy/modify original module native_endianness provided by Dusan Jovic, NCEP/EMC 2012 +! 2012-10-11 parrish - copy/modify original module native_endianness provided by dusan jovic, ncep/emc 2012 ! 2012-10-19 parrish - additional modifications to improve efficiency. Remove interface and make ! to_native_endianness to work only with integer(4) arguments. ! Put to_native_endianness_i4 outside module. @@ -32,19 +32,19 @@ module native_endianness ! !$$$ end documentation block - use kinds, only: i_byte,i_long - implicit none +use kinds, only: i_byte,i_long +implicit none - private +private - public byte_swap - public is_little_endian +public byte_swap +public is_little_endian - logical byte_swap +logical byte_swap - contains +contains - logical function is_little_endian() +logical function is_little_endian() !$$$ subprogram documentation block ! . . . . ! subprogram: is_little_endian @@ -76,15 +76,15 @@ logical function is_little_endian() is_little_endian = (i1 == i2) - end function is_little_endian +end function is_little_endian - end module native_endianness +end module native_endianness !---------------------------------------------------------------------- ! convert 4-byte integer scalar from big-endian to native-endian !---------------------------------------------------------------------- - subroutine to_native_endianness_i4(i4,num) +subroutine to_native_endianness_i4(i4,num) !$$$ subprogram documentation block ! . . . . ! subprogram: to_native_endianness_i4 @@ -100,7 +100,7 @@ subroutine to_native_endianness_i4(i4,num) ! ! input argument list: ! i4 - input 4 byte integer array -! num - length of array i4 (NOTE: type of num must be i_llong (8 byte integer) ) +! num - length of array i4 (Note: type of num must be i_llong (8 byte integer) ) ! ! output argument list: ! i4 - output 4 byte integer array with bytes in reverse order @@ -111,33 +111,33 @@ subroutine to_native_endianness_i4(i4,num) ! !$$$ end documentation block - use kinds, only: i_byte,i_long,i_llong - implicit none + use kinds, only: i_byte,i_long,i_llong + implicit none - integer(i_llong), intent(in) :: num - integer(i_long), intent(inout) :: i4(num) + integer(i_llong), intent(in) :: num + integer(i_long), intent(inout) :: i4(num) - integer(i_byte), dimension(4) :: byte_arr, byte_arr_tmp - integer(i_long) :: n + integer(i_byte), dimension(4) :: byte_arr, byte_arr_tmp + integer(i_long) :: n - do n=1,num - byte_arr_tmp = transfer (i4(n), byte_arr) - byte_arr(1)=byte_arr_tmp(4) - byte_arr(2)=byte_arr_tmp(3) - byte_arr(3)=byte_arr_tmp(2) - byte_arr(4)=byte_arr_tmp(1) - i4(n) = transfer (byte_arr, i4(n)) - end do + do n=1,num + byte_arr_tmp = transfer (i4(n), byte_arr) + byte_arr(1)=byte_arr_tmp(4) + byte_arr(2)=byte_arr_tmp(3) + byte_arr(3)=byte_arr_tmp(2) + byte_arr(4)=byte_arr_tmp(1) + i4(n) = transfer (byte_arr, i4(n)) + end do - return + return - end subroutine to_native_endianness_i4 +end subroutine to_native_endianness_i4 !---------------------------------------------------------------------- ! convert 4-byte real scalar from big-endian to native-endian !---------------------------------------------------------------------- - subroutine to_native_endianness_r4(r4,num) +subroutine to_native_endianness_r4(r4,num) !$$$ subprogram documentation block ! . . . . ! subprogram: to_native_endianness_r4 @@ -153,7 +153,7 @@ subroutine to_native_endianness_r4(r4,num) ! ! input argument list: ! r4 - input 4 byte integer array -! num - length of array r4 (NOTE: type of num must be i_llong (8 byte integer) ) +! num - length of array r4 (Note: type of num must be i_llong (8 byte integer) ) ! ! output argument list: ! r4 - output 4 byte integer array with bytes in reverse order @@ -164,24 +164,24 @@ subroutine to_native_endianness_r4(r4,num) ! !$$$ end documentation block - use kinds, only: i_byte,i_long,i_llong,r_single - implicit none + use kinds, only: i_byte,i_long,i_llong,r_single + implicit none - integer(i_llong), intent(in) :: num - real(r_single), intent(inout) :: r4(num) + integer(i_llong), intent(in) :: num + real(r_single), intent(inout) :: r4(num) - integer(i_byte), dimension(4) :: byte_arr, byte_arr_tmp - integer(i_long) :: n + integer(i_byte), dimension(4) :: byte_arr, byte_arr_tmp + integer(i_long) :: n - do n=1,num - byte_arr_tmp = transfer (r4(n), byte_arr) - byte_arr(1)=byte_arr_tmp(4) - byte_arr(2)=byte_arr_tmp(3) - byte_arr(3)=byte_arr_tmp(2) - byte_arr(4)=byte_arr_tmp(1) - r4(n) = transfer (byte_arr, r4(n)) - end do + do n=1,num + byte_arr_tmp = transfer (r4(n), byte_arr) + byte_arr(1)=byte_arr_tmp(4) + byte_arr(2)=byte_arr_tmp(3) + byte_arr(3)=byte_arr_tmp(2) + byte_arr(4)=byte_arr_tmp(1) + r4(n) = transfer (byte_arr, r4(n)) + end do - return + return - end subroutine to_native_endianness_r4 +end subroutine to_native_endianness_r4 diff --git a/src/gsi/nc_diag_read_mod.f90 b/src/gsi/nc_diag_read_mod.f90 index ff56c09f78..bca78e78a3 100644 --- a/src/gsi/nc_diag_read_mod.f90 +++ b/src/gsi/nc_diag_read_mod.f90 @@ -8,86 +8,86 @@ module nc_diag_read_mod public :: nc_diag_read_get_dim ! interface nc_diag_read_get_var - module procedure nc_diag_read_get_var_i - module procedure nc_diag_read_get_var_rd - module procedure nc_diag_read_get_var_rs - module procedure nc_diag_read_get_var_i_rank1 - module procedure nc_diag_read_get_var_rd_rank1 - module procedure nc_diag_read_get_var_rs_rank1 - module procedure nc_diag_read_get_var_rd_rank2 - module procedure nc_diag_read_get_var_rs_rank2 + module procedure nc_diag_read_get_var_i + module procedure nc_diag_read_get_var_rd + module procedure nc_diag_read_get_var_rs + module procedure nc_diag_read_get_var_i_rank1 + module procedure nc_diag_read_get_var_rd_rank1 + module procedure nc_diag_read_get_var_rs_rank1 + module procedure nc_diag_read_get_var_rd_rank2 + module procedure nc_diag_read_get_var_rs_rank2 end interface interface nc_diag_read_get_global_attr - module procedure nc_diag_read_get_global_attr_i - module procedure nc_diag_read_get_global_attr_c - module procedure nc_diag_read_get_global_attr_rs - module procedure nc_diag_read_get_global_attr_rd + module procedure nc_diag_read_get_global_attr_i + module procedure nc_diag_read_get_global_attr_c + module procedure nc_diag_read_get_global_attr_rs + module procedure nc_diag_read_get_global_attr_rd end interface contains - subroutine nc_diag_read_init(fname,id) - character(len=*):: fname - integer(i_kind) :: id - end subroutine nc_diag_read_init - integer function nc_diag_read_get_dim(id,vname) - integer(i_kind) :: id - character(len=*):: vname - nc_diag_read_get_dim = 0 - end function nc_diag_read_get_dim - subroutine nc_diag_read_close(fname) - character(len=*):: fname - end subroutine nc_diag_read_close -! get rank 0 - subroutine nc_diag_read_get_var_i(name,mold) - character(len=*):: name - integer(i_kind):: mold - end subroutine nc_diag_read_get_var_i - subroutine nc_diag_read_get_var_rs(name,mold) - character(len=*):: name - real(r_single):: mold - end subroutine nc_diag_read_get_var_rs - subroutine nc_diag_read_get_var_rd(name,mold) - character(len=*):: name - real(r_double):: mold - end subroutine nc_diag_read_get_var_rd -! get rank 1 - subroutine nc_diag_read_get_var_i_rank1(name,mold) - character(len=*):: name - integer(i_kind):: mold(:) - end subroutine nc_diag_read_get_var_i_rank1 - subroutine nc_diag_read_get_var_rs_rank1(name,mold) - character(len=*):: name - real(r_single):: mold(:) - end subroutine nc_diag_read_get_var_rs_rank1 - subroutine nc_diag_read_get_var_rd_rank1(name,mold) - character(len=*):: name - real(r_double):: mold(:) - end subroutine nc_diag_read_get_var_rd_rank1 -! get rank 1 - subroutine nc_diag_read_get_var_rs_rank2(name,mold) - character(len=*):: name - real(r_single):: mold(:,:) - end subroutine nc_diag_read_get_var_rs_rank2 - subroutine nc_diag_read_get_var_rd_rank2(name,mold) - character(len=*):: name - real(r_double):: mold(:,:) - end subroutine nc_diag_read_get_var_rd_rank2 -! global_attr - subroutine nc_diag_read_get_global_attr_i(imold1,name,mold2) - character(len=*):: name - integer(i_kind):: imold1,mold2 - end subroutine nc_diag_read_get_global_attr_i - subroutine nc_diag_read_get_global_attr_c(imold1,name,mold2) - character(len=*):: name,mold2 - integer(i_kind):: imold1 - end subroutine nc_diag_read_get_global_attr_c - subroutine nc_diag_read_get_global_attr_rs(imold1,name,mold2) - character(len=*):: name - integer(i_kind):: imold1 - real(r_single):: mold2 - end subroutine nc_diag_read_get_global_attr_rs - subroutine nc_diag_read_get_global_attr_rd(imold1,name,mold2) - character(len=*):: name - integer(i_kind):: imold1 - real(r_double):: mold2 - end subroutine nc_diag_read_get_global_attr_rd + subroutine nc_diag_read_init(fname,id) + character(len=*):: fname + integer(i_kind) :: id + end subroutine nc_diag_read_init + integer function nc_diag_read_get_dim(id,vname) + integer(i_kind) :: id + character(len=*):: vname + nc_diag_read_get_dim = 0 + end function nc_diag_read_get_dim + subroutine nc_diag_read_close(fname) + character(len=*):: fname + end subroutine nc_diag_read_close +! get rank 0 + subroutine nc_diag_read_get_var_i(name,mold) + character(len=*):: name + integer(i_kind):: mold + end subroutine nc_diag_read_get_var_i + subroutine nc_diag_read_get_var_rs(name,mold) + character(len=*):: name + real(r_single):: mold + end subroutine nc_diag_read_get_var_rs + subroutine nc_diag_read_get_var_rd(name,mold) + character(len=*):: name + real(r_double):: mold + end subroutine nc_diag_read_get_var_rd +! get rank 1 + subroutine nc_diag_read_get_var_i_rank1(name,mold) + character(len=*):: name + integer(i_kind):: mold(:) + end subroutine nc_diag_read_get_var_i_rank1 + subroutine nc_diag_read_get_var_rs_rank1(name,mold) + character(len=*):: name + real(r_single):: mold(:) + end subroutine nc_diag_read_get_var_rs_rank1 + subroutine nc_diag_read_get_var_rd_rank1(name,mold) + character(len=*):: name + real(r_double):: mold(:) + end subroutine nc_diag_read_get_var_rd_rank1 +! get rank 1 + subroutine nc_diag_read_get_var_rs_rank2(name,mold) + character(len=*):: name + real(r_single):: mold(:,:) + end subroutine nc_diag_read_get_var_rs_rank2 + subroutine nc_diag_read_get_var_rd_rank2(name,mold) + character(len=*):: name + real(r_double):: mold(:,:) + end subroutine nc_diag_read_get_var_rd_rank2 +! global_attr + subroutine nc_diag_read_get_global_attr_i(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1,mold2 + end subroutine nc_diag_read_get_global_attr_i + subroutine nc_diag_read_get_global_attr_c(imold1,name,mold2) + character(len=*):: name,mold2 + integer(i_kind):: imold1 + end subroutine nc_diag_read_get_global_attr_c + subroutine nc_diag_read_get_global_attr_rs(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1 + real(r_single):: mold2 + end subroutine nc_diag_read_get_global_attr_rs + subroutine nc_diag_read_get_global_attr_rd(imold1,name,mold2) + character(len=*):: name + integer(i_kind):: imold1 + real(r_double):: mold2 + end subroutine nc_diag_read_get_global_attr_rd end module nc_diag_read_mod diff --git a/src/gsi/nc_diag_write_mod.f90 b/src/gsi/nc_diag_write_mod.f90 index 66ad48fd81..33890710b4 100644 --- a/src/gsi/nc_diag_write_mod.f90 +++ b/src/gsi/nc_diag_write_mod.f90 @@ -9,108 +9,108 @@ module nc_diag_write_mod public nc_diag_chaninfo public nc_diag_write interface nc_diag_header - module procedure nc_diag_header_i - module procedure nc_diag_header_c - module procedure nc_diag_header_rs - module procedure nc_diag_header_rd + module procedure nc_diag_header_i + module procedure nc_diag_header_c + module procedure nc_diag_header_rs + module procedure nc_diag_header_rd end interface interface nc_diag_metadata - module procedure nc_diag_metadata_i - module procedure nc_diag_metadata_c - module procedure nc_diag_metadata_rs - module procedure nc_diag_metadata_rd + module procedure nc_diag_metadata_i + module procedure nc_diag_metadata_c + module procedure nc_diag_metadata_rs + module procedure nc_diag_metadata_rd end interface interface nc_diag_chaninfo - module procedure nc_diag_chaninfo_i - module procedure nc_diag_chaninfo_c - module procedure nc_diag_chaninfo_rs - module procedure nc_diag_chaninfo_rd + module procedure nc_diag_chaninfo_i + module procedure nc_diag_chaninfo_c + module procedure nc_diag_chaninfo_rs + module procedure nc_diag_chaninfo_rd end interface interface nc_diag_data2d - module procedure nc_diag_data1d_rs - module procedure nc_diag_data1d_rd - module procedure nc_diag_data2d_rs - module procedure nc_diag_data2d_rd + module procedure nc_diag_data1d_rs + module procedure nc_diag_data1d_rd + module procedure nc_diag_data2d_rs + module procedure nc_diag_data2d_rd end interface contains -! init - subroutine nc_diag_init(fname,append) - character(len=*):: fname - logical(i_kind),optional :: append - end subroutine nc_diag_init -! header - subroutine nc_diag_header_i(vname,ivar) - character(len=*):: vname - integer(i_kind) :: ivar - end subroutine nc_diag_header_i - subroutine nc_diag_header_c(vname,cvar) - character(len=*):: vname - character(len=*):: cvar - end subroutine nc_diag_header_c - subroutine nc_diag_header_rs(vname,rvar) - character(len=*):: vname - real(r_single) :: rvar - end subroutine nc_diag_header_rs - subroutine nc_diag_header_rd(vname,rvar) - character(len=*):: vname - real(r_double) :: rvar - end subroutine nc_diag_header_rd -! metadata - subroutine nc_diag_metadata_i(vname,ivar) - character(len=*):: vname - integer(i_kind) :: ivar - end subroutine nc_diag_metadata_i - subroutine nc_diag_metadata_c(vname,cvar) - character(len=*):: vname - character(len=*):: cvar - end subroutine nc_diag_metadata_c - subroutine nc_diag_metadata_rs(vname,rvar) - character(len=*):: vname - real(r_single) :: rvar - end subroutine nc_diag_metadata_rs - subroutine nc_diag_metadata_rd(vname,rvar) - character(len=*):: vname - real(r_double) :: rvar - end subroutine nc_diag_metadata_rd -! data2d - not sure why original code no wrap these with metadata interface! - subroutine nc_diag_data1d_rs(vname,rvar) - character(len=*):: vname - real(r_single) :: rvar(:) - end subroutine nc_diag_data1d_rs - subroutine nc_diag_data1d_rd(vname,rvar) - character(len=*):: vname - real(r_double) :: rvar(:) - end subroutine nc_diag_data1d_rd - subroutine nc_diag_data2d_rs(vname,rvar) - character(len=*):: vname - real(r_single) :: rvar(:,:) - end subroutine nc_diag_data2d_rs - subroutine nc_diag_data2d_rd(vname,rvar) - character(len=*):: vname - real(r_double) :: rvar(:,:) - end subroutine nc_diag_data2d_rd +! init + subroutine nc_diag_init(fname,append) + character(len=*):: fname + logical(i_kind),optional :: append + end subroutine nc_diag_init +! header + subroutine nc_diag_header_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_header_i + subroutine nc_diag_header_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_header_c + subroutine nc_diag_header_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_header_rs + subroutine nc_diag_header_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_header_rd +! metadata + subroutine nc_diag_metadata_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_metadata_i + subroutine nc_diag_metadata_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_metadata_c + subroutine nc_diag_metadata_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_metadata_rs + subroutine nc_diag_metadata_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_metadata_rd +! data2d - not sure why original code no wrap these with metadata interface! + subroutine nc_diag_data1d_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar(:) + end subroutine nc_diag_data1d_rs + subroutine nc_diag_data1d_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar(:) + end subroutine nc_diag_data1d_rd + subroutine nc_diag_data2d_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar(:,:) + end subroutine nc_diag_data2d_rs + subroutine nc_diag_data2d_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar(:,:) + end subroutine nc_diag_data2d_rd ! - subroutine nc_diag_chaninfo_dim_set(ivar) - integer(i_kind) :: ivar - end subroutine nc_diag_chaninfo_dim_set -! metadata - subroutine nc_diag_chaninfo_i(vname,ivar) - character(len=*):: vname - integer(i_kind) :: ivar - end subroutine nc_diag_chaninfo_i - subroutine nc_diag_chaninfo_c(vname,cvar) - character(len=*):: vname - character(len=*):: cvar - end subroutine nc_diag_chaninfo_c - subroutine nc_diag_chaninfo_rs(vname,rvar) - character(len=*):: vname - real(r_single) :: rvar - end subroutine nc_diag_chaninfo_rs - subroutine nc_diag_chaninfo_rd(vname,rvar) - character(len=*):: vname - real(r_double) :: rvar - end subroutine nc_diag_chaninfo_rd -! final - subroutine nc_diag_write - end subroutine nc_diag_write + subroutine nc_diag_chaninfo_dim_set(ivar) + integer(i_kind) :: ivar + end subroutine nc_diag_chaninfo_dim_set +! metadata + subroutine nc_diag_chaninfo_i(vname,ivar) + character(len=*):: vname + integer(i_kind) :: ivar + end subroutine nc_diag_chaninfo_i + subroutine nc_diag_chaninfo_c(vname,cvar) + character(len=*):: vname + character(len=*):: cvar + end subroutine nc_diag_chaninfo_c + subroutine nc_diag_chaninfo_rs(vname,rvar) + character(len=*):: vname + real(r_single) :: rvar + end subroutine nc_diag_chaninfo_rs + subroutine nc_diag_chaninfo_rd(vname,rvar) + character(len=*):: vname + real(r_double) :: rvar + end subroutine nc_diag_chaninfo_rd +! final + subroutine nc_diag_write + end subroutine nc_diag_write end module nc_diag_write_mod diff --git a/src/gsi/ncepgfs_ghg.f90 b/src/gsi/ncepgfs_ghg.f90 index 6c5fa7bb9d..fc7bf84a56 100644 --- a/src/gsi/ncepgfs_ghg.f90 +++ b/src/gsi/ncepgfs_ghg.f90 @@ -53,7 +53,7 @@ module ncepgfs_ghg real(r_kind), parameter :: prsco2 = 78.8_r_kind ! pres lim for 2-d co2 (cb) ! --- parameter constants for gas volume mixing ratioes in ppm (1.e-6 p/p) -! --- values are based on ESRL or default values in CRTM +! --- values are based on esrl or default values in crtm real(r_kind), parameter :: co2vmr_def = 390.0_r_kind real(r_kind), parameter :: ch4vmr_def = 1.808_r_kind real(r_kind), parameter :: n2ovmr_def = 0.324_r_kind @@ -141,6 +141,8 @@ subroutine read_gfsco2 & ! !$$$ + implicit none + ! --- declare passed variables - input: integer(i_kind), intent(in ) :: iyear integer(i_kind), intent(in ) :: month @@ -157,7 +159,7 @@ subroutine read_gfsco2 & ! --- declare local variables: real(r_kind), allocatable, dimension(:) :: xlatsdeg - real(r_kind), allocatable, dimension(:,:,:) :: co2_Tintrp + real(r_kind), allocatable, dimension(:,:,:) :: co2_tintrp real(r_kind), allocatable, dimension(:,:,:) :: co2_sav1 real(r_kind), allocatable, dimension(:,:,:) :: co2_sav2 ! --- latitudes in degree of input co2 data @@ -281,8 +283,8 @@ subroutine read_gfsco2 & if ( .not. allocated(co2_sav2) ) then allocate ( co2_sav2(nmxlon,nmxlat,nlev) ) endif - if ( .not. allocated(co2_Tintrp) ) then - allocate ( co2_Tintrp(nmxlon,nmxlat,nlev) ) + if ( .not. allocated(co2_tintrp) ) then + allocate ( co2_tintrp(nmxlon,nmxlat,nlev) ) endif ! --- ... ! --- ... rlats: latitudes array of input co2 data (in degree) @@ -301,7 +303,7 @@ subroutine read_gfsco2 & xlatsdeg(i)=xlats(i)*rad2deg enddo -! --- ... read 3-d data starting from January of the year or climate January +! --- ... read 3-d data starting from january of the year or climate january do imo = 1, month do k = 1, nlev do j=1,nmxlat @@ -317,7 +319,7 @@ subroutine read_gfsco2 & enddo ! Linearly interpolate month means into the values for analysis day ndmax=ndpm(month) -! For leap year February: ndmax=29 +! For leap year february: ndmax=29 if (month ==2 ) then if( mod(iyear,4) == 0 .and. iyear >= 1900) ndmax= 29 endif @@ -326,21 +328,21 @@ subroutine read_gfsco2 & do i=1,nmxlon co2diff= co2_sav2(i,j,k)-co2_sav1(i,j,k) co2rate= co2diff/ndmax - co2_Tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*float(idd-1) + co2_tintrp(i,j,k)= co2_sav1(i,j,k)+ co2rate*real(idd-1,r_kind) enddo enddo enddo i=nmxlon/2+1 j=nmxlat/2+1 if ( mype == 0 ) then - write(6,*) 'ncep_ghg: CO2 data ', & + write(6,*) 'ncep_ghg: CO2 data ', & 'data used for year, month,i,j:',iyear,month,i,j - do k=1,nlev - write(6,*) ' Level = ',k,' CO2 = ',co2_Tintrp(i,j,k) - enddo + do k=1,nlev + write(6,*) ' Level = ',k,' CO2 = ',co2_tintrp(i,j,k) + enddo endif -! Interpolate the co2_Tintrp into a subdomain's grid +! Interpolate the co2_tintrp into a subdomain's grid do i = 1, lat2 ! --- ... If the subdomain indexes are out of the coverage of the input co2 ! --- ... or fall at the same lats, atmco2(i,j,k) is assinged by the value of @@ -348,27 +350,27 @@ subroutine read_gfsco2 & if (xlatsdeg(i) < rlats_co2(1)) then do k = 1, nlev do j=1,lon2 - atmco2(i,j,k)= co2_Tintrp(1,1,k) + atmco2(i,j,k)= co2_tintrp(1,1,k) enddo enddo endif if (xlatsdeg(i) >= rlats_co2(nmxlat)) then do k = 1, nlev do j=1,lon2 - atmco2(i,j,k)= co2_Tintrp(1,nmxlat,k) + atmco2(i,j,k)= co2_tintrp(1,nmxlat,k) enddo enddo endif - ii_loop:do ii = 1, nmxlat-1 + ii_loop:do ii = 1, nmxlat-1 if (xlatsdeg(i) >= rlats_co2(ii) .and. xlatsdeg(i) < rlats_co2(ii+1)) then dydn= xlatsdeg(i) - rlats_co2(ii) dyup= rlats_co2(ii+1)-xlatsdeg(i) dyall=rlats_co2(ii+1)-rlats_co2(ii) dydn=dydn /dyall - dyup=1.0-dydn + dyup=one-dydn do k=1,nlev do j=1,lon2 - atmco2(i,j,k)= dydn*co2_Tintrp(1,ii+1,k)+ dyup*co2_Tintrp(1,ii,k) + atmco2(i,j,k)= dydn*co2_tintrp(1,ii+1,k)+ dyup*co2_tintrp(1,ii,k) enddo enddo endif @@ -379,7 +381,7 @@ subroutine read_gfsco2 & if (allocated(rlats_co2)) deallocate (rlats_co2) if (allocated(co2_sav1)) deallocate (co2_sav1) if (allocated(co2_sav2)) deallocate (co2_sav2) - if (allocated(co2_Tintrp)) deallocate (co2_Tintrp) + if (allocated(co2_tintrp)) deallocate (co2_tintrp) endif ! end if_ico2_block return end subroutine read_gfsco2 @@ -392,11 +394,11 @@ subroutine read_ch4n2oco & !$$$ subprogram documentation block ! -! subprogram: read_ch4n2oco read and interpolate prescribed CH4,N2O,and CO fields +! subprogram: read_ch4n2oco read and interpolate prescribed ch4,n2o,and co fields ! ! prgmmr: Yang date: 2012-01-24 ! -! abstract: read prescribed CH4,N2O, and CO, either climate monthly means or monthly means. +! abstract: read prescribed ch4,n2o, and co, either climate monthly means or monthly means. ! Do linearly interpolation on both temporal and spatial space. ! ! program history log: @@ -407,9 +409,9 @@ subroutine read_ch4n2oco & ! month - integer, month of the year ! idd - integer, day of the month ! char_ghg - character -! =ch4: use prescribed CH4 data set -! =n2o: use prescribed N2O data set -! =co1: use prescribed CO data set. Use 'co1' to distinguish from 'co' used by GMAO +! =ch4: use prescribed ch4 data set +! =n2o: use prescribed n2o data set +! =co1: use prescribed co data set. Use 'co1' to distinguish from 'co' used by gmao ! xlats(lat2)- real, grid latitude in radians ! lat2 - integer, number of latitude points in subdomain ! lon2 - integer, number of longitude points in subdomain @@ -422,6 +424,8 @@ subroutine read_ch4n2oco & ! !$$$ + implicit none + ! --- declare passed variables - input: integer(i_kind), intent(in ) :: iyear integer(i_kind), intent(in ) :: month @@ -438,7 +442,7 @@ subroutine read_ch4n2oco & ! --- declare local variables: real(r_kind), allocatable, dimension(:) :: xlatsdeg - real(r_kind), allocatable, dimension(:,:,:) :: ghg_Tintrp + real(r_kind), allocatable, dimension(:,:,:) :: ghg_tintrp real(r_kind), allocatable, dimension(:,:,:) :: ghg_sav1 real(r_kind), allocatable, dimension(:,:,:) :: ghg_sav2 @@ -474,34 +478,34 @@ subroutine read_ch4n2oco & inquire (file=cfile, exist=file_exist) if ( .not. file_exist ) then - if ( mype == 0 ) then - write(6,*) ' Can not find ',trim(char_ghg),' data source file' - write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' - endif + if ( mype == 0 ) then + write(6,*) ' Can not find ',trim(char_ghg),' data source file' + write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' + endif call stop2(332) endif ! end if_file_exist_block -! --- ... read in 2-d (Y-Z) data for the request month +! --- ... read in 2-d (y-z) data for the request month open (lughg,file=cfile,form='formatted',status='old',iostat=ierr) - if (ierr /= 0) then - if ( mype == 0 ) then - write(6,*) ' error opening file = '//cfile - write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' - endif - call stop2(332) - endif + if (ierr /= 0) then + if ( mype == 0 ) then + write(6,*) ' error opening file = '//cfile + write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' + endif + call stop2(332) + endif rewind lughg read (lughg, 36,iostat=ierr) iyr,title1, nmaxlon, nmaxlat, title2 36 format(i8,4x,a18,2i3,a30) - if (ierr /= 0) then - if ( mype == 0 ) then - write(6,*) ' error reading file = '//cfile - write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' - endif - call stop2(332) - endif + if (ierr /= 0) then + if ( mype == 0 ) then + write(6,*) ' error reading file = '//cfile + write(6,*) ' *** Stopped in subroutine read_ch4n2oco !!' + endif + call stop2(332) + endif if ( mype == 0 ) then write(6,*) ' Opened ghg data file: ',cfile @@ -517,8 +521,8 @@ subroutine read_ch4n2oco & if ( .not. allocated(ghg_sav2) ) then allocate ( ghg_sav2(nmaxlon,nmaxlat,nlev) ) endif - if ( .not. allocated(ghg_Tintrp) ) then - allocate ( ghg_Tintrp(nmaxlon,nmaxlat,nlev) ) + if ( .not. allocated(ghg_tintrp) ) then + allocate ( ghg_tintrp(nmaxlon,nmaxlat,nlev) ) endif ! --- ... rlats: latitudes array of input ghg data (in degree) @@ -531,7 +535,7 @@ subroutine read_ch4n2oco & xlatsdeg(i)=xlats(i)*rad2deg enddo -! --- ... read 2-d data field starting from January of the year +! --- ... read 2-d data field starting from january of the year do imo = 1, month do k = 1, nlev read (lughg,37) (ghg_sav1(1,j,k), j=1,nmaxlat) @@ -541,14 +545,14 @@ subroutine read_ch4n2oco & do k = 1, nlev read (lughg,37) (ghg_sav2(1,j,k), j=1,nmaxlat) enddo - if ( mype == 0 ) then - write(6,*) ' CHECK: at Month+1 CH4 data ', & - 'data used for year, month, level:',iyear,month,nlev - write(6,37) ghg_sav2(1,:,64) - endif + if ( mype == 0 ) then + write(6,*) ' CHECK: at Month+1 CH4 data ', & + 'data used for year, month, level:',iyear,month,nlev + write(6,37) ghg_sav2(1,:,64) + endif ! Linearly interperlate two monthly means into values for the analysis day ndmax=ndpm(month) -! For leap year February: ndmax=29 +! For leap year february: ndmax=29 if (month ==2 ) then if( mod(iyear,4) == 0_i_kind .and. iyear >= 1900_i_kind) ndmax= 29 endif @@ -558,12 +562,12 @@ subroutine read_ch4n2oco & do i=1,nmaxlon ghgdiff= ghg_sav2(1,j,k)-ghg_sav1(1,j,k) ghgrate= ghgdiff/ndmax - ghg_Tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*float(idd-1) + ghg_tintrp(1,j,k)= ghg_sav1(1,j,k)+ ghgrate*real(idd-1,r_kind) enddo enddo enddo -! Interpolate ghg_Tintrp into a subdomain's grid +! Interpolate ghg_tintrp into a subdomain's grid do i = 1, lat2 ! --- ... If the subdomain indexes are out of the coverage of the input ghg @@ -572,27 +576,27 @@ subroutine read_ch4n2oco & if (xlatsdeg(i) < rlats_ghg(1)) then do k = 1, nlev do j=1,lon2 - atmghg(i,j,k)= ghg_Tintrp(1,1,k) + atmghg(i,j,k)= ghg_tintrp(1,1,k) enddo enddo endif if (xlatsdeg(i) >= rlats_ghg(nmaxlat)) then do k = 1, nlev do j=1,lon2 - atmghg(i,j,k)= ghg_Tintrp(1,nmaxlat,k) + atmghg(i,j,k)= ghg_tintrp(1,nmaxlat,k) enddo enddo endif -ii_loop: do ii = 1, nmaxlat-1 + ii_loop: do ii = 1, nmaxlat-1 if (xlatsdeg(i) >= rlats_ghg(ii) .and. xlatsdeg(i) < rlats_ghg(ii+1)) then dydn= xlatsdeg(i) - rlats_ghg(ii) dyup= rlats_ghg(ii+1)-xlatsdeg(i) dyall=rlats_ghg(ii+1)-rlats_ghg(ii) dydn=dydn /dyall - dyup=1.0-dydn + dyup=one-dydn do k=1,nlev do j=1,lon2 - atmghg(i,j,k)= dydn*ghg_Tintrp(1,ii+1,k)+ dyup*ghg_Tintrp(1,ii,k) + atmghg(i,j,k)= dydn*ghg_tintrp(1,ii+1,k)+ dyup*ghg_tintrp(1,ii,k) enddo enddo endif @@ -603,7 +607,7 @@ subroutine read_ch4n2oco & if (allocated(rlats_ghg)) deallocate (rlats_ghg) if (allocated(ghg_sav1)) deallocate (ghg_sav1) if (allocated(ghg_sav2)) deallocate (ghg_sav2) - if (allocated(ghg_Tintrp)) deallocate (ghg_Tintrp) + if (allocated(ghg_tintrp)) deallocate (ghg_tintrp) return end subroutine read_ch4n2oco