From 3c888b401e7eacb35a8539d4506528740748b8f9 Mon Sep 17 00:00:00 2001 From: "michael.lueken" Date: Fri, 31 Jul 2020 18:35:46 +0000 Subject: [PATCH] GitHub Issue NOAA-EMC/GSI#13. Continuing to clear through coding standard issues in the master. Finished through src/gsi/m_pcpnode.F90. --- src/gsi/m_pcpNode.F90 | 336 ------------------------------ src/gsi/m_pcpnode.F90 | 336 ++++++++++++++++++++++++++++++ src/gsi/mp_compact_diffs_mod1.f90 | 42 ++-- 3 files changed, 349 insertions(+), 365 deletions(-) delete mode 100644 src/gsi/m_pcpNode.F90 create mode 100644 src/gsi/m_pcpnode.F90 diff --git a/src/gsi/m_pcpNode.F90 b/src/gsi/m_pcpNode.F90 deleted file mode 100644 index 3dd4a9b5d6..0000000000 --- a/src/gsi/m_pcpNode.F90 +++ /dev/null @@ -1,336 +0,0 @@ -module m_pcpNode -!$$$ subprogram documentation block -! . . . . -! subprogram: module m_pcpNode -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2016-05-18 -! -! abstract: class-module of obs-type pcpNode (precipitation) -! -! 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:: pcpNode - - type,extends(obsNode):: pcpNode - !type(pcp_ob_type),pointer :: llpoint => NULL() - type(obs_diag), pointer :: diags => NULL() - real(r_kind) :: obs ! observed precipitation value - real(r_kind) :: err2 ! error variances squared - real(r_kind) :: raterr2 ! ratio of error variances squared - !real(r_kind) :: time ! observation time in sec - real(r_kind) :: ges ! guess observation value - real(r_kind) :: wij(4) ! horizontal interpolation weights - real(r_kind),dimension(:),pointer :: predp => NULL() - ! predictors (npredp) - real(r_kind),dimension(:),pointer :: dpcp_dvar => NULL() - ! error variances squared (nsig5) - integer(i_kind) :: ij(4) ! horizontal locations - integer(i_kind) :: icxp ! type of precipitation rate observation - !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 pcpNode - - public:: pcpNode_typecast - public:: pcpNode_nextcast - interface pcpNode_typecast; module procedure typecast_ ; end interface - interface pcpNode_nextcast; module procedure nextcast_ ; end interface - - public:: pcpNode_appendto - interface pcpNode_appendto; module procedure appendto_ ; end interface - - character(len=*),parameter:: MYNAME="m_pcpNode" - -#include "myassert.H" -#include "mytrace.H" -contains -function typecast_(aNode) result(ptr_) -!-- cast a class(obsNode) to a type(pcpNode) - use m_obsNode, only: obsNode - implicit none - type(pcpNode ),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(pcpNode) - ptr_ => aNode - end select -return -end function typecast_ - -function nextcast_(aNode) result(ptr_) -!-- cast an obsNode_next(obsNode) to a type(pcpNode) - use m_obsNode, only: obsNode,obsNode_next - implicit none - type(pcpNode ),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(pcpNode),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="[pcpNode]" -end function mytype - -subroutine obsHeader_read_(iunit,mobs,jread,istat) - use gridmod, only: nsig5 - use pcpinfo, only: npredp - implicit none - integer(i_kind),intent(in ):: iunit - integer(i_kind),intent(out):: mobs - integer(i_kind),intent(out):: jread - integer(i_kind),intent(out):: istat - - character(len=*),parameter:: myname_=myname//'.obsHeader_read_' - integer(i_kind):: mpredp,msig5 -_ENTRY_(myname_) - - read(iunit,iostat=istat) mobs,jread, mpredp,msig5 - if(istat==0 .and. (npredp/=mpredp .or. nsig5/=msig5)) then - call perr(myname_,'unmatched dimension information, npredp or nsig5') - if(npredp/=mpredp) then - call perr(myname_,' expecting npredp =',npredp) - call perr(myname_,' but read mpredp =',mpredp) - endif - if(nsig5/=msig5) then - call perr(myname_,' expecting nsig5 =',nsig5) - call perr(myname_,' but read msig5 =',msig5) - endif - call die(myname_) - endif -_EXIT_(myname_) -return -end subroutine obsHeader_read_ - -subroutine obsHeader_write_(junit,mobs,jwrite,jstat) - use gridmod, only: nsig5 - use pcpinfo, only: npredp - implicit none - integer(i_kind),intent(in ):: junit - integer(i_kind),intent(in ):: mobs - integer(i_kind),intent(in ):: jwrite - integer(i_kind),intent(out):: jstat - - character(len=*),parameter:: myname_=myname//'.obsHeader_write_' -_ENTRY_(myname_) - - write(junit,iostat=jstat) mobs,jwrite, npredp,nsig5 -_EXIT_(myname_) -return -end subroutine obsHeader_write_ - -subroutine obsNode_init_(aNode) - use gridmod, only: nsig5 - use pcpinfo, only: npredp - implicit none - class(pcpNode),intent(out):: aNode - - character(len=*),parameter:: myname_=myname//'.obsNode_init_' -_ENTRY_(myname_) - !aNode = _obsNode_() - aNode%llpoint => null() - aNode%luse = .false. - aNode%time = 0._r_kind - aNode%elat = 0._r_kind - aNode%elon = 0._r_kind - aNode%idv =-1 - aNode%iob =-1 - !-aNode%dlev = 0._r_kind - !-aNode%ich =-1._i_kind - - allocate(aNode%predp(npredp), & - aNode%dpcp_dvar(1:nsig5) ) -_EXIT_(myname_) -return -end subroutine obsNode_init_ - -subroutine obsNode_clean_(aNode) - implicit none - class(pcpNode),intent(inout):: aNode - - character(len=*),parameter:: myname_=myname//'.obsNode_clean_' -_ENTRY_(myname_) -!_TRACEV_(myname_,'%mytype() =',aNode%mytype()) - if(associated(aNode%predp )) deallocate(aNode%predp) - if(associated(aNode%dpcp_dvar)) deallocate(aNode%dpcp_dvar) -_EXIT_(myname_) -return -end subroutine obsNode_clean_ - -subroutine obsNode_xread_(aNode,iunit,istat,diagLookup,skip) - use m_obsdiagNode, only: obsdiagLookup_locate - implicit none - class(pcpNode) , 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%obs , & - aNode%err2 , & - aNode%raterr2, & - aNode%ges , & - aNode%icxp , & - aNode%predp(:) , & - aNode%dpcp_dvar(:), & - aNode%wij(:) , & - aNode%ij(:) - if (istat/=0) then - call perr(myname_,'read(%(res,err2,...)), 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 -_EXIT_(myname_) -return -end subroutine obsNode_xread_ - -subroutine obsNode_xwrite_(aNode,junit,jstat) - implicit none - class(pcpNode),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%obs , & - aNode%err2 , & - aNode%raterr2, & - aNode%ges , & - aNode%icxp , & - aNode%predp(:) , & - aNode%dpcp_dvar(:), & - 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(pcpNode),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(pcpNode),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(pcpNode), 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_pcpNode diff --git a/src/gsi/m_pcpnode.F90 b/src/gsi/m_pcpnode.F90 new file mode 100644 index 0000000000..4ef6cbf382 --- /dev/null +++ b/src/gsi/m_pcpnode.F90 @@ -0,0 +1,336 @@ +module m_pcpnode +!$$$ subprogram documentation block +! . . . . +! subprogram: module m_pcpnode +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2016-05-18 +! +! abstract: class-module of obs-type pcpnode (precipitation) +! +! 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:: pcpnode + + type,extends(obsnode):: pcpnode + !type(pcp_ob_type),pointer :: llpoint => null() + type(obs_diag), pointer :: diags => null() + real(r_kind) :: obs ! observed precipitation value + real(r_kind) :: err2 ! error variances squared + real(r_kind) :: raterr2 ! ratio of error variances squared + !real(r_kind) :: time ! observation time in sec + real(r_kind) :: ges ! guess observation value + real(r_kind) :: wij(4) ! horizontal interpolation weights + real(r_kind),dimension(:),pointer :: predp => null() + ! predictors (npredp) + real(r_kind),dimension(:),pointer :: dpcp_dvar => null() + ! error variances squared (nsig5) + integer(i_kind) :: ij(4) ! horizontal locations + integer(i_kind) :: icxp ! type of precipitation rate observation + !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 pcpnode + + public:: pcpnode_typecast + public:: pcpnode_nextcast + interface pcpnode_typecast; module procedure typecast_ ; end interface + interface pcpnode_nextcast; module procedure nextcast_ ; end interface + + public:: pcpnode_appendto + interface pcpnode_appendto; module procedure appendto_ ; end interface + + character(len=*),parameter:: myname="m_pcpnode" + +#include "myassert.H" +#include "mytrace.H" +contains +function typecast_(anode) result(ptr_) +!-- cast a class(obsnode) to a type(pcpnode) + use m_obsnode, only: obsnode + implicit none + type(pcpnode ),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(pcpnode) + ptr_ => anode + end select + return +end function typecast_ + +function nextcast_(anode) result(ptr_) +!-- cast an obsnode_next(obsnode) to a type(pcpnode) + use m_obsnode, only: obsnode,obsnode_next + implicit none + type(pcpnode ),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(pcpnode),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="[pcpnode]" +end function mytype + +subroutine obsheader_read_(iunit,mobs,jread,istat) + use gridmod, only: nsig5 + use pcpinfo, only: npredp + implicit none + integer(i_kind),intent(in ):: iunit + integer(i_kind),intent(out):: mobs + integer(i_kind),intent(out):: jread + integer(i_kind),intent(out):: istat + + character(len=*),parameter:: myname_=myname//'.obsheader_read_' + integer(i_kind):: mpredp,msig5 +_ENTRY_(myname_) + + read(iunit,iostat=istat) mobs,jread, mpredp,msig5 + if(istat==0 .and. (npredp/=mpredp .or. nsig5/=msig5)) then + call perr(myname_,'unmatched dimension information, npredp or nsig5') + if(npredp/=mpredp) then + call perr(myname_,' expecting npredp =',npredp) + call perr(myname_,' but read mpredp =',mpredp) + endif + if(nsig5/=msig5) then + call perr(myname_,' expecting nsig5 =',nsig5) + call perr(myname_,' but read msig5 =',msig5) + endif + call die(myname_) + endif +_EXIT_(myname_) + return +end subroutine obsheader_read_ + +subroutine obsheader_write_(junit,mobs,jwrite,jstat) + use gridmod, only: nsig5 + use pcpinfo, only: npredp + implicit none + integer(i_kind),intent(in ):: junit + integer(i_kind),intent(in ):: mobs + integer(i_kind),intent(in ):: jwrite + integer(i_kind),intent(out):: jstat + + character(len=*),parameter:: myname_=myname//'.obsheader_write_' +_ENTRY_(myname_) + + write(junit,iostat=jstat) mobs,jwrite, npredp,nsig5 +_EXIT_(myname_) + return +end subroutine obsheader_write_ + +subroutine obsnode_init_(anode) + use gridmod, only: nsig5 + use pcpinfo, only: npredp + implicit none + class(pcpnode),intent(out):: anode + + character(len=*),parameter:: myname_=myname//'.obsnode_init_' +_ENTRY_(myname_) + !anode = _obsnode_() + anode%llpoint => null() + anode%luse = .false. + anode%time = 0._r_kind + anode%elat = 0._r_kind + anode%elon = 0._r_kind + anode%idv =-1 + anode%iob =-1 + !-anode%dlev = 0._r_kind + !-anode%ich =-1 + + allocate(anode%predp(npredp), & + anode%dpcp_dvar(1:nsig5) ) +_EXIT_(myname_) + return +end subroutine obsnode_init_ + +subroutine obsnode_clean_(anode) + implicit none + class(pcpnode),intent(inout):: anode + + character(len=*),parameter:: myname_=myname//'.obsnode_clean_' +_ENTRY_(myname_) +!_TRACEV_(myname_,'%mytype() =',anode%mytype()) + if(associated(anode%predp )) deallocate(anode%predp) + if(associated(anode%dpcp_dvar)) deallocate(anode%dpcp_dvar) +_EXIT_(myname_) + return +end subroutine obsnode_clean_ + +subroutine obsnode_xread_(anode,iunit,istat,diaglookup,skip) + use m_obsdiagnode, only: obsdiaglookup_locate + implicit none + class(pcpnode) , 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%obs , & + anode%err2 , & + anode%raterr2, & + anode%ges , & + anode%icxp , & + anode%predp(:) , & + anode%dpcp_dvar(:), & + anode%wij(:) , & + anode%ij(:) + if (istat/=0) then + call perr(myname_,'read(%(res,err2,...)), 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 +_EXIT_(myname_) + return +end subroutine obsnode_xread_ + +subroutine obsnode_xwrite_(anode,junit,jstat) + implicit none + class(pcpnode),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%obs , & + anode%err2 , & + anode%raterr2, & + anode%ges , & + anode%icxp , & + anode%predp(:) , & + anode%dpcp_dvar(:), & + 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(pcpnode),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(pcpnode),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(pcpnode), 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_pcpnode diff --git a/src/gsi/mp_compact_diffs_mod1.f90 b/src/gsi/mp_compact_diffs_mod1.f90 index bb924441b7..893ae6a858 100644 --- a/src/gsi/mp_compact_diffs_mod1.f90 +++ b/src/gsi/mp_compact_diffs_mod1.f90 @@ -271,8 +271,6 @@ subroutine cdiff_sd2ew0(nlev,mype) end do -! if(mype==0) write(0,*)' nn,nlat_tot,nlat,nlev=',nn,nlat_tot,nlat,nlev - nlat_0=-1 nlat_1=-2 nn=0 @@ -293,12 +291,6 @@ subroutine cdiff_sd2ew0(nlev,mype) end do end if end do -! write(0,*) ' mype,nlat_0,nlat_1,nlat_1-nlat0+1=',mype,nlat_0,nlat_1,nlat_1-nlat_0+1 -! if(mype==0) then -! do i=1,nlat_tot -! write(0,'(" i,list_sd2ew(:,i)=",i5,4i6)')i,list_sd2ew(1:4,i) -! end do -! end if end subroutine cdiff_sd2ew0 @@ -891,8 +883,6 @@ subroutine cdiff_sd2ns0(nlev,mype) end do -! if(mype==0) write(0,*)' nn,nlon_tot,nlon,nlonh,nlev=',nn,nlon_tot,nlon,nlonh,nlev - nlon_0=-1 nlon_1=-2 nn=0 @@ -913,12 +903,6 @@ subroutine cdiff_sd2ns0(nlev,mype) end do end if end do -! write(0,*) ' mype,nlon_0,nlon_1,nlon_1-nlon0+1=',mype,nlon_0,nlon_1,nlon_1-nlon_0+1 -! if(mype==0) then -! do i=1,nlon_tot -! write(0,'(" i,list_sd2ns(:,i)=",i5,4i6)')i,list_sd2ns(1:4,i) -! end do -! end if end subroutine cdiff_sd2ns0 @@ -1550,8 +1534,8 @@ subroutine mp_compact_dlon(b,dbdx,vector) polu=polu+grid3(ix)*coslon(ix) polv=polv+grid3(ix)*sinlon(ix) end do - polu=polu/float(nlon) - polv=polv/float(nlon) + polu=polu/real(nlon,r_kind) + polv=polv/real(nlon,r_kind) do ix=1,nlon grid3pol(ix)=polu*coslon(ix)+polv*sinlon(ix) end do @@ -1673,8 +1657,8 @@ subroutine mp_compact_dlon_ad(b,dbdx,vector) polu=polu+grid3pol(ix)*coslon(ix) polv=polv+grid3pol(ix)*sinlon(ix) end do - polu=polu/float(nlon) - polv=polv/float(nlon) + polu=polu/real(nlon,r_kind) + polv=polv/real(nlon,r_kind) do ix=1,nlon grid3(ix)=grid3(ix)+polu*coslon(ix)+polv*sinlon(ix) end do @@ -1697,7 +1681,7 @@ subroutine mp_compact_dlon_ad(b,dbdx,vector) ! Transfer scaler input field to work array. ! Zero other work arrays. do ix=1,nlon -! NOTE: Adjoint of first derivative is its negative +! Note: Adjoint of first derivative is its negative b(i12,ix,k)=b(i12,ix,k)-work3(ix) end do end if @@ -1977,8 +1961,8 @@ subroutine mp_uv_pole(u,v) polsu=polsu+u(2,ix,k)*coslon(ix)+v(2,ix,k)*sinlon(ix) polsv=polsv+u(2,ix,k)*sinlon(ix)-v(2,ix,k)*coslon(ix) end do - polsu=polsu/float(nlon) - polsv=polsv/float(nlon) + polsu=polsu/real(nlon,r_kind) + polsv=polsv/real(nlon,r_kind) do ix=1,nlon u(1,ix,k)=polsu*coslon(ix)+polsv*sinlon(ix) v(1,ix,k)=polsu*sinlon(ix)-polsv*coslon(ix) @@ -1993,8 +1977,8 @@ subroutine mp_uv_pole(u,v) polnu=polnu+u(1,ix,k)*coslon(ix)-v(1,ix,k)*sinlon(ix) polnv=polnv+u(1,ix,k)*sinlon(ix)+v(1,ix,k)*coslon(ix) end do - polnu=polnu/float(nlon) - polnv=polnv/float(nlon) + polnu=polnu/real(nlon,r_kind) + polnv=polnv/real(nlon,r_kind) do ix=1,nlon u(2,ix,k)= polnu*coslon(ix)+polnv*sinlon(ix) v(2,ix,k)=-polnu*sinlon(ix)+polnv*coslon(ix) @@ -2055,8 +2039,8 @@ subroutine mp_uv_pole_ad(u,v) u(1,ix,k)=zero v(1,ix,k)=zero end do - polsu=polsu/float(nlon) - polsv=polsv/float(nlon) + polsu=polsu/real(nlon,r_kind) + polsv=polsv/real(nlon,r_kind) do ix=1,nlon u(2,ix,k)=u(2,ix,k)+polsu*coslon(ix)+polsv*sinlon(ix) v(2,ix,k)=v(2,ix,k)+polsu*sinlon(ix)-polsv*coslon(ix) @@ -2073,8 +2057,8 @@ subroutine mp_uv_pole_ad(u,v) u(2,ix,k)=zero v(2,ix,k)=zero end do - polnu=polnu/float(nlon) - polnv=polnv/float(nlon) + polnu=polnu/real(nlon,r_kind) + polnv=polnv/real(nlon,r_kind) do ix=1,nlon u(1,ix,k)=u(1,ix,k)+polnu*coslon(ix)+polnv*sinlon(ix) v(1,ix,k)=v(1,ix,k)-polnu*sinlon(ix)+polnv*coslon(ix)