diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt index 7adab2eed1..23b70b398a 100644 --- a/src/gsi/CMakeLists.txt +++ b/src/gsi/CMakeLists.txt @@ -45,8 +45,8 @@ cmake_minimum_required(VERSION 2.8) list( REMOVE_ITEM GSIFORT_SRC ${STUB_SRC} ${CPLR_SRC} - ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_REGIONAL.F90 - ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_GFS.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_regional.f90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_gfs.f90 ${CMAKE_CURRENT_SOURCE_DIR}/stub_nstmod.f90 ${GSIUTIL_SRC} ${GSIMAIN_SRC} @@ -62,7 +62,7 @@ cmake_minimum_required(VERSION 2.8) if(USE_WRF) list( APPEND GSIFORT_SRC ${CPLR_SRC} - ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_REGIONAL.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_regional.f90 ) endif() @@ -70,7 +70,7 @@ cmake_minimum_required(VERSION 2.8) if(BUILD_GLOBAL) list( APPEND GSIFORT_SRC ${STUB_SRC} - ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_GFS.F90 + ${CMAKE_CURRENT_SOURCE_DIR}/gsi_fixture_gfs.f90 ) endif(BUILD_GLOBAL) diff --git a/src/gsi/gsi_4dvar.f90 b/src/gsi/gsi_4dvar.f90 index d955bd57d1..b961fa97c6 100644 --- a/src/gsi/gsi_4dvar.f90 +++ b/src/gsi/gsi_4dvar.f90 @@ -4,23 +4,23 @@ module gsi_4dvar ! module: gsi_4dvar ! prgmmr: tremolet org: GMAO date: 2007-02-02 ! -! abstract: Contains variables and routines to control GSI 4D-Var +! abstract: Contains variables and routines to control gsi 4d-var ! ! program history log: ! 2007-02-02 tremolet -! 2007-05-29 todling - add initialization of GCM TLM/ADM +! 2007-05-29 todling - add initialization of gcm tlm/adm ! 2007-07-10 todling - flag to allow writing of increment ! 2009-10-09 wu - replace nhr_offset with min_offset and -! set default 1.5 hr for regional not for 4dvar but for FGAT +! set default 1.5 hr for regional not for 4dvar but for fgat ! 2010-03-16 todling - add knob to calculate analysis error from lanczos -! 2010-05-27 todling - add gsi_4dcoupler; remove dependence on GMAO's geos pertmod +! 2010-05-27 todling - add gsi_4dcoupler; remove dependence on gmao's geos pertmod ! 2010-10-05 todling - add bi-cg option ! 2011-03-14 guo - Moved gsi_4dcoupler calls out of this module, to split ! gsi_4dcoupler_init_traj() from gsimain_initialize(), ! and gsi_4dcoupler_final_traj() from gsimain_finalize(), ! 2011-07-10 guo/zhang- add liauon ! 2012-02-08 kleist - add new features for 4dvar with ensemble/hybrid. -! 2012-09-14 Syed RH Rizvi, NCAR/NESL/MMM/DAS - introduced ladtest_obs +! 2012-09-14 Syed RH Rizvi, ncar/nesl/mmm/das - introduced ladtest_obs ! 2015-02-23 Rancic/Thomas - iwinbgn changed from hours to mins, added thin4d ! option to remove thinning in time ! 2015-10-01 Guo - trigger for redistribution of obs when applicable @@ -34,19 +34,19 @@ module gsi_4dvar ! ! Variable Definitions: ! -! l4dvar - 4D-Var on/off -! lsqrtb - Use sqrt(B) preconditioning -! lbicg - Use B preconditioning with bi-conjugate gradient +! l4dvar - 4d-var on/off +! lsqrtb - Use sqrt(b) preconditioning +! lbicg - Use b preconditioning with bi-conjugate gradient ! lcongrad - Use conjugate gradient/Lanczos minimizer -! lbfgsmin - Use L-BFGS minimizer -! ltlint - Use TL inner loop (ie TL intall) -! lanczosave - Save Lanczos vectors to file +! lbfgsmin - Use l-bfgs minimizer +! ltlint - Use tl inner loop (ie tl intall) +! lanczosave - Save lanczos vectors to file ! lnested_loops - Allows multiple inner loops to work at differing resolutions ! jsiga - Calculate approximate analysis errors for iteration jiter=jsiga -! nwrvecs - Number of precond vectors (Lanczos) or pairs of vectors (QN) +! nwrvecs - Number of precond vectors (lanczos) or pairs of vectors (qn) ! being saved -! iorthomax - max number of vectors used for orthogonalization of various CG options -! liauon - turn on IAU mode. The default value is set to .false. +! iorthomax - max number of vectors used for orthogonalization of various cg options +! liauon - turn on iau mode. The default value is set to .false. ! ! ibdate - Date and time at start of 4dvar window ! iadatebgn - Date and time at start of 4dvar window @@ -69,9 +69,9 @@ module gsi_4dvar ! ladtest - Run adjoint test ! ladtest_obs - Run adjoint test for obervation ! lgrtest - Run gradient test -! ltcost - When .t., calc true cost within Lanczos (expensive) +! ltcost - When .t., calc true cost within lanczos (expensive) ! -! idmodel - Run w/ identity GCM TLM and ADM; test mode +! idmodel - Run w/ identity gcm tlm and adm; test mode ! ! l4densvar - Logical flag for 4d-ensemble-var option ! ens_nhr - Time between time levels for ensemble (currently same as nhr_obsbins) @@ -79,11 +79,11 @@ module gsi_4dvar ! this variable defines the assumed filenames for ensemble ! ens_nstarthr - Integer namelist option for first time level for ensemble ! this should generally match with min_offset -! ibin_anl - Analysis update bin. This will be one for any 3D of 4DVAR mode, but -! will be set to center of window for 4D-ens mode -! lwrite4danl - logical to turn on writing out of 4D analysis state for 4D analysis modes +! ibin_anl - Analysis update bin. This will be one for any 3d of 4dvar mode, but +! will be set to center of window for 4d-ens mode +! lwrite4danl - logical to turn on writing out of 4d analysis state for 4D analysis modes ! ** currently only set up for write_gfs in ncepgfs_io module -! nhr_anal - forecast times to output if lwrite4danl=T. if zero, output all times (default). +! nhr_anal - forecast times to output if lwrite4danl=t. if zero, output all times (default). ! if > 0, output specific fcst time given by nhr_anal ! thin4d - When .t., removes thinning of observations due to ! location in the time window @@ -116,7 +116,7 @@ module gsi_4dvar public :: jsiga,ltcost,iorthomax,liauon,lnested_loops public :: l4densvar,ens_nhr,ens_fhrlevs,ens_nstarthr,ibin_anl public :: lwrite4danl,thin4d,nhr_anal - public :: mPEs_observer + public :: mpes_observer public :: tau_fcst public :: efsoi_order public :: efsoi_afcst @@ -158,7 +158,7 @@ module gsi_4dvar integer(i_kind) :: tau_fcst integer(i_kind) :: efsoi_order - integer(i_kind),save:: mPEs_observer=0 + integer(i_kind),save:: mpes_observer=0 real(r_kind) :: iwinbgn, winlen, winoff, winsub, hr_obsbin @@ -228,9 +228,9 @@ subroutine init_4dvar () nhr_anal = 0 tau_fcst = -1 ! ensemble of forecast at hour current+tau_fcst -efsoi_order = 1 ! order of appox used in EFSOI-like settings -efsoi_afcst = .false. ! internal EFSOI-like parameter (NEVER to be in namelist) -efsoi_ana = .false. ! internal EFSOI-like parameter (NEVER to be in namelist) +efsoi_order = 1 ! order of appox used in efsoi-like settings +efsoi_afcst = .false. ! internal efsoi-like parameter (never to be in namelist) +efsoi_ana = .false. ! internal efsoi-like parameter (never to be in namelist) end subroutine init_4dvar ! -------------------------------------------------------------------- @@ -273,7 +273,7 @@ subroutine setup_4dvar(mype) hr_obsbin = real(nhr_obsbin,r_kind) else if (l4dvar) then -! Should depend on resolution of TLM, etc... +! Should depend on resolution of tlm, etc... hr_obsbin = one else if(l4densvar) then hr_obsbin = one @@ -283,16 +283,16 @@ subroutine setup_4dvar(mype) end if ! Setup observation bins -IF (hr_obsbin ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for aeroNode type +! abstract: an oboper extension for aeronode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,50 +23,50 @@ module gsi_aeroOper ! module interface: - use gsi_obOper, only: obOper + use gsi_oboper, only: oboper use aero_setup, only: setup - use m_aeroNode, only: aeroNode + use m_aeronode, only: aeronode use intaodmod , only: intjo => intaod use stpaodmod , only: stpjo => stpaod implicit none - public:: aeroOper ! data stracture + public:: aerooper ! data stracture - type,extends(obOper):: aeroOper + type,extends(oboper):: aerooper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type aeroOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type aerooper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_aeroOper' - type(aeroNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_aerooper' + type(aeronode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[aeroOper]" + mytype="[aerooper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use obsmod , only: write_diag use aeroinfo, only: diag_aero @@ -74,7 +74,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(aeroOper ), intent(inout):: self + class(aerooper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -97,7 +97,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_aero - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) end subroutine setup_ @@ -105,11 +105,11 @@ end subroutine setup_ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(aeroOper ),intent(in ):: self + class(aerooper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,22 +118,22 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(aeroOper ),intent(in):: self + class(aerooper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -146,11 +146,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_aeroOper +end module gsi_aerooper diff --git a/src/gsi/gsi_bias.f90 b/src/gsi/gsi_bias.f90 index 2ee3ba4572..fa647c3746 100644 --- a/src/gsi/gsi_bias.f90 +++ b/src/gsi/gsi_bias.f90 @@ -110,8 +110,8 @@ subroutine read_bias(filename,mype,nbc,sub_z,bundle,istatus) real(r_single),dimension(nlon,nlat):: grid4 real(r_kind),dimension(lat2,lon2,nsig)::work3d - real(r_kind),pointer,dimension(:,:) :: ptr2d=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ptr3d=>NULL() + real(r_kind),pointer,dimension(:,:) :: ptr2d=>null() + real(r_kind),pointer,dimension(:,:,:):: ptr3d=>null() !****************************************************************************** ! Initialize variables used below @@ -252,7 +252,7 @@ subroutine write_bias(filename,mype_out,nbc,sub_z,bundle,istatus) ! !OUTPUT PARAMETERS: ! -! !DESCRIPTION: This routine gathers fields needed for the GSI analysis +! !DESCRIPTION: This routine gathers fields needed for the gsi analysis ! file from subdomains and then transforms the fields from ! grid to spectral space. The spectral coefficients are ! then written to an atmospheric analysis file. @@ -290,8 +290,8 @@ subroutine write_bias(filename,mype_out,nbc,sub_z,bundle,istatus) real(r_kind),dimension(lat1*lon1,nsig):: work3dm real(r_kind),dimension(max(iglobal,itotsub)):: work real(r_single),dimension(nlon,nlat):: grid4 - real(r_kind),pointer,dimension(:,:) :: ptr2d=>NULL() - real(r_kind),pointer,dimension(:,:,:):: ptr3d=>NULL() + real(r_kind),pointer,dimension(:,:) :: ptr2d=>null() + real(r_kind),pointer,dimension(:,:,:):: ptr3d=>null() type(gsi_bundle) xbundle @@ -375,14 +375,14 @@ subroutine write_bias(filename,mype_out,nbc,sub_z,bundle,istatus) istatus=istatus+iret endif - nymd = 10000*iadate(1)+iadate(2)*100+iadate(3) - nhms = 10000*iadate(4) - if(mype==0) write(6,'(2a,i8.8,2x,i6.6)')trim(myname_),': writing out bias on ',& - nymd, nhms - call gsi_bundlecreate(xbundle,bundle(1),'Bias Estimate',iret) - call bkg_bias_model(xbundle,iadate(4)) - call gsi_4dcoupler_putpert (xbundle,nymd,nhms,'tlm','bbias') - call gsi_bundledestroy(xbundle,iret) + nymd = 10000*iadate(1)+iadate(2)*100+iadate(3) + nhms = 10000*iadate(4) + if(mype==0) write(6,'(2a,i8.8,2x,i6.6)')trim(myname_),': writing out bias on ',& + nymd, nhms + call gsi_bundlecreate(xbundle,bundle(1),'Bias Estimate',iret) + call bkg_bias_model(xbundle,iadate(4)) + call gsi_4dcoupler_putpert (xbundle,nymd,nhms,'tlm','bbias') + call gsi_bundledestroy(xbundle,iret) ! return end subroutine write_bias diff --git a/src/gsi/gsi_bundlemod.F90 b/src/gsi/gsi_bundlemod.F90 index ad0a370a4a..2aac34d8f9 100644 --- a/src/gsi/gsi_bundlemod.F90 +++ b/src/gsi/gsi_bundlemod.F90 @@ -1,16 +1,16 @@ !---------------------------------------------------------------------------- !BOP ! -! !MODULE: GSI_BundleMod --- GSI Bundle +! !MODULE: gsi_bundlemod --- gsi bundle ! ! !INTERFACE: ! ! program change log: ! 2018-01-18 G. Ge: change pointer,intent(out) to pointer,intent(inout) -! to solve the GSI crash under INTEL v18+ +! to solve the gsi crash under intel v18+ ! -module GSI_BundleMod +module gsi_bundlemod ! !USES: @@ -25,148 +25,148 @@ module GSI_BundleMod ! ! !PUBLIC MEMBER FUNCTIONS: ! -! public GSI_1D -! public GSI_2D -! public GSI_3D - public GSI_Bundle ! Bundle - public GSI_BundleCreate ! Create a Bundle - public GSI_BundleDup ! Duplicate a Bundle - public GSI_BundleDPlevs ! dot product w/ possible "halo" - public GSI_BundleSum ! dot product w/ possible "halo" - public GSI_BundleSet ! Set Bundle - public GSI_BundleInquire ! Inquire about Bundle contents - public GSI_BundleMerge ! Merge two Bundles - public GSI_BundlePrint ! Print contents of Bundle - public GSI_BundleGetPointer ! Get pointer to variable - public GSI_BundleGetVar ! Get contents of variable - public GSI_BundlePutVar ! Put contents in variable - public GSI_BundleUnset ! Unset Bundle - public GSI_BundleDestroy ! Destroy Bundle - public assignment(=) ! Assign to Bundle contents - public GSI_BundleAssign ! The same functions as assignment(=) above +! public gsi_1d +! public gsi_2d +! public gsi_3d + public gsi_bundle ! bundle + public gsi_bundlecreate ! Create a bundle + public gsi_bundledup ! Duplicate a bundle + public gsi_bundledplevs ! dot product w/ possible "halo" + public gsi_bundlesum ! dot product w/ possible "halo" + public gsi_bundleset ! Set bundle + public gsi_bundleinquire ! Inquire about bundle contents + public gsi_bundlemerge ! Merge two bundles + public gsi_bundleprint ! Print contents of bundle + public gsi_bundlegetpointer ! Get pointer to variable + public gsi_bundlegetvar ! Get contents of variable + public gsi_bundleputvar ! Put contents in variable + public gsi_bundleunset ! Unset bundle + public gsi_bundledestroy ! Destroy bundle + public assignment(=) ! Assign to bundle contents + public gsi_bundleassign ! The same functions as assignment(=) above public self_add ! Add contents of bundles - public gsi_bundleAddmul ! Add scaled contents of a bundle + public gsi_bundleaddmul ! Add scaled contents of a bundle public self_mul ! Add contents of bundles public gsi_bundlehadamard ! Hadamard product of contents of two bundles ! These should be moved out of the bundle soon (gridmod?) - public GSI_Grid ! Grid (not yet general) - public GSI_GridCreate ! Create a grid + public gsi_grid ! Grid (not yet general) + public gsi_gridcreate ! Create a grid ! !METHOD OVERLOADING: - interface GSI_BundleCreate ! create bundle from ... - module procedure create1_ ! scratch - module procedure create2_ ! existing bundle - module procedure create3_ ! merging two bundles + interface gsi_bundlecreate ! create bundle from ... + module procedure create1_ ! scratch + module procedure create2_ ! existing bundle + module procedure create3_ ! merging two bundles end interface - interface GSI_BundleDup ! duplicate a bundle - module procedure dup_ ! dup(x,y) -- y = x - module procedure scl_dup_ ! dup(a,x,y) -- y = a*x - module procedure sclR4_dup_ ! dup(a,x,y) -- y = a*x + interface gsi_bundledup ! duplicate a bundle + module procedure dup_ ! dup(x,y) -- y = x + module procedure scl_dup_ ! dup(a,x,y) -- y = a*x + module procedure sclr4_dup_ ! dup(a,x,y) -- y = a*x end interface - interface GSI_BundleSet ! set pointer to bundle contents - module procedure set0_ - module procedure set1_ + interface gsi_bundleset ! set pointer to bundle contents + module procedure set0_ + module procedure set1_ end interface - interface GSI_BundleInquire ! inquire about bundle ... - module procedure inquire_char_ ! character contents + interface gsi_bundleinquire ! inquire about bundle ... + module procedure inquire_char_ ! character contents end interface - interface GSI_BundleMerge ! merge bundles - module procedure merge_ + interface gsi_bundlemerge ! merge bundles + module procedure merge_ end interface - interface GSI_BundlePrint ! print summary of bundle contents - module procedure print_ + interface gsi_bundleprint ! print summary of bundle contents + module procedure print_ end interface - interface GSI_BundleGetVar ! get fiedl(s) from bundle - module procedure getvar1dr4_ ! real*4 rank-1 field - module procedure getvar1dr8_ ! real*8 rank-1 field - module procedure getvar2dr4_ ! real*4 rank-2 field - module procedure getvar2dr8_ ! real*8 rank-2 field - module procedure getvar2dp1r4_ ! real*4 rank-2+1 field - module procedure getvar2dp1r8_ ! real*8 rank-2+1 field - module procedure getvar3dr4_ ! real*4 rank-3 field - module procedure getvar3dr8_ ! real*8 rank-3 field - module procedure getvar3dp1r4_ ! real*4 rank-3+1 field - module procedure getvar3dp1r8_ ! real*8 rank-3+1 field + interface gsi_bundlegetvar ! get fiedl(s) from bundle + module procedure getvar1dr4_ ! real*4 rank-1 field + module procedure getvar1dr8_ ! real*8 rank-1 field + module procedure getvar2dr4_ ! real*4 rank-2 field + module procedure getvar2dr8_ ! real*8 rank-2 field + module procedure getvar2dp1r4_ ! real*4 rank-2+1 field + module procedure getvar2dp1r8_ ! real*8 rank-2+1 field + module procedure getvar3dr4_ ! real*4 rank-3 field + module procedure getvar3dr8_ ! real*8 rank-3 field + module procedure getvar3dp1r4_ ! real*4 rank-3+1 field + module procedure getvar3dp1r8_ ! real*8 rank-3+1 field end interface - interface GSI_BundlePutVar ! put field(s) in bundle ... - module procedure putvar0dr4_ ! assign field to real*4 constant - module procedure putvar0dr8_ ! assign field to real*8 constant - module procedure putvar1dr4_ ! write to real*4 rank-1 content - module procedure putvar1dr8_ ! write to real*8 rank-1 content - module procedure putvar2dr4_ ! write to real*4 rank-2 content - module procedure putvar2dr8_ ! write to real*8 rank-2 content - module procedure putvar2dp1r4_ ! write to real*4 rank-2+1 content - module procedure putvar2dp1r8_ ! write to real*8 rank-2+1 content - module procedure putvar3dr4_ ! write to real*4 rank-3 content - module procedure putvar3dr8_ ! write to real*8 rank-3 content - module procedure putvar3dp1r4_ ! write to real*4 rank-3+1 content - module procedure putvar3dp1r8_ ! write to real*8 rank-3+1 content + interface gsi_bundleputvar ! put field(s) in bundle ... + module procedure putvar0dr4_ ! assign field to real*4 constant + module procedure putvar0dr8_ ! assign field to real*8 constant + module procedure putvar1dr4_ ! write to real*4 rank-1 content + module procedure putvar1dr8_ ! write to real*8 rank-1 content + module procedure putvar2dr4_ ! write to real*4 rank-2 content + module procedure putvar2dr8_ ! write to real*8 rank-2 content + module procedure putvar2dp1r4_ ! write to real*4 rank-2+1 content + module procedure putvar2dp1r8_ ! write to real*8 rank-2+1 content + module procedure putvar3dr4_ ! write to real*4 rank-3 content + module procedure putvar3dr8_ ! write to real*8 rank-3 content + module procedure putvar3dp1r4_ ! write to real*4 rank-3+1 content + module procedure putvar3dp1r8_ ! write to real*8 rank-3+1 content end interface - interface GSI_BundleGetPointer ! get pointer to field(s) in bundle - module procedure get1_ ! single-field - module procedure get2_ ! many-field - module procedure get31r4_ ! real*4 rank-1 explict pointer (real*4) - module procedure get31r8_ ! real*8 rank-1 explict pointer (real*8) - module procedure get32r4_ ! real*4 rank-2 explict pointer (real*8) - module procedure get32r8_ ! real*8 rank-2 explict pointer (real*4) - module procedure get33r4_ ! real*4 rank-3 explict pointer (real*4) - module procedure get33r8_ ! real*8 rank-3 explict pointer (real*8) + interface gsi_bundlegetpointer ! get pointer to field(s) in bundle + module procedure get1_ ! single-field + module procedure get2_ ! many-field + module procedure get31r4_ ! real*4 rank-1 explict pointer (real*4) + module procedure get31r8_ ! real*8 rank-1 explict pointer (real*8) + module procedure get32r4_ ! real*4 rank-2 explict pointer (real*8) + module procedure get32r8_ ! real*8 rank-2 explict pointer (real*4) + module procedure get33r4_ ! real*4 rank-3 explict pointer (real*4) + module procedure get33r8_ ! real*8 rank-3 explict pointer (real*8) end interface - interface GSI_BundleUnSet ! nullify pointers in bundle - module procedure unset_ + interface gsi_bundleunset ! nullify pointers in bundle + module procedure unset_ end interface - interface GSI_BundleDestroy ! deallocate contents of bundle - module procedure destroy_ + interface gsi_bundledestroy ! deallocate contents of bundle + module procedure destroy_ end interface - interface GSI_BundleAssign - module procedure copy_ - module procedure assignR4_const_ - module procedure assignR8_const_ + interface gsi_bundleassign + module procedure copy_ + module procedure assignr4_const_ + module procedure assignr8_const_ end interface interface assignment (=) - module procedure copy_ - module procedure assignR4_const_ - module procedure assignR8_const_ + module procedure copy_ + module procedure assignr4_const_ + module procedure assignr8_const_ end interface - interface self_add ! What we really want here is ASSIGNMENT (+=) - module procedure self_add_st - module procedure self_add_R4scal - module procedure self_add_R8scal + interface self_add ! What we really want here is assignment (+=) + module procedure self_add_st + module procedure self_add_r4scal + module procedure self_add_r8scal end interface - interface gsi_bundleAddmul ! I believe "addmul" is the conventional name - ! gs_bundleAddmul(y,a,x) := y+=a*x - module procedure self_add_R4scal - module procedure self_add_R8scal + interface gsi_bundleaddmul ! I believe "addmul" is the conventional name + ! gs_bundleaddmul(y,a,x) := y+=a*x + module procedure self_add_r4scal + module procedure self_add_r8scal end interface - interface self_mul ! What we really want here is ASSIGNMENT (+=) - module procedure self_mulR4_ - module procedure self_mulR8_ + interface self_mul ! What we really want here is assignment (+=) + module procedure self_mulr4_ + module procedure self_mulr8_ end interface interface gsi_bundlehadamard - module procedure hadamard_upd_ + module procedure hadamard_upd_ end interface interface gsi_bundledplevs ! needs to be generalized to operate on bundle - module procedure dplevs2dr4_ - module procedure dplevs2dr8_ - module procedure dplevs3dr4_ - module procedure dplevs3dr8_ + module procedure dplevs2dr4_ + module procedure dplevs2dr8_ + module procedure dplevs3dr4_ + module procedure dplevs3dr8_ end interface interface gsi_bundlesum ! needs to be generalized to operate on bundle - module procedure sum2dR4_ - module procedure sum2dR8_ - module procedure sum3dR4_ - module procedure sum3dR8_ + module procedure sum2dr4_ + module procedure sum2dr8_ + module procedure sum3dr4_ + module procedure sum3dr8_ end interface ! !PRIVATE TYPES: - integer(i_kind), parameter :: MAXSTR=256 + integer(i_kind), parameter :: maxstr=256 - type GSI_Grid ! simple regular grid for now + type gsi_grid ! simple regular grid for now integer(i_kind) :: im=-1 ! dim of 1st rank integer(i_kind) :: jm=-1 ! dim of 2nd rank integer(i_kind) :: km=-1 ! dim of 3nd rank @@ -178,110 +178,110 @@ module GSI_BundleMod !! real(r_kind), pointer :: lon(:,:) ! field of longitudes !! real(r_kind), pointer :: pm (:,:,:) ! field of mid-layer pressures !! real(r_kind), pointer :: pe (:,:,:) ! field of edge pressures - end type GSI_Grid + end type gsi_grid - type GSI_1D - character(len=MAXSTR) :: shortname ! name, e.g., 'ps' - character(len=MAXSTR) :: longname ! longname, e.g., 'Surface Pressure' - character(len=MAXSTR) :: units ! units, e.g. 'hPa' - integer(i_kind) :: myKind = -1 ! no default + type gsi_1d + character(len=maxstr) :: shortname ! name, e.g., 'ps' + character(len=maxstr) :: longname ! longname, e.g., 'Surface Pressure' + character(len=maxstr) :: units ! units, e.g. 'hPa' + integer(i_kind) :: mykind = -1 ! no default real(r_single), pointer :: qr4(:) => null() ! rank-1 real*4 field real(r_double), pointer :: qr8(:) => null() ! rank-1 real*8 field real(r_kind), pointer :: q (:) => null() ! points to intrisic rank-1 default precision - end type GSI_1D + end type gsi_1d - type GSI_2D - character(len=MAXSTR) :: shortname - character(len=MAXSTR) :: longname - character(len=MAXSTR) :: units - integer(i_kind) :: myKind = -1 ! no default + type gsi_2d + character(len=maxstr) :: shortname + character(len=maxstr) :: longname + character(len=maxstr) :: units + integer(i_kind) :: mykind = -1 ! no default real(r_single), pointer :: qr4(:,:) => null() ! rank-2 real*4 field real(r_double), pointer :: qr8(:,:) => null() ! rank-2 real*8 field real(r_kind), pointer :: q (:,:) => null() ! points to intrisic rank-2 default precision - end type GSI_2D + end type gsi_2d - type GSI_3D - character(len=MAXSTR) :: shortname - character(len=MAXSTR) :: longname - character(len=MAXSTR) :: units + type gsi_3d + character(len=maxstr) :: shortname + character(len=maxstr) :: longname + character(len=maxstr) :: units integer(i_kind) :: level ! level: size of rank3 other than km - integer(i_kind) :: myKind = -1 ! no default + integer(i_kind) :: mykind = -1 ! no default real(r_single), pointer :: qr4(:,:,:) => null() ! rank-3 real*4 field real(r_double), pointer :: qr8(:,:,:) => null() ! rank-3 real*8 field real(r_kind), pointer :: q (:,:,:) => null() ! points to intrisic rank-3 default precision - end type GSI_3D + end type gsi_3d ! !PUBLIC TYPES: ! - type GSI_Bundle - character(len=MAXSTR) :: name + type gsi_bundle + character(len=maxstr) :: name !!#ifdef HAVE_ESMF -!! type(ESMF_FieldBundle), pointer :: Bundle ! Associated ESMF bundle -!! type(ESMF_Grid) :: grid ! Associated ESMF grid +!! type(esmf_fieldbundle), pointer :: bundle ! Associated esmf bundle +!! type(ESMF_Grid) :: grid ! Associated esmf grid !!#endif /* HAVE_ESMF */ integer(i_kind) :: n1d=-1 ! number of 1-d variables integer(i_kind) :: n2d=-1 ! number of 2-d variables integer(i_kind) :: n3d=-1 ! number of 3-d variables - integer(i_kind) :: NumVars=-1 ! total number of variables (n1d+n2d+n3d) + integer(i_kind) :: numvars=-1 ! total number of variables (n1d+n2d+n3d) integer(i_kind) :: ndim=-1 ! size of pointer values - integer(i_kind) :: AllKinds=-1! overall bundle kind (see Remark 9) - type(GSI_Grid) :: grid - type(GSI_1D), pointer :: r1(:) => null() - type(GSI_2D), pointer :: r2(:) => null() - type(GSI_3D), pointer :: r3(:) => null() + integer(i_kind) :: allkinds=-1! overall bundle kind (see Remark 9) + type(gsi_grid) :: grid + type(gsi_1d), pointer :: r1(:) => null() + type(gsi_2d), pointer :: r2(:) => null() + type(gsi_3d), pointer :: r3(:) => null() integer(i_kind), pointer :: ival1(:) => null() integer(i_kind), pointer :: ival2(:) => null() integer(i_kind), pointer :: ival3(:) => null() real(r_single), pointer :: valuesr4(:) => null() real(r_double), pointer :: valuesr8(:) => null() real(r_kind), pointer :: values (:) => null() - end type GSI_Bundle + end type gsi_bundle interface init_ ! internal procedure only - not to become public - module procedure init1d_ - module procedure init2d_ - module procedure init3d_ + module procedure init1d_ + module procedure init2d_ + module procedure init3d_ end interface interface copy_item_ ! internal procedure only - not to become public - module procedure copy_item1d_ - module procedure copy_item2d_ - module procedure copy_item3d_ + module procedure copy_item1d_ + module procedure copy_item2d_ + module procedure copy_item3d_ end interface interface clean_ ! internal procedure only - not to become public - module procedure clean1d_ - module procedure clean2d_ - module procedure clean3d_ + module procedure clean1d_ + module procedure clean2d_ + module procedure clean3d_ end interface ! -! !DESCRIPTION: This module implements the bundle structure for GSI. -! It is meant to be general enough to allow its use in GSI within +! !DESCRIPTION: This module implements the bundle structure for gsi. +! It is meant to be general enough to allow its use in gsi within ! both the control and the state vectors. Ultimately, the guess-vector of -! GSI could also aim at using the GSI\_Bundle as a general approach to +! GSI could also aim at using the gsi\_bundle as a general approach to ! gathering various fields needed to define the guess. ! -! A first example of the use of GSI\_Bundle is used in the module +! A first example of the use of gsi\_bundle is used in the module ! gsi\_chemguess\_mod.F90 that allows adding an arbitrary number of -! chemical constituents and species into GSI --- with a note that -! only CO and CO2 are currently known by the internal GSI guess module. +! chemical constituents and species into gsi --- with a note that +! only co and co2 are currently known by the internal gsi guess module. ! -! The GSI\_Bundle is a collection of fields defined on a grid. By definition, -! the bundle can only keep fields on the same grid. The concept of a GSI\_Bundle -! is similar to that of an ESMF Bundle. +! The gsi\_bundle is a collection of fields defined on a grid. By definition, +! the bundle can only keep fields on the same grid. The concept of a gsi\_bundle +! is similar to that of an esmf bundle. ! -! This version of GSI\_Bundle is MPI-free. This modules knows nothing about +! This version of gsi\_bundle is mpi-free. This modules knows nothing about ! the distribution of the grid. Indeed, it does not need to know. The only -! procedure that could have an MPI support here is GSI\_BundlePrint, but for +! procedure that could have an mpi support here is gsi\_bundleprint, but for ! now it is simple and ignorant of distributed calling codes. ! ! ! !REVISION HISTORY: ! ! 22Apr2010 Todling - initial code, based on discussion w/ Arlindo da Silva -! and his f90/ESMF's SimpleBundle. -! 18Aug2010 Hu - declared GSI_1D, GSI_2D, and GSI_3D as public. -! 28Apr2011 Todling - complete overload to support REAL*4 and REAL*8 -! 04Jul2011 Todling - large revision of REAL*4 or REAL*8 implementation +! and his f90/esmf's simplebundle. +! 18Aug2010 Hu - declared gsi_1d, gsi_2d, and gsi_3d as public. +! 28Apr2011 Todling - complete overload to support real*4 and real*8 +! 04Jul2011 Todling - large revision of real*4 or real*8 implementation ! 27Jun2012 Parrish - set verbose_ to .false. to turn off diagnostic print in subroutine merge_. ! 05Oct2014 Todling - add 4d-like interfaces to getvars ! 26Aug2017 G. Ge - change names(nd) to names(:) to make the passing of assumed size character @@ -293,29 +293,29 @@ module GSI_BundleMod ! ! !REMARKS: ! -! 1. This module should never depend on more than the following GSI modules: +! 1. This module should never depend on more than the following gsi modules: ! kinds ! constants ! m_rerank ! -! 2. Currently the Bundle uses a very simple (im,jm,km) grid. The grid could -! be generalized. In doing so, it should not be a part of the Bundle, but -! rather an outside entity that can them be used by the Bundle; instead -! of passing im,jm,km the routines would pass the Grid type. +! 2. Currently the bundle uses a very simple (im,jm,km) grid. The grid could +! be generalized. In doing so, it should not be a part of the bundle, but +! rather an outside entity that can them be used by the bundle; instead +! of passing im,jm,km the routines would pass the grid type. ! ! 3. Bundle does not accept redundancy in variable names. ! ! 4. Routines and interfaces are only written if they are needed and can -! be tested in GSI. There is no need to create code that is not being +! be tested in gsi. There is no need to create code that is not being ! used. ! ! 5. Not all prologues will show in "protex -s" since I have purposefully -! placed BOC and EOC strategically to eliminate interfaces that users +! placed boc and eoc strategically to eliminate interfaces that users ! have no need to be concerned with. ! ! 6. This module uses the following conventions: ! -! 6.a) all public procedures are named with the prefix GSI_Bundle +! 6.a) all public procedures are named with the prefix gsi_bundle ! ! 6.b) all public procedures must be declared via an interface ! declaration. @@ -323,9 +323,9 @@ module GSI_BundleMod ! 6.c) name of internal procedures end with an underscore; the ! corresponding public names are created via an interface with a ! similar name without the underscore, e.g., internal procedure -! print_ is made public with the name GSI_BundlePrint +! print_ is made public with the name gsi_bundleprint ! -! 7. For the time being the GSI stop2 routine is being used to kill +! 7. For the time being the gsi stop2 routine is being used to kill ! certain error conditions. Ultimately, this module should never ! call stop2 or be killed. All procedures should return an error ! code. It is up to the calling program to check on the error code @@ -333,45 +333,47 @@ module GSI_BundleMod ! ! 8. An error messaging system has not yet been developed. Ideally, ! this module should have its own error codes and not depend on the -! GSI error codes. +! gsi error codes. ! ! 9. In principle the bundle should be able to handle mix-kind variables, ! however, because of the need to link the fields in the bundle to ! a long array-like entity (values), it turns out that all fields ! in a given bundle must be created with the same kind, therefore -! the existence of AllKinds. +! the existence of allkinds. ! !EOP !------------------------------------------------------------------------- !noBOC - character(len=*), parameter :: myname='GSI_BundleMod' - logical, parameter :: VERBOSE_=.false. + character(len=*), parameter :: myname='gsi_bundlemod' + logical, parameter :: verbose_=.false. integer, parameter :: bundle_kind_def = r_kind ! default kind -CONTAINS +contains !noEOC !............................................................................................ !_BOP ! -! !IROUTINE: Init1d_ --- Initialze rank-1 meta-data +! !IROUTINE: init1d_ --- Initialze rank-1 meta-data ! ! !INTERFACE: - subroutine init1d_(flds,nd,names,istatus,longnames,units,thisKind) + subroutine init1d_(flds,nd,names,istatus,longnames,units,thiskind) + + implicit none ! !INPUT PARAMETERS: integer(i_kind), intent(in):: nd character(len=*),intent(in):: names(:) - character(len=*),OPTIONAL,intent(in):: longnames(nd) - character(len=*),OPTIONAL,intent(in):: units(nd) - integer(i_kind), OPTIONAL,intent(in):: thisKind + character(len=*),optional,intent(in):: longnames(nd) + character(len=*),optional,intent(in):: units(nd) + integer(i_kind), optional,intent(in):: thiskind ! !INPUT/OUTPUT PARAMETERS: - type(GSI_1D), intent(inout):: flds(nd) + type(gsi_1d), intent(inout):: flds(nd) ! !OUTPUT PARAMETERS: @@ -391,13 +393,13 @@ subroutine init1d_(flds,nd,names,istatus,longnames,units,thisKind) integer(i_kind) i do i=1,nd - flds(i)%myKind = thisKind + flds(i)%mykind = thiskind flds(i)%shortname = trim(names(i)) if (present(longnames)) then - flds(i)%longname = trim(longnames(i)) + flds(i)%longname = trim(longnames(i)) endif if (present(units)) then - flds(i)%units = trim(units(i)) + flds(i)%units = trim(units(i)) endif enddo istatus=0 @@ -405,14 +407,15 @@ subroutine init1d_(flds,nd,names,istatus,longnames,units,thisKind) end subroutine init1d_ subroutine clean1d_(flds,nd,istatus) + implicit none integer(i_kind),intent(in) :: nd - type(GSI_1D), intent(inout):: flds(nd) + type(gsi_1D), intent(inout):: flds(nd) integer(i_kind),intent(out) :: istatus integer(i_kind) i do i=1,nd - flds(i)%myKind = -1 + flds(i)%mykind = -1 flds(i)%shortname = "" flds(i)%longname = "" flds(i)%units = "" @@ -421,25 +424,26 @@ subroutine clean1d_(flds,nd,istatus) end subroutine clean1d_ !............................................................................................ - subroutine init2d_(flds,nd,names,istatus,longnames,units,thisKind) + subroutine init2d_(flds,nd,names,istatus,longnames,units,thiskind) + implicit none integer(i_kind), intent(in) :: nd - type(GSI_2D), intent(inout):: flds(nd) + type(gsi_2d), intent(inout):: flds(nd) character(len=*),intent(in):: names(:) integer(i_kind), intent(out):: istatus - character(len=*),OPTIONAL,intent(in):: longnames(nd) - character(len=*),OPTIONAL,intent(in):: units(nd) - integer(i_kind), OPTIONAL,intent(in):: thisKind + character(len=*),optional,intent(in):: longnames(nd) + character(len=*),optional,intent(in):: units(nd) + integer(i_kind), optional,intent(in):: thiskind integer(i_kind) i do i=1,nd - flds(i)%myKind = thisKind + flds(i)%mykind = thiskind flds(i)%shortname = trim(names(i)) if (present(longnames)) then - flds(i)%longname = trim(longnames(i)) + flds(i)%longname = trim(longnames(i)) endif if (present(units)) then - flds(i)%units = trim(units(i)) + flds(i)%units = trim(units(i)) endif enddo istatus=0 @@ -447,14 +451,15 @@ subroutine init2d_(flds,nd,names,istatus,longnames,units,thisKind) end subroutine init2d_ subroutine clean2d_(flds,nd,istatus) + implicit none integer(i_kind),intent(in) :: nd - type(GSI_2D), intent(inout):: flds(nd) + type(gsi_2d), intent(inout):: flds(nd) integer(i_kind),intent(out):: istatus integer(i_kind) i do i=1,nd - flds(i)%myKind = -1 + flds(i)%mykind = -1 flds(i)%shortname = "" flds(i)%longname = "" flds(i)%units = "" @@ -463,25 +468,26 @@ subroutine clean2d_(flds,nd,istatus) end subroutine clean2d_ !............................................................................................ - subroutine init3d_(flds,nd,names,istatus,longnames,units,thisKind) + subroutine init3d_(flds,nd,names,istatus,longnames,units,thiskind) + implicit none integer(i_kind), intent(in) :: nd - type(GSI_3D), intent(inout):: flds(nd) + type(gsi_3d), intent(inout):: flds(nd) character(len=*),intent(in):: names(:) integer(i_kind), intent(out):: istatus - character(len=*),OPTIONAL,intent(in):: longnames(nd) - character(len=*),OPTIONAL,intent(in):: units(nd) - integer(i_kind), OPTIONAL,intent(in):: thisKind + character(len=*),optional,intent(in):: longnames(nd) + character(len=*),optional,intent(in):: units(nd) + integer(i_kind), optional,intent(in):: thiskind integer(i_kind) i do i=1,nd - flds(i)%myKind = thisKind + flds(i)%mykind = thiskind flds(i)%shortname = trim(names(i)) if (present(longnames)) then - flds(i)%longname = trim(longnames(i)) + flds(i)%longname = trim(longnames(i)) endif if (present(units)) then - flds(i)%units = trim(units(i)) + flds(i)%units = trim(units(i)) endif enddo istatus=0 @@ -489,14 +495,15 @@ subroutine init3d_(flds,nd,names,istatus,longnames,units,thisKind) end subroutine init3d_ subroutine clean3d_(flds,nd,istatus) + implicit none integer(i_kind),intent(in) :: nd - type(GSI_3D), intent(inout):: flds(nd) + type(gsi_3d), intent(inout):: flds(nd) integer(i_kind),intent(out):: istatus integer(i_kind) i do i=1,nd - flds(i)%myKind = -1 + flds(i)%mykind = -1 flds(i)%shortname = "" flds(i)%longname = "" flds(i)%units = "" @@ -507,110 +514,113 @@ end subroutine clean3d_ !............................................................................................ subroutine copy_item1d_ (i1,i2,fld1,fld2,istatus) + implicit none integer(i_kind),intent(in) :: i1(:),i2(:) - type(GSI_1D), intent(in) :: fld1(:) - type(GSI_1D), intent(inout):: fld2(:) + type(gsi_1d), intent(in) :: fld1(:) + type(gsi_1d), intent(inout):: fld2(:) integer(i_kind),intent(out) :: istatus integer(i_kind) i istatus=0 if(size(i1)>size(i2)) then - istatus=1 - return + istatus=1 + return endif do i = 1, size(i1) fld2(i2(i))%shortname = fld1(i1(i))%shortname fld2(i2(i))%longname = fld1(i1(i))%longname fld2(i2(i))%units = fld1(i1(i))%units - fld2(i2(i))%myKind = fld1(i1(i))%myKind - if (fld1(i1(i))%myKind == r_single ) then + fld2(i2(i))%mykind = fld1(i1(i))%mykind + if (fld1(i1(i))%mykind == r_single ) then #ifdef _REAL4_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr4 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr4 =>fld2(i2(i))%q #else - fld2(i2(i))%qr4 = fld1(i1(i))%qr4 + fld2(i2(i))%qr4 = fld1(i1(i))%qr4 #endif - else if ( fld1(i1(i))%myKind == r_double ) then + else if ( fld1(i1(i))%mykind == r_double ) then #ifdef _REAL8_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr8 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr8 =>fld2(i2(i))%q #else - fld2(i2(i))%qr8 = fld1(i1(i))%qr8 + fld2(i2(i))%qr8 = fld1(i1(i))%qr8 #endif else - istatus=1 - return + istatus=1 + return endif enddo end subroutine copy_item1d_ subroutine copy_item2d_ (i1,i2,fld1,fld2,istatus) + implicit none integer(i_kind),intent(in) :: i1(:),i2(:) - type(GSI_2D), intent(in) :: fld1(:) - type(GSI_2D), intent(inout):: fld2(:) + type(gsi_2d), intent(in) :: fld1(:) + type(gsi_2d), intent(inout):: fld2(:) integer(i_kind),intent(out) :: istatus integer(i_kind) i istatus=0 if(size(i1)>size(i2)) then - istatus=1 - return + istatus=1 + return endif do i = 1, size(i1) fld2(i2(i))%shortname = fld1(i1(i))%shortname fld2(i2(i))%longname = fld1(i1(i))%longname fld2(i2(i))%units = fld1(i1(i))%units - fld2(i2(i))%myKind = fld1(i1(i))%myKind - if (fld1(i1(i))%myKind == r_single ) then + fld2(i2(i))%mykind = fld1(i1(i))%mykind + if (fld1(i1(i))%mykind == r_single ) then #ifdef _REAL4_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr4 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr4 =>fld2(i2(i))%q #else - fld2(i2(i))%qr4 = fld1(i1(i))%qr4 + fld2(i2(i))%qr4 = fld1(i1(i))%qr4 #endif - else if ( fld1(i1(i))%myKind == r_double ) then + else if ( fld1(i1(i))%mykind == r_double ) then #ifdef _REAL8_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr8 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr8 =>fld2(i2(i))%q #else - fld2(i2(i))%qr8 = fld1(i1(i))%qr8 + fld2(i2(i))%qr8 = fld1(i1(i))%qr8 #endif else - istatus=1 - return + istatus=1 + return endif enddo end subroutine copy_item2d_ subroutine copy_item3d_ (i1,i2,fld1,fld2,istatus) + implicit none integer(i_kind),intent(in) :: i1(:),i2(:) - type(GSI_3D), intent(in) :: fld1(:) - type(GSI_3D), intent(inout):: fld2(:) + type(gsi_3d), intent(in) :: fld1(:) + type(gsi_3d), intent(inout):: fld2(:) integer(i_kind),intent(out) :: istatus integer(i_kind) i istatus=0 if(size(i1)>size(i2)) then - istatus=1 - return + istatus=1 + return endif do i = 1, size(i1) fld2(i2(i))%shortname = fld1(i1(i))%shortname fld2(i2(i))%longname = fld1(i1(i))%longname fld2(i2(i))%units = fld1(i1(i))%units - fld2(i2(i))%myKind = fld1(i1(i))%myKind - if (fld1(i1(i))%myKind == r_single ) then + fld2(i2(i))%mykind = fld1(i1(i))%mykind + if (fld1(i1(i))%mykind == r_single ) then #ifdef _REAL4_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr4 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr4 =>fld2(i2(i))%q #else - fld2(i2(i))%qr4 = fld1(i1(i))%qr4 + fld2(i2(i))%qr4 = fld1(i1(i))%qr4 #endif - else if ( fld1(i1(i))%myKind == r_double ) then + else if ( fld1(i1(i))%mykind == r_double ) then #ifdef _REAL8_ - fld2(i2(i))%q = fld1(i1(i))%q - fld2(i2(i))%qr8 =>fld2(i2(i))%q + fld2(i2(i))%q = fld1(i1(i))%q + fld2(i2(i))%qr8 =>fld2(i2(i))%q #else - fld2(i2(i))%qr8 = fld1(i1(i))%qr8 + fld2(i2(i))%qr8 = fld1(i1(i))%qr8 #endif else - istatus=1 - return + istatus=1 + return endif enddo end subroutine copy_item3d_ @@ -618,30 +628,31 @@ end subroutine copy_item3d_ !............................................................................................ !BOP ! -! !IROUTINE: Set0_ --- Set pointers to bundle; all vars interface +! !IROUTINE: set0_ --- Set pointers to bundle; all vars interface ! ! !INTERFACE: ! - subroutine set0_ ( Bundle, grid, name, istatus, & + subroutine set0_ ( bundle, grid, name, istatus, & names1d, names2d, names3d, levels, bundle_kind ) + implicit none ! !INPUT PARAMETERS: - type(GSI_Grid), intent(in) :: grid + type(gsi_grid), intent(in) :: grid character(len=*),intent(in) :: name ! define name of this bundle - character(len=*),OPTIONAL,intent(in) :: names1d(:) ! 1-d variable names - character(len=*),OPTIONAL,intent(in) :: names2d(:) ! 2-d variable names - character(len=*),OPTIONAL,intent(in) :: names3d(:) ! 3-d variable names - integer(i_kind), OPTIONAL,intent(in) :: levels(:) ! array of size(names3d) + character(len=*),optional,intent(in) :: names1d(:) ! 1-d variable names + character(len=*),optional,intent(in) :: names2d(:) ! 2-d variable names + character(len=*),optional,intent(in) :: names3d(:) ! 3-d variable names + integer(i_kind), optional,intent(in) :: levels(:) ! array of size(names3d) ! indicating third dim ! of fields (possibly ! diff from km) - integer, OPTIONAL,intent(in) :: bundle_kind! overall bundle kind + integer(i_kind), optional,intent(in) :: bundle_kind! overall bundle kind ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle) :: Bundle ! The Bundle + type(gsi_bundle) :: bundle ! The bundle ! !OUTPUT PARAMETERS: @@ -674,87 +685,87 @@ subroutine set0_ ( Bundle, grid, name, istatus, & n1d = -1 n2d = -1 n3d = -1 - Bundle%name = name + bundle%name = name ! ... need grid create for more general grids ! copy external grid ... im=grid%im jm=grid%jm km=grid%km ! ... to internal grid - Bundle%grid%im=im - Bundle%grid%jm=jm - Bundle%grid%km=km + bundle%grid%im=im + bundle%grid%jm=jm + bundle%grid%km=km ndim1d=im ndim2d=ndim1d*jm ndim3d=ndim2d*km if ( present(bundle_kind)) then - Bundle%AllKinds = bundle_kind + bundle%allkinds = bundle_kind else - Bundle%AllKinds = bundle_kind_def + bundle%allkinds = bundle_kind_def endif ! First count vector size for ... ! 1-d arrays ... ntotal=0 if (present(names1d)) then - nd=size(names1d) - if (nd>0) then - n1d=nd - allocate(Bundle%r1(n1d), stat=istatus) - call init_ (Bundle%r1(:),n1d,names1d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus - call stop2(999) - endif - ntotal=ntotal+n1d*ndim1d - endif + nd=size(names1d) + if (nd>0) then + n1d=nd + allocate(bundle%r1(n1d), stat=istatus) + call init_ (bundle%r1(:),n1d,names1d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus + call stop2(999) + endif + ntotal=ntotal+n1d*ndim1d + endif endif ! 2-d arrays ... if (present(names2d)) then - nd=size(names2d) - if (nd>0) then - n2d=nd - allocate(Bundle%r2(n2d), stat=istatus) - call init_ (Bundle%r2(:),n2d,names2d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init2), ', istatus - call stop2(999) - endif - ntotal=ntotal+n2d*ndim2d - endif + nd=size(names2d) + if (nd>0) then + n2d=nd + allocate(bundle%r2(n2d), stat=istatus) + call init_ (bundle%r2(:),n2d,names2d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init2), ', istatus + call stop2(999) + endif + ntotal=ntotal+n2d*ndim2d + endif endif ! and 3-d if (present(names3d)) then - nd=size(names3d) - if (nd>0) then - n3d=nd - allocate(Bundle%r3(n3d), stat=istatus) - call init_ (Bundle%r3(:),n3d,names3d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init3), ', istatus - call stop2(999) - endif - if (present(levels)) then - do i=1,n3d - Bundle%r3(i)%level = levels(i) - if(levels(i)/=km) then - ntotal=ntotal+ndim2d*levels(i) - else - ntotal=ntotal+ndim3d - endif - enddo - else - do i=1,n3d - Bundle%r3(i)%level = km - enddo - ntotal=ntotal+n3d*ndim3d - endif - endif + nd=size(names3d) + if (nd>0) then + n3d=nd + allocate(bundle%r3(n3d), stat=istatus) + call init_ (bundle%r3(:),n3d,names3d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init3), ', istatus + call stop2(999) + endif + if (present(levels)) then + do i=1,n3d + bundle%r3(i)%level = levels(i) + if(levels(i)/=km) then + ntotal=ntotal+ndim2d*levels(i) + else + ntotal=ntotal+ndim3d + endif + enddo + else + do i=1,n3d + bundle%r3(i)%level = km + enddo + ntotal=ntotal+n3d*ndim3d + endif + endif endif - if(n1d>0) allocate(Bundle%ival1(n1d),stat=istatus) - if(n2d>0) allocate(Bundle%ival2(n2d),stat=istatus) - if(n3d>0) allocate(Bundle%ival3(n3d),stat=istatus) + if(n1d>0) allocate(bundle%ival1(n1d),stat=istatus) + if(n2d>0) allocate(bundle%ival2(n2d),stat=istatus) + if(n3d>0) allocate(bundle%ival3(n3d),stat=istatus) if(istatus/=0) then write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus call stop2(999) @@ -762,120 +773,122 @@ subroutine set0_ ( Bundle, grid, name, istatus, & ii=0 if (n3d>0) then - do i = 1, n3d - km1=km; ndim3d1=ndim3d - if(Bundle%r3(i)%level/=km) then - km1=Bundle%r3(i)%level - ndim3d1=ndim2d*km1 - endif - if (Bundle%r3(i)%myKind == r_single) then + do i = 1, n3d + km1=km; ndim3d1=ndim3d + if(bundle%r3(i)%level/=km) then + km1=bundle%r3(i)%level + ndim3d1=ndim2d*km1 + endif + if (bundle%r3(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r3(i)%q => rerank(Bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) - Bundle%r3(i)%qr4 => Bundle%r3(i)%q + bundle%r3(i)%q => rerank(bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr4 => bundle%r3(i)%q #else - Bundle%r3(i)%qr4 => rerank(Bundle%valuesr4(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr4 => rerank(bundle%valuesr4(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) #endif - else if (Bundle%r3(i)%myKind == r_double) then + else if (bundle%r3(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r3(i)%q => rerank(Bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) - Bundle%r3(i)%qr8 => Bundle%r3(i)%q + bundle%r3(i)%q => rerank(bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr8 => bundle%r3(i)%q #else - Bundle%r3(i)%qr8 => rerank(Bundle%valuesr8(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr8 => rerank(bundle%valuesr8(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r3, ', istatus - call stop2(999) - endif - Bundle%ival3(i) = ii+1 - ii=ii+ndim3d1 - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r3, ', istatus + call stop2(999) + endif + bundle%ival3(i) = ii+1 + ii=ii+ndim3d1 + enddo endif if (n2d>0) then - do i = 1, n2d - if (Bundle%r2(i)%myKind == r_single) then + do i = 1, n2d + if (bundle%r2(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r2(i)%q => rerank(Bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) - Bundle%r2(i)%qr4 => Bundle%r2(i)%q + bundle%r2(i)%q => rerank(bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr4 => bundle%r2(i)%q #else - Bundle%r2(i)%qr4 => rerank(Bundle%valuesr4(ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr4 => rerank(bundle%valuesr4(ii+1:ii+ndim2d),mold2,(/im,jm/)) #endif - else if (Bundle%r2(i)%myKind == r_double) then + else if (bundle%r2(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r2(i)%q => rerank(Bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) - Bundle%r2(i)%qr8 => Bundle%r2(i)%q + bundle%r2(i)%q => rerank(bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr8 => bundle%r2(i)%q #else - Bundle%r2(i)%qr8 => rerank(Bundle%valuesr8(ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr8 => rerank(bundle%valuesr8(ii+1:ii+ndim2d),mold2,(/im,jm/)) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r2, ', istatus - call stop2(999) - endif - Bundle%ival2(i) = ii+1 - ii=ii+ndim2d - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r2, ', istatus + call stop2(999) + endif + bundle%ival2(i) = ii+1 + ii=ii+ndim2d + enddo endif if (n1d>0) then - do i = 1, n1d - if (Bundle%r1(i)%myKind == r_single) then + do i = 1, n1d + if (bundle%r1(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr4 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%r1(i)%q #else - Bundle%r1(i)%qr4 => Bundle%valuesr4(ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%valuesr4(ii+1:ii+ndim1d) #endif - else if (Bundle%r1(i)%myKind == r_double) then + else if (bundle%r1(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr8 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%r1(i)%q #else - Bundle%r1(i)%qr8 => Bundle%valuesr8(ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%valuesr8(ii+1:ii+ndim1d) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus - call stop2(999) - endif - Bundle%ival1(i) = ii+1 - ii=ii+ndim1d - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus + call stop2(999) + endif + bundle%ival1(i) = ii+1 + ii=ii+ndim1d + enddo endif if(ii==ntotal) then - Bundle%ndim = ntotal + bundle%ndim = ntotal else istatus=1 write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus call stop2(999) endif - Bundle%NumVars=max(0,n1d)+max(0,n2d)+max(0,n3d) - Bundle%n1d=n1d - Bundle%n2d=n2d - Bundle%n3d=n3d + bundle%numvars=max(0,n1d)+max(0,n2d)+max(0,n3d) + bundle%n1d=n1d + bundle%n2d=n2d + bundle%n3d=n3d end subroutine set0_ !noEOC !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: Set1_ --- Set pointers to bundle; 1-d interface +! !IROUTINE: set1_ --- Set pointers to bundle; 1-d interface ! ! !INTERFACE: ! - subroutine set1_ ( Bundle, im, name, istatus, & + subroutine set1_ ( bundle, im, name, istatus, & names1d, bundle_kind ) + implicit none + ! !INPUT PARAMETERS: integer(i_kind), intent(in) :: im ! first dimension of grid character(len=*),intent(in) :: name ! define name of this bundle - character(len=*),OPTIONAL,intent(in) :: names1d(:) ! 1-d variable names - integer, OPTIONAL,intent(in) :: bundle_kind! overall bundle kind + character(len=*),optional,intent(in) :: names1d(:) ! 1-d variable names + integer(i_kind), optional,intent(in) :: bundle_kind! overall bundle kind ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle) :: Bundle ! The Bundle + type(gsi_bundle) :: bundle ! The bundle ! !OUTPUT PARAMETERS: @@ -902,35 +915,35 @@ subroutine set1_ ( Bundle, im, name, istatus, & integer(i_kind) :: i,ii,nd,n1d,ndim1d,ntotal n1d = -1 - Bundle%name = name + bundle%name = name ! ... need grid create for more general grids - Bundle%grid%im=im + bundle%grid%im=im ndim1d=im if ( present(bundle_kind)) then - Bundle%AllKinds = bundle_kind + bundle%allkinds = bundle_kind else - Bundle%AllKinds = bundle_kind_def + bundle%allkinds = bundle_kind_def endif ! First count vector size for ... ! 1-d arrays ... ntotal=0 if (present(names1d)) then - nd=size(names1d) - if (nd>0) then - n1d=nd - allocate(Bundle%r1(n1d), stat=istatus) - call init_ (Bundle%r1(:),n1d,names1d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus - call stop2(999) - endif - ntotal=ntotal+n1d*ndim1d - endif + nd=size(names1d) + if (nd>0) then + n1d=nd + allocate(bundle%r1(n1d), stat=istatus) + call init_ (bundle%r1(:),n1d,names1d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus + call stop2(999) + endif + ntotal=ntotal+n1d*ndim1d + endif endif - Bundle%ndim = ntotal + bundle%ndim = ntotal - if(n1d>0) allocate(Bundle%ival1(n1d),stat=istatus) + if(n1d>0) allocate(bundle%ival1(n1d),stat=istatus) if(istatus/=0) then write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus call stop2(999) @@ -938,71 +951,71 @@ subroutine set1_ ( Bundle, im, name, istatus, & ii=0 if (n1d>0) then - do i = 1, n1d - if (Bundle%r1(i)%myKind == r_single) then + do i = 1, n1d + if (bundle%r1(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr4 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%r1(i)%q #else - Bundle%r1(i)%qr4 => Bundle%valuesr4(ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%valuesr4(ii+1:ii+ndim1d) #endif - else if (Bundle%r3(i)%myKind == r_double) then + else if (bundle%r3(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr8 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%r1(i)%q #else - Bundle%r1(i)%qr8 => Bundle%valuesr8(ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%valuesr8(ii+1:ii+ndim1d) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus - call stop2(999) - endif - Bundle%ival1(i) = ii+1 - ii=ii+ndim1d - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus + call stop2(999) + endif + bundle%ival1(i) = ii+1 + ii=ii+ndim1d + enddo endif if(ii==ntotal) then - Bundle%ndim = ntotal + bundle%ndim = ntotal else istatus=1 write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus call stop2(999) endif - Bundle%NumVars=max(0,n1d) - Bundle%n1d=n1d + bundle%numvars=max(0,n1d) + bundle%n1d=n1d end subroutine set1_ !noEOC !............................................................................................ !BOP ! -! !IROUTINE: Create1_ --- Create generel bundle from grid specification and var names +! !IROUTINE: create1_ --- Create generel bundle from grid specification and var names ! ! !INTERFACE: ! - subroutine create1_ ( Bundle, grid, name, istatus, & + subroutine create1_ ( bundle, grid, name, istatus, & names1d, names2d, names3d, levels, bundle_kind ) implicit none ! !INPUT PARAMETERS: - type(GSI_Grid), intent(in) :: grid ! GSI grid + type(gsi_grid), intent(in) :: grid ! gsi grid character(len=*),intent(in) :: name ! define name of this bundle - character(len=*),OPTIONAL,intent(in) :: names1d(:) ! 1-d variable names - character(len=*),OPTIONAL,intent(in) :: names2d(:) ! 2-d variable names - character(len=*),OPTIONAL,intent(in) :: names3d(:) ! 3-d variable names - integer(i_kind), OPTIONAL,intent(in) :: levels(:) ! arrays of size(names3d) + character(len=*),optional,intent(in) :: names1d(:) ! 1-d variable names + character(len=*),optional,intent(in) :: names2d(:) ! 2-d variable names + character(len=*),optional,intent(in) :: names3d(:) ! 3-d variable names + integer(i_kind), optional,intent(in) :: levels(:) ! arrays of size(names3d) ! indicating level of 3d ! fields (may diff from km) - integer, OPTIONAL,intent(in) :: bundle_kind! overall bundle kind + integer(i_kind), optional,intent(in) :: bundle_kind! overall bundle kind ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle) :: Bundle ! The Bundle + type(gsi_bundle) :: bundle ! The bundle ! !OUTPUT PARAMETERS: @@ -1019,7 +1032,7 @@ subroutine create1_ ( Bundle, grid, name, istatus, & ! !REVISION HISTORY: ! ! 05May2010 Todling Initial code. -! 03May2010 Treadon Add (:) to Bundle%r1, %r2, %r3 when calling init_. +! 03May2010 Treadon Add (:) to bundle%r1, %r2, %r3 when calling init_. ! 10May2010 Todling Add handling for edge-like fields. ! 16May2010 Todling Pass the grid instead of im,jm,km. ! 22Oct2013 Todling Replace edges with levels. @@ -1036,225 +1049,225 @@ subroutine create1_ ( Bundle, grid, name, istatus, & n1d = -1 n2d = -1 n3d = -1 - Bundle%name = name + bundle%name = name ! ... need grid create for more general grids im=grid%im jm=grid%jm km=grid%km - Bundle%grid%im=im - Bundle%grid%jm=jm - Bundle%grid%km=km + bundle%grid%im=im + bundle%grid%jm=jm + bundle%grid%km=km ndim1d=im ndim2d=ndim1d*jm ndim3d=ndim2d*km if (present(bundle_kind)) then - Bundle%AllKinds = bundle_kind + bundle%allkinds = bundle_kind else - Bundle%AllKinds = bundle_kind_def + bundle%allkinds = bundle_kind_def endif ! First count vector size for ... ! 1-d arrays ... ntotal=0 if (present(names1d)) then - nd=size(names1d) - if (nd>0) then - n1d=nd - allocate(Bundle%r1(n1d), stat=istatus) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(r1), ', istatus - call stop2(999) - endif - ntotal=ntotal+n1d*ndim1d - endif + nd=size(names1d) + if (nd>0) then + n1d=nd + allocate(bundle%r1(n1d), stat=istatus) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(r1), ', istatus + call stop2(999) + endif + ntotal=ntotal+n1d*ndim1d + endif endif ! 2-d arrays ... if (present(names2d)) then - nd=size(names2d) - if (nd>0) then - n2d=nd - allocate(Bundle%r2(n2d), stat=istatus) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(r2), ', istatus - call stop2(999) - endif - ntotal=ntotal+n2d*ndim2d - endif + nd=size(names2d) + if (nd>0) then + n2d=nd + allocate(bundle%r2(n2d), stat=istatus) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(r2), ', istatus + call stop2(999) + endif + ntotal=ntotal+n2d*ndim2d + endif endif ! and 3-d if (present(names3d)) then - nd=size(names3d) - if (nd>0) then - n3d=nd - allocate(Bundle%r3(n3d), stat=istatus) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(r3), ', istatus - call stop2(999) - endif - if (present(levels)) then - do i=1,n3d - Bundle%r3(i)%level = levels(i) - if(levels(i)/=km) then - ntotal=ntotal+ndim2d*levels(i) - else - ntotal=ntotal+ndim3d - endif - enddo - else - do i=1,n3d - Bundle%r3(i)%level = km - enddo - ntotal=ntotal+n3d*ndim3d - endif - endif + nd=size(names3d) + if (nd>0) then + n3d=nd + allocate(bundle%r3(n3d), stat=istatus) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(r3), ', istatus + call stop2(999) + endif + if (present(levels)) then + do i=1,n3d + bundle%r3(i)%level = levels(i) + if(levels(i)/=km) then + ntotal=ntotal+ndim2d*levels(i) + else + ntotal=ntotal+ndim3d + endif + enddo + else + do i=1,n3d + bundle%r3(i)%level = km + enddo + ntotal=ntotal+n3d*ndim3d + endif + endif endif ! Now allocate long vector - if (Bundle%AllKinds == r_single) then + if (bundle%allkinds == r_single) then #ifdef _REAL4_ - allocate(Bundle%values (ntotal),stat=istatus) - Bundle%values =zero_single - Bundle%valuesR4=>Bundle%values + allocate(bundle%values (ntotal),stat=istatus) + bundle%values =zero_single + bundle%valuesr4=>bundle%values #else - allocate(Bundle%valuesR4(ntotal),stat=istatus) - Bundle%valuesR4=zero_single + allocate(bundle%valuesr4(ntotal),stat=istatus) + bundle%valuesr4=zero_single #endif - else if (Bundle%AllKinds == r_double) then + else if (bundle%allkinds == r_double) then #ifdef _REAL8_ - allocate(Bundle%values (ntotal),stat=istatus) - Bundle%values =zero - Bundle%valuesR8=>Bundle%values + allocate(bundle%values (ntotal),stat=istatus) + bundle%values =zero + bundle%valuesr8=>bundle%values #else - allocate(Bundle%valuesR8(ntotal),stat=istatus) - Bundle%valuesR8=zero + allocate(bundle%valuesr8(ntotal),stat=istatus) + bundle%valuesr8=zero #endif else - istatus = 999 + istatus = 999 endif if(istatus/=0) then write(6,*) myname_, ':trouble allocating ',trim(name),' values, ', istatus call stop2(999) endif - if(n1d>0) allocate(Bundle%ival1(n1d),stat=istatus) - if(n2d>0) allocate(Bundle%ival2(n2d),stat=istatus) - if(n3d>0) allocate(Bundle%ival3(n3d),stat=istatus) + if(n1d>0) allocate(bundle%ival1(n1d),stat=istatus) + if(n2d>0) allocate(bundle%ival2(n2d),stat=istatus) + if(n3d>0) allocate(bundle%ival3(n3d),stat=istatus) if(istatus/=0) then write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus call stop2(999) endif if (present(names3d)) then - if (n3d>0) then - call init_ (Bundle%r3(:),n3d,names3d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init3), ', istatus - call stop2(999) - endif - endif + if (n3d>0) then + call init_ (bundle%r3(:),n3d,names3d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init3), ', istatus + call stop2(999) + endif + endif endif if (present(names2d)) then - if (n2d>0) then - call init_ (Bundle%r2(:),n2d,names2d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init2), ', istatus - call stop2(999) - endif - endif + if (n2d>0) then + call init_ (bundle%r2(:),n2d,names2d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init2), ', istatus + call stop2(999) + endif + endif endif if (present(names1d)) then - if (n1d>0) then - call init_ (Bundle%r1(:),n1d,names1d,istatus,thisKind=Bundle%AllKinds) - if(istatus/=0)then - write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus - call stop2(999) - endif - endif + if (n1d>0) then + call init_ (bundle%r1(:),n1d,names1d,istatus,thiskind=bundle%allkinds) + if(istatus/=0)then + write(6,*) myname_, ':trouble allocating ',trim(name),'(init1), ', istatus + call stop2(999) + endif + endif endif ii=0 if (n3d>0) then - do i = 1, n3d - km1=km; ndim3d1=ndim3d - if(Bundle%r3(i)%level/=km) then - km1=Bundle%r3(i)%level - ndim3d1=ndim2d*km1 - endif - if (Bundle%r3(i)%myKind == r_single) then + do i = 1, n3d + km1=km; ndim3d1=ndim3d + if(bundle%r3(i)%level/=km) then + km1=bundle%r3(i)%level + ndim3d1=ndim2d*km1 + endif + if (bundle%r3(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r3(i)%q => rerank(Bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) - Bundle%r3(i)%qr4 => Bundle%r3(i)%q + bundle%r3(i)%q => rerank(bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr4 => bundle%r3(i)%q #else - Bundle%r3(i)%qr4 => rerank(Bundle%valuesr4(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr4 => rerank(bundle%valuesr4(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) #endif - else if (Bundle%r3(i)%myKind == r_double) then + else if (bundle%r3(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r3(i)%q => rerank(Bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) - Bundle%r3(i)%qr8 => Bundle%r3(i)%q + bundle%r3(i)%q => rerank(bundle%values (ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr8 => bundle%r3(i)%q #else - Bundle%r3(i)%qr8 => rerank(Bundle%valuesr8(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) + bundle%r3(i)%qr8 => rerank(bundle%valuesr8(ii+1:ii+ndim3d1),mold3,(/im,jm,km1/)) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r3, ', istatus - call stop2(999) - endif - Bundle%ival3(i) = ii+1 - ii=ii+ndim3d1 - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r3, ', istatus + call stop2(999) + endif + bundle%ival3(i) = ii+1 + ii=ii+ndim3d1 + enddo endif if (n2d>0) then - do i = 1, n2d - if (Bundle%r2(i)%myKind == r_single) then + do i = 1, n2d + if (bundle%r2(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r2(i)%q => rerank(Bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) - Bundle%r2(i)%qr4 => Bundle%r2(i)%q + bundle%r2(i)%q => rerank(bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr4 => bundle%r2(i)%q #else - Bundle%r2(i)%qr4 => rerank(Bundle%valuesr4(ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr4 => rerank(bundle%valuesr4(ii+1:ii+ndim2d),mold2,(/im,jm/)) #endif - else if (Bundle%r2(i)%myKind == r_double) then + else if (bundle%r2(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r2(i)%q => rerank(Bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) - Bundle%r2(i)%qr8 => Bundle%r2(i)%q + bundle%r2(i)%q => rerank(bundle%values (ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr8 => bundle%r2(i)%q #else - Bundle%r2(i)%qr8 => rerank(Bundle%valuesr8(ii+1:ii+ndim2d),mold2,(/im,jm/)) + bundle%r2(i)%qr8 => rerank(bundle%valuesr8(ii+1:ii+ndim2d),mold2,(/im,jm/)) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r2, ', istatus - call stop2(999) - endif - Bundle%ival2(i) = ii+1 - ii=ii+ndim2d - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r2, ', istatus + call stop2(999) + endif + bundle%ival2(i) = ii+1 + ii=ii+ndim2d + enddo endif if (n1d>0) then - do i = 1, n1d - if (Bundle%r1(i)%myKind == r_single) then + do i = 1, n1d + if (bundle%r1(i)%mykind == r_single) then #ifdef _REAL4_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr4 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%r1(i)%q #else - Bundle%r1(i)%qr4 => Bundle%valuesr4(ii+1:ii+ndim1d) + bundle%r1(i)%qr4 => bundle%valuesr4(ii+1:ii+ndim1d) #endif - else if (Bundle%r1(i)%myKind == r_double) then + else if (bundle%r1(i)%mykind == r_double) then #ifdef _REAL8_ - Bundle%r1(i)%q => Bundle%values (ii+1:ii+ndim1d) - Bundle%r1(i)%qr8 => Bundle%r1(i)%q + bundle%r1(i)%q => bundle%values (ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%r1(i)%q #else - Bundle%r1(i)%qr8 => Bundle%valuesr8(ii+1:ii+ndim1d) + bundle%r1(i)%qr8 => bundle%valuesr8(ii+1:ii+ndim1d) #endif - else - istatus = 999 - write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus - call stop2(999) - endif - Bundle%ival1(i) = ii+1 - ii=ii+ndim1d - enddo + else + istatus = 999 + write(6,*) myname_, ':trouble assigining ',trim(name),' r1, ', istatus + call stop2(999) + endif + bundle%ival1(i) = ii+1 + ii=ii+ndim1d + enddo endif if(ii==ntotal) then - Bundle%ndim = ntotal + bundle%ndim = ntotal else istatus=1 write(6,*) myname_, ':trouble allocating ',trim(name),' ivals, ', istatus @@ -1262,14 +1275,14 @@ subroutine create1_ ( Bundle, grid, name, istatus, & endif - Bundle%NumVars=max(0,n1d)+max(0,n2d)+max(0,n3d) - Bundle%n1d=n1d - Bundle%n2d=n2d - Bundle%n3d=n3d + bundle%numvars=max(0,n1d)+max(0,n2d)+max(0,n3d) + bundle%n1d=n1d + bundle%n2d=n2d + bundle%n3d=n3d - if ( redundant_(Bundle) ) then - write(6,*) myname_, ': ',trim(name),' has redundant names, aborting ...' - call stop2(999) + if ( redundant_(bundle) ) then + write(6,*) myname_, ': ',trim(name),' has redundant names, aborting ...' + call stop2(999) endif end subroutine create1_ @@ -1277,24 +1290,24 @@ end subroutine create1_ !BOP ! -! !IROUTINE: Create2_ --- Create new bundle from an existing bundle +! !IROUTINE: create2_ --- Create new bundle from an existing bundle ! ! !INTERFACE: ! - subroutine create2_ ( NewBundle, Bundle, name, istatus ) + subroutine create2_ ( newbundle, bundle, name, istatus ) ! !INPUT PARAMETERS: character(len=*),intent(in) :: name - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle) :: NewBundle + type(gsi_bundle) :: newbundle ! !OUTPUT PARAMETERS: - integer,intent(out)::istatus + integer(i_kind),intent(out)::istatus ! !DESCRIPTION: Create new bundle from another existing bundle. ! @@ -1314,32 +1327,32 @@ subroutine create2_ ( NewBundle, Bundle, name, istatus ) character(len=*),parameter::myname_=myname//'*create2_' integer(i_kind) :: k,n1d,n2d,n3d,this_bundle_kind - character(len=MAXSTR),allocatable::names1d(:),names2d(:),names3d(:) + character(len=maxstr),allocatable::names1d(:),names2d(:),names3d(:) integer(i_kind),allocatable::levels(:) - n1d = max(0,Bundle%n1d) - n2d = max(0,Bundle%n2d) - n3d = max(0,Bundle%n3d) + n1d = max(0,bundle%n1d) + n2d = max(0,bundle%n2d) + n3d = max(0,bundle%n3d) allocate(names1d(n1d)) allocate(names2d(n2d)) allocate(names3d(n3d)) do k=1,n1d - names1d(k)=trim(Bundle%r1(k)%shortname) + names1d(k)=trim(bundle%r1(k)%shortname) enddo do k=1,n2d - names2d(k)=trim(Bundle%r2(k)%shortname) + names2d(k)=trim(bundle%r2(k)%shortname) enddo allocate(levels(n3d)) do k=1,n3d - names3d(k)=trim(Bundle%r3(k)%shortname) - levels(k)=Bundle%r3(k)%level + names3d(k)=trim(bundle%r3(k)%shortname) + levels(k)=bundle%r3(k)%level enddo - this_bundle_kind = Bundle%AllKinds + this_bundle_kind = bundle%allkinds - call create1_ ( NewBundle, Bundle%grid, trim(name), istatus, & + call create1_ ( newbundle, bundle%grid, trim(name), istatus, & names1d=names1d,names2d=names2d,names3d=names3d, & levels=levels, bundle_kind=this_bundle_kind ) @@ -1352,11 +1365,11 @@ end subroutine create2_ !noEOC !BOP ! -! !IROUTINE: Create3_ --- Create new bundle from merge of two existing bundles +! !IROUTINE: create3_ --- Create new bundle from merge of two existing bundles ! ! !INTERFACE: ! - subroutine create3_ ( MergeBundle, Bundle1, Bundle2, Name, istatus ) + subroutine create3_ ( mergebundle, bundle1, bundle2, name, istatus ) ! !INPUT PARAMETERS: @@ -1364,9 +1377,9 @@ subroutine create3_ ( MergeBundle, Bundle1, Bundle2, Name, istatus ) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle) :: Bundle1 ! 1st existing bundle (must be inout) - type(GSI_Bundle) :: Bundle2 ! 2nd existing bundle (must be inout) - type(GSI_Bundle) :: MergeBundle ! newly created merged bundle + type(gsi_bundle) :: bundle1 ! 1st existing bundle (must be inout) + type(gsi_bundle) :: bundle2 ! 2nd existing bundle (must be inout) + type(gsi_bundle) :: mergebundle ! newly created merged bundle ! !OUTPUT PARAMETERS: @@ -1391,78 +1404,78 @@ subroutine create3_ ( MergeBundle, Bundle1, Bundle2, Name, istatus ) character(len=*),parameter::myname_=myname//'*create3_' integer(i_kind) :: i,k,n1d,n2d,n3d,im,jm,km,this_bundle_kind - character(len=MAXSTR),allocatable::names1d(:),names2d(:),names3d(:) + character(len=maxstr),allocatable::names1d(:),names2d(:),names3d(:) integer(i_kind),allocatable::levels(:) - type(GSI_Grid) :: grid + type(gsi_grid) :: grid istatus=0 ! Defining the grid the following way is dangerous ... - im = max(Bundle1%grid%im,Bundle2%grid%im) - jm = max(Bundle1%grid%jm,Bundle2%grid%jm) - km = max(Bundle1%grid%km,Bundle2%grid%km) - call GSI_GridCreate(grid,im,jm,km) - - n1d = max(0,Bundle1%n1d)+max(0,Bundle2%n1d) - n2d = max(0,Bundle1%n2d)+max(0,Bundle2%n2d) - n3d = max(0,Bundle1%n3d)+max(0,Bundle2%n3d) + im = max(bundle1%grid%im,bundle2%grid%im) + jm = max(bundle1%grid%jm,bundle2%grid%jm) + km = max(bundle1%grid%km,bundle2%grid%km) + call gsi_gridcreate(grid,im,jm,km) + + n1d = max(0,bundle1%n1d)+max(0,bundle2%n1d) + n2d = max(0,bundle1%n2d)+max(0,bundle2%n2d) + n3d = max(0,bundle1%n3d)+max(0,bundle2%n3d) allocate(names1d(n1d)) allocate(names2d(n2d)) allocate(names3d(n3d)) allocate(levels(n3d)) i=0 - do k=1,Bundle1%n1d + do k=1,bundle1%n1d i=i+1 - names1d(i)=trim(Bundle1%r1(k)%shortname) + names1d(i)=trim(bundle1%r1(k)%shortname) enddo - do k=1,Bundle2%n1d + do k=1,bundle2%n1d i=i+1 - names1d(i)=trim(Bundle2%r1(k)%shortname) + names1d(i)=trim(bundle2%r1(k)%shortname) enddo i=0 - do k=1,Bundle1%n2d + do k=1,bundle1%n2d i=i+1 - names2d(i)=trim(Bundle1%r2(k)%shortname) + names2d(i)=trim(bundle1%r2(k)%shortname) enddo - do k=1,Bundle2%n2d + do k=1,bundle2%n2d i=i+1 - names2d(i)=trim(Bundle2%r2(k)%shortname) + names2d(i)=trim(bundle2%r2(k)%shortname) enddo i=0 - do k=1,Bundle1%n3d + do k=1,bundle1%n3d i=i+1 - names3d(i)=trim(Bundle1%r3(k)%shortname) - levels (i)=Bundle1%r3(k)%level + names3d(i)=trim(bundle1%r3(k)%shortname) + levels (i)=bundle1%r3(k)%level enddo - do k=1,Bundle2%n3d + do k=1,bundle2%n3d i=i+1 - names3d(i)=trim(Bundle2%r3(k)%shortname) - levels (i)=Bundle2%r3(k)%level + names3d(i)=trim(bundle2%r3(k)%shortname) + levels (i)=bundle2%r3(k)%level enddo - if (Bundle1%AllKinds/=Bundle2%AllKinds) then - print*, 'bundles have diff Kinds: ', Bundle1%AllKinds,Bundle2%AllKinds - write(6,*) myname_, ': not possible to merge bundles, aborting ...' - call stop2(999) + if (bundle1%allkinds/=bundle2%allkinds) then + print*, 'bundles have diff Kinds: ', bundle1%allkinds,bundle2%allkinds + write(6,*) myname_, ': not possible to merge bundles, aborting ...' + call stop2(999) endif - this_bundle_kind = Bundle1%AllKinds + this_bundle_kind = bundle1%allkinds - call create1_ ( MergeBundle, grid, name, istatus, & + call create1_ ( mergebundle, grid, name, istatus, & names1d=names1d, names2d=names2d, names3d=names3d, & levels=levels, bundle_kind=this_bundle_kind ) - if ( redundant_(MergeBundle) ) then - print*, MergeBundle%n1d - print*, MergeBundle%n2d - print*, MergeBundle%n3d - print*, MergeBundle%ndim - print*, MergeBundle%numvars - write(6,*) myname_, ': merge bundle has redundant names, aborting ...' - call stop2(999) + if ( redundant_(mergebundle) ) then + print*, mergebundle%n1d + print*, mergebundle%n2d + print*, mergebundle%n3d + print*, mergebundle%ndim + print*, mergebundle%numvars + write(6,*) myname_, ': merge bundle has redundant names, aborting ...' + call stop2(999) endif deallocate(levels) @@ -1478,13 +1491,13 @@ end subroutine create3_ ! ! !INTERFACE: ! - subroutine dup_ ( Bundi, Bundo, Name, istatus ) + subroutine dup_ ( bundi, bundo, name, istatus ) ! !ARGUMENTS implicit none - type(GSI_Bundle),intent(in ) :: Bundi ! an existing bundle - type(GSI_Bundle),intent(inout) :: Bundo ! the newly created bundle + type(gsi_bundle),intent(in ) :: bundi ! an existing bundle + type(gsi_bundle),intent(inout) :: bundo ! the newly created bundle character(len=*), optional, intent(in ) :: name ! name of the new bundle integer(i_kind) , optional, intent(out) :: istatus ! return status code @@ -1510,21 +1523,21 @@ subroutine dup_ ( Bundi, Bundo, Name, istatus ) if(present(istatus)) istatus=0 if(present(name)) then - call create2_(Bundo,Bundi,name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(name)//'"), istatus =',ier) + call create2_(bundo,bundi,name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(name)//'"), istatus =',ier) else - call create2_(Bundo,Bundi,Bundi%name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(Bundi%name)//'"), istatus =',ier) + call create2_(bundo,bundi,bundi%name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(bundi%name)//'"), istatus =',ier) endif if(ier/=0) then - if(.not.present(istatus)) call die(myname_) - istatus=ier - return + if(.not.present(istatus)) call die(myname_) + istatus=ier + return endif - call copy_(Bundo,Bundi) + call copy_(bundo,bundi) end subroutine dup_ !noEOC @@ -1534,14 +1547,14 @@ end subroutine dup_ ! ! !INTERFACE: ! - subroutine scl_dup_ ( a, Bundi, Bundo, Name, istatus ) + subroutine scl_dup_ ( a, bundi, bundo, name, istatus ) ! !ARGUMENTS implicit none real(r_double), intent(in ) :: a - type(GSI_Bundle),intent(in ) :: Bundi ! an existing bundle - type(GSI_Bundle),intent(out) :: Bundo ! the newly created bundle + type(gsi_bundle),intent(in ) :: bundi ! an existing bundle + type(gsi_bundle),intent(out) :: bundo ! the newly created bundle character(len=*), optional, intent(in ) :: name ! name of the new bundle integer(i_kind) , optional, intent(out) :: istatus ! return status code @@ -1567,13 +1580,13 @@ subroutine scl_dup_ ( a, Bundi, Bundo, Name, istatus ) if(present(istatus)) istatus=0 if(present(name)) then - call create2_(Bundo,Bundi,name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(name)//'"), istatus =',ier) + call create2_(bundo,bundi,name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(name)//'"), istatus =',ier) else - call create2_(Bundo,Bundi,Bundi%name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(Bundi%name)//'"), istatus =',ier) + call create2_(bundo,bundi,bundi%name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(bundi%name)//'"), istatus =',ier) endif if(ier/=0) then if(.not.present(istatus)) call die(myname_) @@ -1581,25 +1594,25 @@ subroutine scl_dup_ ( a, Bundi, Bundo, Name, istatus ) return endif - call gsi_bundleAssign(Bundo,0._r_double) - call gsi_bundleAddmul(Bundo,a,Bundi) + call gsi_bundleassign(bundo,0._r_double) + call gsi_bundleaddmul(bundo,a,bundi) end subroutine scl_dup_ !noEOC !BOP ! -! !IROUTINE: sclR4_dup_ --- duplicate a given bundle +! !IROUTINE: sclr4_dup_ --- duplicate a given bundle ! ! !INTERFACE: ! - subroutine sclR4_dup_ ( a, Bundi, Bundo, Name, istatus ) + subroutine sclr4_dup_ ( a, bundi, bundo, name, istatus ) ! !ARGUMENTS implicit none real(r_single) ,intent(in ) :: a - type(GSI_Bundle),intent(in ) :: Bundi ! an existing bundle - type(GSI_Bundle),intent(out) :: Bundo ! the newly created bundle + type(gsi_bundle),intent(in ) :: bundi ! an existing bundle + type(gsi_bundle),intent(out) :: bundo ! the newly created bundle character(len=*), optional, intent(in ) :: name ! name of the new bundle integer(i_kind) , optional, intent(out) :: istatus ! return status code @@ -1619,19 +1632,19 @@ subroutine sclR4_dup_ ( a, Bundi, Bundo, Name, istatus ) !------------------------------------------------------------------------- !noBOC - character(len=*), parameter:: myname_=myname//'*sclR4_dup_' + character(len=*), parameter:: myname_=myname//'*sclr4_dup_' integer(i_kind):: ier if(present(istatus)) istatus=0 if(present(name)) then - call create2_(Bundo,Bundi,name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(name)//'"), istatus =',ier) + call create2_(bundo,bundi,name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(name)//'"), istatus =',ier) else - call create2_(Bundo,Bundi,Bundi%name,istatus=ier) - if(ier/=0) call perr(myname_, & - 'create2_(name="'//trim(Bundi%name)//'"), istatus =',ier) + call create2_(bundo,bundi,bundi%name,istatus=ier) + if(ier/=0) call perr(myname_, & + 'create2_(name="'//trim(bundi%name)//'"), istatus =',ier) endif if(ier/=0) then if(.not.present(istatus)) call die(myname_) @@ -1639,23 +1652,25 @@ subroutine sclR4_dup_ ( a, Bundi, Bundo, Name, istatus ) return endif - call gsi_bundleAssign(Bundo,0._r_single) - call gsi_bundleAddmul(Bundo,a,Bundi) - end subroutine sclR4_dup_ + call gsi_bundleassign(bundo,0._r_single) + call gsi_bundleaddmul(bundo,a,bundi) + end subroutine sclr4_dup_ !noEOC !............................................................................................ !BOP ! -! !IROUTINE: Get0_ --- Get pointer for a field in bundle +! !IROUTINE: get0_ --- Get pointer for a field in bundle ! ! !INTERFACE: ! - subroutine get0_ ( Bundle, fldname, ipnt, istatus, irank, ival ) - + subroutine get0_ ( bundle, fldname, ipnt, istatus, irank, ival ) + + implicit none + ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname ! required field name ! !OUTPUT PARAMETERS: @@ -1671,8 +1686,8 @@ subroutine get0_ ( Bundle, fldname, ipnt, istatus, irank, ival ) ! !REVISION HISTORY: ! ! 05May2010 Todling Initial code. -! 07Jul2010 Todling Fixed interface (no optionals, per Guo's suggestion) to -! avoid problem found Kokron of referencing undef variables +! 07Jul2010 Todling Fixed interface (no optionals, per guo's suggestion) to +! avoid problem found kokron of referencing undef variables ! !EOP !------------------------------------------------------------------------- @@ -1681,31 +1696,31 @@ subroutine get0_ ( Bundle, fldname, ipnt, istatus, irank, ival ) integer(i_kind) :: i, n1d, n2d, n3d istatus=0 - n1d = Bundle%n1d - n2d = Bundle%n2d - n3d = Bundle%n3d + n1d = bundle%n1d + n2d = bundle%n2d + n3d = bundle%n3d ipnt=-1; irank=-1; ival=-1 do i=1,n1d - if (trim(fldname).eq.trim(Bundle%r1(i)%shortname)) then + if (trim(fldname)==trim(bundle%r1(i)%shortname)) then ipnt=i irank=1 - ival=Bundle%ival1(i) + ival=bundle%ival1(i) return endif enddo do i=1,n2d - if (trim(fldname).eq.trim(Bundle%r2(i)%shortname)) then + if (trim(fldname)==trim(bundle%r2(i)%shortname)) then ipnt=i irank=2 - ival=Bundle%ival2(i) + ival=bundle%ival2(i) return endif enddo do i=1,n3d - if (trim(fldname).eq.trim(Bundle%r3(i)%shortname)) then + if (trim(fldname)==trim(bundle%r3(i)%shortname)) then ipnt=i irank=3 - ival=Bundle%ival3(i) + ival=bundle%ival3(i) return endif enddo @@ -1716,23 +1731,25 @@ end subroutine get0_ !............................................................................................ !BOP ! -! !IROUTINE: Get1_ --- Get pointer for a field in bundle +! !IROUTINE: get1_ --- Get pointer for a field in bundle ! ! !INTERFACE: ! - subroutine get1_ ( Bundle, fldname, ipnt, istatus, irank, ival ) + subroutine get1_ ( bundle, fldname, ipnt, istatus, irank, ival ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname ! required field name ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: ipnt ! actual pointer to individual field integer(i_kind),intent(out) :: istatus ! status error code - integer(i_kind),OPTIONAL,intent(out) :: irank ! field rank (e.g., 1, or 2, or 3) - integer(i_kind),OPTIONAL,intent(out) :: ival ! optional pointer to long vector form + integer(i_kind),optional,intent(out) :: irank ! field rank (e.g., 1, or 2, or 3) + integer(i_kind),optional,intent(out) :: ival ! optional pointer to long vector form ! !DESCRIPTION: Retrieve pointer for required field ! @@ -1750,7 +1767,7 @@ subroutine get1_ ( Bundle, fldname, ipnt, istatus, irank, ival ) integer(i_kind) :: ival_ istatus=0 - call get0_ ( Bundle, fldname, ipnt, istatus, irank_, ival_ ) + call get0_ ( bundle, fldname, ipnt, istatus, irank_, ival_ ) if(present(irank)) then irank=irank_ endif @@ -1763,22 +1780,24 @@ end subroutine get1_ !............................................................................................ !BOP ! -! !IROUTINE: Get2_ --- Get pointers for require fields in bundle +! !IROUTINE: get2_ --- Get pointers for require fields in bundle ! ! !INTERFACE: - subroutine get2_ ( Bundle, fldnames, ipnts, istatus, iranks, ivals ) + subroutine get2_ ( bundle, fldnames, ipnts, istatus, iranks, ivals ) + implicit none + ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldnames(:) ! list with field names ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: ipnts(:) ! actual pointer to individual field integer(i_kind),intent(out) :: istatus ! status error code - integer(i_kind),OPTIONAL,intent(out) :: iranks(:)! fields rank (e.g., 1, or 2, or 3) - integer(i_kind),OPTIONAL,intent(out) :: ivals(:) ! optional pointers to long vector form + integer(i_kind),optional,intent(out) :: iranks(:)! fields rank (e.g., 1, or 2, or 3) + integer(i_kind),optional,intent(out) :: ivals(:) ! optional pointers to long vector form ! !DESCRIPTION: Retrieve pointers for required fields. ! @@ -1800,7 +1819,7 @@ subroutine get2_ ( Bundle, fldnames, ipnts, istatus, iranks, ivals ) nflds = size(fldnames) allocate(iranks_(nflds),ivals_(nflds)) do i=1,nflds - call get0_ ( Bundle, fldnames(i), ipnts(i), istatus, iranks_(i), ivals_(i) ) + call get0_ ( bundle, fldnames(i), ipnts(i), istatus, iranks_(i), ivals_(i) ) enddo if(present(iranks)) then iranks=iranks_ @@ -1815,14 +1834,16 @@ end subroutine get2_ !............................................................................................ !BOP ! -! !IROUTINE: Get31r8_ --- Get pointer to rank-1 field +! !IROUTINE: get31r8_ --- Get pointer to rank-1 field ! ! !INTERFACE: - subroutine get31r8_ ( Bundle, fldname, pntr, istatus ) + subroutine get31r8_ ( bundle, fldname, pntr, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),target,intent(in) :: Bundle ! the Bundle + type(gsi_bundle),target,intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -1836,8 +1857,8 @@ subroutine get31r8_ ( Bundle, fldname, pntr, istatus ) ! !REVISION HISTORY: ! ! 05May2010 Todling Initial code. -! 13May2010 Todling Also return rank-N into rank-1 -! 11Nov2010 Treadon Subtract 1 from upper array bound of Bundle%values +! 13May2010 Todling Also return rank-n into rank-1 +! 11Nov2010 Treadon Subtract 1 from upper array bound of bundle%values ! !EOP !------------------------------------------------------------------------- @@ -1846,24 +1867,24 @@ subroutine get31r8_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt,ival,nsz istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank, ival=ival ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank, ival=ival ) if (istatus==0) then - select case (irank) + select case (irank) case(1) - pntr => Bundle%r1(ipnt)%qr8 + pntr => bundle%r1(ipnt)%qr8 case(2) -! pntr => rerank(Bundle%r2(ipnt)%qr8) - nsz=size(Bundle%r2(ipnt)%qr8) - pntr => Bundle%valuesr8(ival:ival+nsz-1) +! pntr => rerank(bundle%r2(ipnt)%qr8) + nsz=size(bundle%r2(ipnt)%qr8) + pntr => bundle%valuesr8(ival:ival+nsz-1) case(3) -! pntr => rerank(Bundle%r3(ipnt)%qr8) - nsz=size(Bundle%r3(ipnt)%qr8) - pntr => Bundle%valuesr8(ival:ival+nsz-1) +! pntr => rerank(bundle%r3(ipnt)%qr8) + nsz=size(bundle%r3(ipnt)%qr8) + pntr => bundle%valuesr8(ival:ival+nsz-1) case default istatus=1 end select else - istatus=1 + istatus=1 endif end subroutine get31r8_ @@ -1871,14 +1892,14 @@ end subroutine get31r8_ !............................................................................................ !BOP ! -! !IROUTINE: Get31r4_ --- Get pointer to rank-1 field +! !IROUTINE: get31r4_ --- Get pointer to rank-1 field ! ! !INTERFACE: - subroutine get31r4_ ( Bundle, fldname, pntr, istatus ) + subroutine get31r4_ ( bundle, fldname, pntr, istatus ) ! !INPUT PARAMETERS: - type(GSI_Bundle),target,intent(in) :: Bundle ! the Bundle + type(gsi_bundle),target,intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -1892,8 +1913,8 @@ subroutine get31r4_ ( Bundle, fldname, pntr, istatus ) ! !REVISION HISTORY: ! ! 05May2010 Todling Initial code. -! 13May2010 Todling Also return rank-N into rank-1 -! 11Nov2010 Treadon Subtract 1 from upper array bound of Bundle%values +! 13May2010 Todling Also return rank-n into rank-1 +! 11Nov2010 Treadon Subtract 1 from upper array bound of bundle%values ! !EOP !------------------------------------------------------------------------- @@ -1902,37 +1923,39 @@ subroutine get31r4_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt,ival,nsz istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank, ival=ival ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank, ival=ival ) if (istatus==0) then - select case (irank) + select case (irank) case(1) - pntr => Bundle%r1(ipnt)%qr4 + pntr => bundle%r1(ipnt)%qr4 case(2) - nsz=size(Bundle%r2(ipnt)%qr4) - pntr => Bundle%valuesr4(ival:ival+nsz-1) + nsz=size(bundle%r2(ipnt)%qr4) + pntr => bundle%valuesr4(ival:ival+nsz-1) case(3) - nsz=size(Bundle%r3(ipnt)%qr4) - pntr => Bundle%valuesr4(ival:ival+nsz-1) + nsz=size(bundle%r3(ipnt)%qr4) + pntr => bundle%valuesr4(ival:ival+nsz-1) case default istatus=1 end select else - istatus=1 + istatus=1 endif end subroutine get31r4_ !noEOC !BOP ! -! !IROUTINE: Get32r8_ --- Get pointer to rank-2 field +! !IROUTINE: get32r8_ --- Get pointer to rank-2 field ! ! ! !INTERFACE: - subroutine get32r8_ ( Bundle, fldname, pntr, istatus ) + subroutine get32r8_ ( bundle, fldname, pntr, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -1954,26 +1977,28 @@ subroutine get32r8_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if (istatus==0.and.irank==2) then - pntr => Bundle%r2(ipnt)%qr8 + pntr => bundle%r2(ipnt)%qr8 else - istatus=1 + istatus=1 endif end subroutine get32r8_ !noEOC !BOP ! -! !IROUTINE: Get32r4_ --- Get pointer to rank-2 field +! !IROUTINE: get32r4_ --- Get pointer to rank-2 field ! ! ! !INTERFACE: - subroutine get32r4_ ( Bundle, fldname, pntr, istatus ) + subroutine get32r4_ ( bundle, fldname, pntr, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -1995,25 +2020,27 @@ subroutine get32r4_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if (istatus==0.and.irank==2) then - pntr => Bundle%r2(ipnt)%qr4 + pntr => bundle%r2(ipnt)%qr4 else - istatus=1 + istatus=1 endif end subroutine get32r4_ !noEOC !BOP ! -! !IROUTINE: Get33r8_ --- Get pointer to rank-3 field +! !IROUTINE: get33r8_ --- Get pointer to rank-3 field ! ! !INTERFACE: - subroutine get33r8_ ( Bundle, fldname, pntr, istatus ) + subroutine get33r8_ ( bundle, fldname, pntr, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -2035,25 +2062,27 @@ subroutine get33r8_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if (istatus==0.and.irank==3) then - pntr => Bundle%r3(ipnt)%qr8 + pntr => bundle%r3(ipnt)%qr8 else - istatus=1 + istatus=1 endif end subroutine get33r8_ !noEOC !BOP ! -! !IROUTINE: Get33r4_ --- Get pointer to rank-3 field +! !IROUTINE: get33r4_ --- Get pointer to rank-3 field ! ! !INTERFACE: - subroutine get33r4_ ( Bundle, fldname, pntr, istatus ) + subroutine get33r4_ ( bundle, fldname, pntr, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! name of field ! !OUTPUT PARAMETERS: @@ -2075,11 +2104,11 @@ subroutine get33r4_ ( Bundle, fldname, pntr, istatus ) integer(i_kind) :: irank,ipnt istatus=0 - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if (istatus==0.and.irank==3) then - pntr => Bundle%r3(ipnt)%qr4 + pntr => bundle%r3(ipnt)%qr4 else - istatus=1 + istatus=1 endif end subroutine get33r4_ @@ -2087,11 +2116,13 @@ end subroutine get33r4_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar0r8_ --- Set request field to a constant value +! !IROUTINE: putvar0dr8_ --- Set request field to a constant value ! ! !INTERFACE: - subroutine putvar0dr8_ ( Bundle, fldname, cnst, istatus ) + subroutine putvar0dr8_ ( bundle, fldname, cnst, istatus ) + + implicit none ! !INPUT PARAMETERS: @@ -2100,7 +2131,7 @@ subroutine putvar0dr8_ ( Bundle, fldname, cnst, istatus ) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle ! the Bundle + type(gsi_bundle),intent(inout) :: bundle ! the bundle ! !OUTPUT PARAMETERS: @@ -2122,16 +2153,16 @@ subroutine putvar0dr8_ ( Bundle, fldname, cnst, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==1 ) then - Bundle%r1(ipnt)%qr8 = cnst + bundle%r1(ipnt)%qr8 = cnst else if( irank==2 ) then - Bundle%r2(ipnt)%qr8 = cnst + bundle%r2(ipnt)%qr8 = cnst else if( irank==3 ) then - Bundle%r3(ipnt)%qr8 = cnst + bundle%r3(ipnt)%qr8 = cnst endif end subroutine putvar0dr8_ @@ -2139,11 +2170,13 @@ end subroutine putvar0dr8_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar0r4_ --- Set request field to a constant value +! !IROUTINE: putvar0dr4_ --- Set request field to a constant value ! ! !INTERFACE: - subroutine putvar0dr4_ ( Bundle, fldname, cnst, istatus ) + subroutine putvar0dr4_ ( bundle, fldname, cnst, istatus ) + + implicit none ! !INPUT PARAMETERS: @@ -2152,7 +2185,7 @@ subroutine putvar0dr4_ ( Bundle, fldname, cnst, istatus ) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle ! the Bundle + type(gsi_bundle),intent(inout) :: bundle ! the bundle ! !OUTPUT PARAMETERS: @@ -2174,16 +2207,16 @@ subroutine putvar0dr4_ ( Bundle, fldname, cnst, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==1 ) then - Bundle%r1(ipnt)%qr4 = cnst + bundle%r1(ipnt)%qr4 = cnst else if( irank==2 ) then - Bundle%r2(ipnt)%qr4 = cnst + bundle%r2(ipnt)%qr4 = cnst else if( irank==3 ) then - Bundle%r3(ipnt)%qr4 = cnst + bundle%r3(ipnt)%qr4 = cnst endif end subroutine putvar0dr4_ @@ -2191,12 +2224,13 @@ end subroutine putvar0dr4_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar1dr8_ --- Set request field to given input field values; 1d to Nd +! !IROUTINE: putvar1dr8_ --- Set request field to given input field values; 1d to nd ! ! !INTERFACE: - subroutine putvar1dr8_ ( Bundle, fldname, fld, istatus ) + subroutine putvar1dr8_ ( bundle, fldname, fld, istatus ) + implicit none ! !INPUT PARAMETERS: @@ -2205,14 +2239,14 @@ subroutine putvar1dr8_ ( Bundle, fldname, fld, istatus ) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle ! the Bundle + type(gsi_bundle),intent(inout) :: bundle ! the bundle ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Set user-specified field in bundle the given input field. -! rank-1 input to rank-N output. +! rank-1 input to rank-n output. ! ! ! !REMARKS: @@ -2231,20 +2265,20 @@ subroutine putvar1dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank ) if(istatus/=0) return - im=Bundle%grid%im - jm=Bundle%grid%jm - km=Bundle%grid%km + im=bundle%grid%im + jm=bundle%grid%jm + km=bundle%grid%km ! retrieve variable if( irank==1 ) then - Bundle%r1(ipnt)%qr8 = fld + bundle%r1(ipnt)%qr8 = fld else if( irank==2 ) then - Bundle%r2(ipnt)%qr8 = reshape(fld,(/im,jm/)) + bundle%r2(ipnt)%qr8 = reshape(fld,(/im,jm/)) else if( irank==3 ) then - Bundle%r3(ipnt)%qr8 = reshape(fld,(/im,jm,km/)) + bundle%r3(ipnt)%qr8 = reshape(fld,(/im,jm,km/)) endif end subroutine putvar1dr8_ @@ -2252,12 +2286,13 @@ end subroutine putvar1dr8_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar1dr4_ --- Set request field to given input field values; 1d to Nd +! !IROUTINE: putvar1dr4_ --- Set request field to given input field values; 1d to nd ! ! !INTERFACE: - subroutine putvar1dr4_ ( Bundle, fldname, fld, istatus ) + subroutine putvar1dr4_ ( bundle, fldname, fld, istatus ) + implicit none ! !INPUT PARAMETERS: @@ -2266,14 +2301,14 @@ subroutine putvar1dr4_ ( Bundle, fldname, fld, istatus ) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle ! the Bundle + type(gsi_bundle),intent(inout) :: bundle ! the bundle ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Set user-specified field in bundle the given input field. -! rank-1 input to rank-N output. +! rank-1 input to rank-n output. ! ! ! !REMARKS: @@ -2292,22 +2327,22 @@ subroutine putvar1dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank ) if(istatus/=0) return - im=Bundle%grid%im - jm=Bundle%grid%jm - km=Bundle%grid%km + im=bundle%grid%im + jm=bundle%grid%jm + km=bundle%grid%km ! retrieve variable if( irank==1 ) then - Bundle%r1(ipnt)%qr4 = fld + bundle%r1(ipnt)%qr4 = fld endif if( irank==2 ) then - Bundle%r2(ipnt)%qr4 = reshape(fld,(/im,jm/)) + bundle%r2(ipnt)%qr4 = reshape(fld,(/im,jm/)) endif if( irank==3 ) then - Bundle%r3(ipnt)%qr4 = reshape(fld,(/im,jm,km/)) + bundle%r3(ipnt)%qr4 = reshape(fld,(/im,jm,km/)) endif end subroutine putvar1dr4_ @@ -2315,17 +2350,19 @@ end subroutine putvar1dr4_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar2dr8_ --- Set request field to given input field values; 2d to 2d +! !IROUTINE: putvar2dr8_ --- Set request field to given input field values; 2d to 2d ! ! !INTERFACE: - subroutine putvar2dr8_ ( Bundle, fldname, fld, istatus ) + subroutine putvar2dr8_ ( bundle, fldname, fld, istatus ) + implicit none + ! !INPUT PARAMETERS: character(len=*),intent(in) :: fldname real(r_double), intent(in) :: fld(:,:) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus @@ -2347,29 +2384,31 @@ subroutine putvar2dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==2 ) then - Bundle%r2(ipnt)%qr8 = fld + bundle%r2(ipnt)%qr8 = fld endif end subroutine putvar2dr8_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar2dr4_ --- Set request field to given input field values; 2d to 2d +! !IROUTINE: putvar2dr4_ --- Set request field to given input field values; 2d to 2d ! ! !INTERFACE: - subroutine putvar2dr4_ ( Bundle, fldname, fld, istatus ) + subroutine putvar2dr4_ ( bundle, fldname, fld, istatus ) + + implicit none ! !INPUT PARAMETERS: character(len=*),intent(in) :: fldname real(r_single), intent(in) :: fld(:,:) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus @@ -2391,35 +2430,37 @@ subroutine putvar2dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==2 ) then - Bundle%r2(ipnt)%qr4 = fld + bundle%r2(ipnt)%qr4 = fld endif end subroutine putvar2dr4_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar2dp1r8_ --- Set request field to given input field values; 2d to 2d +! !IROUTINE: putvar2dp1r8_ --- Set request field to given input field values; 2d to 2d ! ! !INTERFACE: - subroutine putvar2dp1r8_ ( Bundle, fldname, fld, istatus ) + subroutine putvar2dp1r8_ ( bundle, fldname, fld, istatus ) + + implicit none ! !INPUT PARAMETERS: character(len=*),intent(in) :: fldname real(r_double), intent(in) :: fld(:,:,:) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle(:) + type(gsi_bundle),intent(inout) :: bundle(:) ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus ! !DESCRIPTION: Set user-specified field in bundle the given input field. -! 2d-input to 2d output, for each instance of Bundle. +! 2d-input to 2d output, for each instance of bundle. ! ! ! !REVISION HISTORY: @@ -2433,19 +2474,19 @@ subroutine putvar2dp1r8_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt -! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) - if(istatus/=0) return +! get pointer to desired variable + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) + if(istatus/=0) return -! retrieve variable - if( irank==2 ) then - Bundle(ii)%r2(ipnt)%qr8 = fld(:,:,ii) - endif +! retrieve variable + if( irank==2 ) then + bundle(ii)%r2(ipnt)%qr8 = fld(:,:,ii) + endif enddo @@ -2453,23 +2494,25 @@ end subroutine putvar2dp1r8_ !............................................................................................ !BOP ! -! !IROUTINE: PutVar2dp1r4_ --- Set request field to given input field values; 2d to 2d +! !IROUTINE: putvar2dp1r4_ --- Set request field to given input field values; 2d to 2d ! ! !INTERFACE: - subroutine putvar2dp1r4_ ( Bundle, fldname, fld, istatus ) + subroutine putvar2dp1r4_ ( bundle, fldname, fld, istatus ) + + implicit none ! !INPUT PARAMETERS: character(len=*),intent(in) :: fldname real(r_single), intent(in) :: fld(:,:,:) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle(:) + type(gsi_bundle),intent(inout) :: bundle(:) ! !OUTPUT PARAMETERS: integer(i_kind),intent(out) :: istatus ! !DESCRIPTION: Set user-specified field in bundle the given input field. -! 2d-input to 2d output, for each instance of Bundle. +! 2d-input to 2d output, for each instance of bundle. ! ! ! !REVISION HISTORY: @@ -2483,27 +2526,29 @@ subroutine putvar2dp1r4_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==2 ) then - Bundle(ii)%r2(ipnt)%qr4 = fld(:,:,ii) + bundle(ii)%r2(ipnt)%qr4 = fld(:,:,ii) endif enddo end subroutine putvar2dp1r4_ - subroutine putvar3dr8_ ( Bundle, fldname, fld, istatus ) + subroutine putvar3dr8_ ( bundle, fldname, fld, istatus ) + + implicit none ! This routine also allows putting a 1d-array into a 2d-/3d-array - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle character(len=*),intent(in) :: fldname real(r_double), intent(in) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2513,19 +2558,21 @@ subroutine putvar3dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==3 ) then - Bundle%r3(ipnt)%qr8 = fld + bundle%r3(ipnt)%qr8 = fld endif end subroutine putvar3dr8_ - subroutine putvar3dr4_ ( Bundle, fldname, fld, istatus ) + subroutine putvar3dr4_ ( bundle, fldname, fld, istatus ) + + implicit none ! This routine also allows putting a 1d-array into a 2d-/3d-array - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle character(len=*),intent(in) :: fldname real(r_single), intent(in) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2535,19 +2582,21 @@ subroutine putvar3dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==3 ) then - Bundle%r3(ipnt)%qr4 = fld + bundle%r3(ipnt)%qr4 = fld endif end subroutine putvar3dr4_ - subroutine putvar3dp1r8_ ( Bundle, fldname, fld, istatus ) + subroutine putvar3dp1r8_ ( bundle, fldname, fld, istatus ) + + implicit none ! This routine also allows putting a 1d-array into a 2d-/3d-array+1 - type(GSI_Bundle),intent(inout) :: Bundle(:) + type(gsi_bundle),intent(inout) :: bundle(:) character(len=*),intent(in) :: fldname real(r_double), intent(in) :: fld(:,:,:,:) integer(i_kind),intent(out) :: istatus @@ -2555,27 +2604,29 @@ subroutine putvar3dp1r8_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==3 ) then - Bundle(ii)%r3(ipnt)%qr8 = fld(:,:,:,ii) + bundle(ii)%r3(ipnt)%qr8 = fld(:,:,:,ii) endif enddo end subroutine putvar3dp1r8_ - subroutine putvar3dp1r4_ ( Bundle, fldname, fld, istatus ) + subroutine putvar3dp1r4_ ( bundle, fldname, fld, istatus ) + + implicit none ! This routine also allows putting a 1d-array into a 2d-/3d-array+1 - type(GSI_Bundle),intent(inout) :: Bundle(:) + type(gsi_bundle),intent(inout) :: bundle(:) character(len=*),intent(in) :: fldname real(r_single), intent(in) :: fld(:,:,:,:) integer(i_kind),intent(out) :: istatus @@ -2583,18 +2634,18 @@ subroutine putvar3dp1r4_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable if( irank==3 ) then - Bundle(ii)%r3(ipnt)%qr4 = fld(:,:,:,ii) + bundle(ii)%r3(ipnt)%qr4 = fld(:,:,:,ii) endif enddo @@ -2604,15 +2655,17 @@ end subroutine putvar3dp1r4_ !............................................................................................ !BOP ! -! !IROUTINE: GetVar1dr8_ --- Retrieve request field from bundle; Nd to 1d +! !IROUTINE: getvar1dr8_ --- Retrieve request field from bundle; nd to 1d ! ! !INTERFACE: - subroutine getvar1dr8_ ( Bundle, fldname, fld, istatus ) + subroutine getvar1dr8_ ( bundle, fldname, fld, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! request field name ! !INPUT/OUTPUT PARAMETERS: @@ -2622,7 +2675,7 @@ subroutine getvar1dr8_ ( Bundle, fldname, fld, istatus ) integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve request field from bundle and return as 1d-array. -! Nd-input to 1d output. +! nd-input to 1d output. ! ! ! !REMARKS: @@ -2642,36 +2695,38 @@ subroutine getvar1dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable select case (irank) - case(1) - fld = Bundle%r1(ipnt)%qr8 - case(2) - n=size(Bundle%r2(ipnt)%qr8) - fld = reshape(Bundle%r2(ipnt)%qr8,(/n/)) - case(3) - n=size(Bundle%r3(ipnt)%qr8) - fld = reshape(Bundle%r3(ipnt)%qr8,(/n/)) - case default - istatus=1 + case(1) + fld = bundle%r1(ipnt)%qr8 + case(2) + n=size(bundle%r2(ipnt)%qr8) + fld = reshape(bundle%r2(ipnt)%qr8,(/n/)) + case(3) + n=size(bundle%r3(ipnt)%qr8) + fld = reshape(bundle%r3(ipnt)%qr8,(/n/)) + case default + istatus=1 end select end subroutine getvar1dr8_ !............................................................................................ !BOP ! -! !IROUTINE: GetVar1dr4_ --- Retrieve request field from bundle; Nd to 1d +! !IROUTINE: getvar1dr4_ --- Retrieve request field from bundle; nd to 1d ! ! !INTERFACE: - subroutine getvar1dr4_ ( Bundle, fldname, fld, istatus ) + subroutine getvar1dr4_ ( bundle, fldname, fld, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: fldname ! request field name ! !INPUT/OUTPUT PARAMETERS: @@ -2681,7 +2736,7 @@ subroutine getvar1dr4_ ( Bundle, fldname, fld, istatus ) integer(i_kind),intent(out) :: istatus ! status error code ! !DESCRIPTION: Retrieve request field from bundle and return as 1d-array. -! Nd-input to 1d output. +! nd-input to 1d output. ! ! ! !REMARKS: @@ -2701,27 +2756,29 @@ subroutine getvar1dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable select case (irank) - case(1) - fld = Bundle%r1(ipnt)%qr4 - case(2) - n=size(Bundle%r2(ipnt)%qr4) - fld = reshape(Bundle%r2(ipnt)%qr4,(/n/)) - case(3) - n=size(Bundle%r3(ipnt)%qr4) - fld = reshape(Bundle%r3(ipnt)%qr4,(/n/)) - case default - istatus=1 + case(1) + fld = bundle%r1(ipnt)%qr4 + case(2) + n=size(bundle%r2(ipnt)%qr4) + fld = reshape(bundle%r2(ipnt)%qr4,(/n/)) + case(3) + n=size(bundle%r3(ipnt)%qr4) + fld = reshape(bundle%r3(ipnt)%qr4,(/n/)) + case default + istatus=1 end select end subroutine getvar1dr4_ - subroutine getvar2dr8_ ( Bundle, fldname, fld, istatus ) + subroutine getvar2dr8_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname real(r_double),intent(inout) :: fld(:,:) integer(i_kind),intent(out) :: istatus @@ -2731,16 +2788,18 @@ subroutine getvar2dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable - fld = Bundle%r2(ipnt)%qr8 + fld = bundle%r2(ipnt)%qr8 end subroutine getvar2dr8_ - subroutine getvar2dr4_ ( Bundle, fldname, fld, istatus ) + subroutine getvar2dr4_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname real(r_single), intent(inout) :: fld(:,:) integer(i_kind),intent(out) :: istatus @@ -2750,16 +2809,18 @@ subroutine getvar2dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable - fld = Bundle%r2(ipnt)%qr4 + fld = bundle%r2(ipnt)%qr4 end subroutine getvar2dr4_ - subroutine getvar2dp1r8_ ( Bundle, fldname, fld, istatus ) + subroutine getvar2dp1r8_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle(:) + type(gsi_bundle),intent(in) :: bundle(:) character(len=*),intent(in) :: fldname real(r_double),intent(inout) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2767,24 +2828,26 @@ subroutine getvar2dp1r8_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable - fld(:,:,ii) = Bundle(ii)%r2(ipnt)%qr8 + fld(:,:,ii) = bundle(ii)%r2(ipnt)%qr8 enddo end subroutine getvar2dp1r8_ - subroutine getvar2dp1r4_ ( Bundle, fldname, fld, istatus ) + subroutine getvar2dp1r4_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle(:) + type(gsi_bundle),intent(in) :: bundle(:) character(len=*),intent(in) :: fldname real(r_single), intent(inout) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2792,23 +2855,25 @@ subroutine getvar2dp1r4_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank=irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank=irank ) if(istatus/=0) return ! retrieve variable - fld(:,:,ii) = Bundle(ii)%r2(ipnt)%qr4 + fld(:,:,ii) = bundle(ii)%r2(ipnt)%qr4 enddo end subroutine getvar2dp1r4_ - subroutine getvar3dr8_ ( Bundle, fldname, fld, istatus ) + subroutine getvar3dr8_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname real(r_double),intent(inout) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2818,16 +2883,18 @@ subroutine getvar3dr8_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank ) if(istatus/=0) return ! retrieve variable - fld = Bundle%r3(ipnt)%qr8 + fld = bundle%r3(ipnt)%qr8 end subroutine getvar3dr8_ - subroutine getvar3dr4_ ( Bundle, fldname, fld, istatus ) + subroutine getvar3dr4_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle + type(gsi_bundle),intent(in) :: bundle character(len=*),intent(in) :: fldname real(r_single), intent(inout) :: fld(:,:,:) integer(i_kind),intent(out) :: istatus @@ -2837,16 +2904,18 @@ subroutine getvar3dr4_ ( Bundle, fldname, fld, istatus ) istatus=0 ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle, fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle, fldname, ipnt, istatus, irank ) if(istatus/=0) return ! retrieve variable - fld = Bundle%r3(ipnt)%qr4 + fld = bundle%r3(ipnt)%qr4 end subroutine getvar3dr4_ - subroutine getvar3dp1r8_ ( Bundle, fldname, fld, istatus ) + subroutine getvar3dp1r8_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle(:) + type(gsi_bundle),intent(in) :: bundle(:) character(len=*),intent(in) :: fldname real(r_double),intent(inout) :: fld(:,:,:,:) integer(i_kind),intent(out) :: istatus @@ -2854,24 +2923,26 @@ subroutine getvar3dp1r8_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt = size(Bundle) + nt = size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank ) if(istatus/=0) return ! retrieve variable - fld(:,:,:,ii) = Bundle(ii)%r3(ipnt)%qr8 + fld(:,:,:,ii) = bundle(ii)%r3(ipnt)%qr8 enddo end subroutine getvar3dp1r8_ - subroutine getvar3dp1r4_ ( Bundle, fldname, fld, istatus ) + subroutine getvar3dp1r4_ ( bundle, fldname, fld, istatus ) + + implicit none - type(GSI_Bundle),intent(in) :: Bundle(:) + type(gsi_bundle),intent(in) :: bundle(:) character(len=*),intent(in) :: fldname real(r_single), intent(inout) :: fld(:,:,:,:) integer(i_kind),intent(out) :: istatus @@ -2879,17 +2950,17 @@ subroutine getvar3dp1r4_ ( Bundle, fldname, fld, istatus ) integer(i_kind) :: irank,ipnt,ii,nt istatus=0 - nt=size(Bundle) + nt=size(bundle) ! loop over bundle instances do ii=1,nt ! get pointer to desired variable - call GSI_BundleGetPointer ( Bundle(ii), fldname, ipnt, istatus, irank ) + call gsi_bundlegetpointer ( bundle(ii), fldname, ipnt, istatus, irank ) if(istatus/=0) return ! retrieve variable - fld(:,:,:,ii) = Bundle(ii)%r3(ipnt)%qr4 + fld(:,:,:,ii) = bundle(ii)%r3(ipnt)%qr4 enddo @@ -2898,15 +2969,17 @@ end subroutine getvar3dp1r4_ !............................................................................................ !BOP ! -! !IROUTINE: Inquire_Char_ --- Inquire about character-type meta-data +! !IROUTINE: inquire_char_ --- Inquire about character-type meta-data ! ! !INTERFACE: - subroutine inquire_char_ ( Bundle, what, vars, istatus ) + subroutine inquire_char_ ( bundle, what, vars, istatus ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle),intent(in) :: Bundle ! the Bundle + type(gsi_bundle),intent(in) :: bundle ! the bundle character(len=*),intent(in) :: what ! type of inquire (shortname,longname,etc) ! !OUTPUT PARAMETERS: @@ -2929,80 +3002,80 @@ subroutine inquire_char_ ( Bundle, what, vars, istatus ) integer(i_kind) :: i,ii -! if(size(vars)0) then is=1 - ie=max(0,Bundle1%n1d) + ie=max(0,bundle1%n1d) if (ie>0) then - allocate(idi(Bundle1%n1d),ido(Bundle1%n1d)) - idi=(/(i,i=1,Bundle1%n1d)/) + allocate(idi(bundle1%n1d),ido(bundle1%n1d)) + idi=(/(i,i=1,bundle1%n1d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle1%r1(:),MergeBundle%r1(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle1%r1(:),mergebundle%r1(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif is=ie+1 ie=n1d if (ie>=is) then - allocate(idi(Bundle2%n1d),ido(Bundle2%n1d)) - idi=(/(i,i=1,Bundle2%n1d)/) + allocate(idi(bundle2%n1d),ido(bundle2%n1d)) + idi=(/(i,i=1,bundle2%n1d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle2%r1(:),MergeBundle%r1(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle2%r1(:),mergebundle%r1(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif endif @@ -3084,23 +3159,23 @@ subroutine merge_ ( MergeBundle, Bundle1, Bundle2, NewName, istatus ) ! Handle 2d-part of bundles if(n2d>0) then is=1 - ie=max(0,Bundle1%n2d) + ie=max(0,bundle1%n2d) if (ie>0) then - allocate(idi(Bundle1%n2d),ido(Bundle1%n2d)) - idi=(/(i,i=1,Bundle1%n2d)/) + allocate(idi(bundle1%n2d),ido(bundle1%n2d)) + idi=(/(i,i=1,bundle1%n2d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle1%r2(:),MergeBundle%r2(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle1%r2(:),mergebundle%r2(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif is=ie+1 ie=n2d if (ie>=is) then - allocate(idi(Bundle2%n2d),ido(Bundle2%n2d)) - idi=(/(i,i=1,Bundle2%n2d)/) + allocate(idi(bundle2%n2d),ido(bundle2%n2d)) + idi=(/(i,i=1,bundle2%n2d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle2%r2(:),MergeBundle%r2(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle2%r2(:),mergebundle%r2(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif endif @@ -3108,23 +3183,23 @@ subroutine merge_ ( MergeBundle, Bundle1, Bundle2, NewName, istatus ) ! Handle 3d-part of bundles if(n3d>0) then is=1 - ie=max(0,Bundle1%n3d) + ie=max(0,bundle1%n3d) if (ie>0) then - allocate(idi(Bundle1%n3d),ido(Bundle1%n3d)) - idi=(/(i,i=1,Bundle1%n3d)/) + allocate(idi(bundle1%n3d),ido(bundle1%n3d)) + idi=(/(i,i=1,bundle1%n3d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle1%r3(:),MergeBundle%r3(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle1%r3(:),mergebundle%r3(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif is=ie+1 ie=n3d if (ie>=is) then - allocate(idi(Bundle2%n3d),ido(Bundle2%n3d)) - idi=(/(i,i=1,Bundle2%n3d)/) + allocate(idi(bundle2%n3d),ido(bundle2%n3d)) + idi=(/(i,i=1,bundle2%n3d)/) ido=(/(i,i=is,ie)/) - call copy_item_ (idi,ido,Bundle2%r3(:),MergeBundle%r3(:),istatus) - if(istatus/=0)return + call copy_item_ (idi,ido,bundle2%r3(:),mergebundle%r3(:),istatus) + if(istatus/=0)return deallocate(idi,ido) endif endif @@ -3135,11 +3210,11 @@ end subroutine merge_ !............................................................................................ !BOP ! -! !IROUTINE: Copy_ --- Copy one Bundle into another +! !IROUTINE: copy_ --- Copy one bundle into another ! ! !INTERFACE: - subroutine copy_(Bundo,Bundi) + subroutine copy_(bundo,bundi) ! !USES: @@ -3147,11 +3222,11 @@ subroutine copy_(Bundo,Bundi) ! !INPUT PARAMETERS: - type(GSI_Bundle), intent(in ) :: bundi + type(gsi_bundle), intent(in ) :: bundi ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle), intent(inout) :: bundo + type(gsi_bundle), intent(inout) :: bundo ! !DESCRIPTION: Copy contents of one bundle into another. ! @@ -3181,8 +3256,8 @@ subroutine copy_(Bundo,Bundi) bundi%n3d,bundo%n3d call stop2(999) end if - if (bundi%AllKinds<0 .or. bundo%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',bundi%AllKinds,bundo%AllKinds + if (bundi%allkinds<0 .or. bundo%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',bundi%allkinds,bundo%allkinds call stop2(999) endif @@ -3212,7 +3287,7 @@ subroutine copy_(Bundo,Bundi) enddo endif - if (bundo%AllKinds==r_single) then + if (bundo%allkinds==r_single) then !$omp parallel do do ii=1,bundo%ndim #ifdef _REAL4_ @@ -3222,7 +3297,7 @@ subroutine copy_(Bundo,Bundi) #endif enddo !$omp end parallel do - else if (bundo%AllKinds==r_double) then + else if (bundo%allkinds==r_double) then !$omp parallel do do ii=1,bundo%ndim #ifdef _REAL8_ @@ -3250,11 +3325,11 @@ end subroutine copy_ !............................................................................................ !BOP ! -! !IROUTINE: AssignR8_Const_ --- Assign values of bundle to a give constant +! !IROUTINE: assignr8_const_ --- Assign values of bundle to a give constant ! ! !INTERFACE: - subroutine assignR8_const_(Bundo,cnst) + subroutine assignr8_const_(bundo,cnst) ! !USES: @@ -3266,7 +3341,7 @@ subroutine assignR8_const_(Bundo,cnst) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle), intent(inout) :: bundo + type(gsi_bundle), intent(inout) :: bundo ! !DESCRIPTION: Assign values of bundle to a constant ! @@ -3280,11 +3355,11 @@ subroutine assignR8_const_(Bundo,cnst) !------------------------------------------------------------------------- !noBOC - character(len=*),parameter::myname_='assignR8_const_' + character(len=*),parameter::myname_='assignr8_const_' integer(i_kind) :: ii - if (bundo%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',bundo%AllKinds + if (bundo%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',bundo%allkinds call stop2(999) endif @@ -3295,16 +3370,16 @@ subroutine assignR8_const_(Bundo,cnst) !$omp end parallel do return - end subroutine assignR8_const_ + end subroutine assignr8_const_ !noEOC !............................................................................................ !BOP ! -! !IROUTINE: AssignR4_Const_ --- Assign values of bundle to a give constant +! !IROUTINE: assignr4_const_ --- Assign values of bundle to a give constant ! ! !INTERFACE: - subroutine assignR4_const_(Bundo,cnst) + subroutine assignr4_const_(bundo,cnst) ! !USES: @@ -3316,7 +3391,7 @@ subroutine assignR4_const_(Bundo,cnst) ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle), intent(inout) :: bundo + type(gsi_bundle), intent(inout) :: bundo ! !DESCRIPTION: Assign values of bundle to a constant ! @@ -3330,11 +3405,11 @@ subroutine assignR4_const_(Bundo,cnst) !------------------------------------------------------------------------- !noBOC - character(len=*),parameter::myname_='assignR4_const_' + character(len=*),parameter::myname_='assignr4_const_' integer(i_kind) :: ii - if (bundo%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',bundo%AllKinds + if (bundo%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',bundo%allkinds call stop2(999) endif @@ -3345,7 +3420,7 @@ subroutine assignR4_const_(Bundo,cnst) !$omp end parallel do return - end subroutine assignR4_const_ + end subroutine assignr4_const_ !noEOC subroutine hadamard_upd_(zst,yst,xst) !$$$ subprogram documentation block @@ -3384,59 +3459,59 @@ subroutine hadamard_upd_(zst,yst,xst) call stop2(313) endif - if (zst%AllKinds<0.or.xst%AllKinds<0.or.yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',zst%AllKinds,xst%AllKinds,yst%AllKinds + if (zst%allkinds<0.or.xst%allkinds<0.or.yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',zst%allkinds,xst%allkinds,yst%allkinds call stop2(999) endif - if(zst%AllKinds==r_single .and. & - xst%AllKinds==r_single .and. & - yst%AllKinds==r_single ) then - DO ii=1,zst%ndim - zst%valuesR4(ii)=zst%valuesR4(ii) + xst%valuesR4(ii)*yst%valuesR4(ii) - ENDDO + if(zst%allkinds==r_single .and. & + xst%allkinds==r_single .and. & + yst%allkinds==r_single ) then + do ii=1,zst%ndim + zst%valuesr4(ii)=zst%valuesr4(ii) + xst%valuesr4(ii)*yst%valuesr4(ii) + enddo endif - if(zst%AllKinds==r_double .and. & - xst%AllKinds==r_double .and. & - yst%AllKinds==r_double ) then - DO ii=1,zst%ndim - zst%valuesR8(ii)=zst%valuesR8(ii) + xst%valuesR8(ii)*yst%valuesR8(ii) - ENDDO + if(zst%allkinds==r_double .and. & + xst%allkinds==r_double .and. & + yst%allkinds==r_double ) then + do ii=1,zst%ndim + zst%valuesr8(ii)=zst%valuesr8(ii) + xst%valuesr8(ii)*yst%valuesr8(ii) + enddo endif - if(zst%AllKinds==r_single .and. & - xst%AllKinds==r_double .and. & - yst%AllKinds==r_double ) then - DO ii=1,zst%ndim - zst%valuesR4(ii)=zst%valuesR4(ii) + xst%valuesR8(ii)*yst%valuesR8(ii) - ENDDO + if(zst%allkinds==r_single .and. & + xst%allkinds==r_double .and. & + yst%allkinds==r_double ) then + do ii=1,zst%ndim + zst%valuesr4(ii)=zst%valuesr4(ii) + xst%valuesr8(ii)*yst%valuesr8(ii) + enddo endif - if(zst%AllKinds==r_double .and. & - xst%AllKinds==r_single .and. & - yst%AllKinds==r_double ) then - DO ii=1,zst%ndim - zst%valuesR8(ii)=zst%valuesR8(ii) + xst%valuesR4(ii)*yst%valuesR8(ii) - ENDDO + if(zst%allkinds==r_double .and. & + xst%allkinds==r_single .and. & + yst%allkinds==r_double ) then + do ii=1,zst%ndim + zst%valuesr8(ii)=zst%valuesr8(ii) + xst%valuesr4(ii)*yst%valuesr8(ii) + enddo endif - if(zst%AllKinds==r_double .and. & - xst%AllKinds==r_double .and. & - yst%AllKinds==r_single ) then - DO ii=1,zst%ndim - zst%valuesR8(ii)=zst%valuesR8(ii) + xst%valuesR8(ii)*yst%valuesR4(ii) - ENDDO + if(zst%allkinds==r_double .and. & + xst%allkinds==r_double .and. & + yst%allkinds==r_single ) then + do ii=1,zst%ndim + zst%valuesr8(ii)=zst%valuesr8(ii) + xst%valuesr8(ii)*yst%valuesr4(ii) + enddo endif - if(zst%AllKinds==r_single .and. & - xst%AllKinds==r_single .and. & - yst%AllKinds==r_double ) then - DO ii=1,zst%ndim - zst%valuesR4(ii)=zst%valuesR4(ii) + xst%valuesR4(ii)*yst%valuesR8(ii) - ENDDO + if(zst%allkinds==r_single .and. & + xst%allkinds==r_single .and. & + yst%allkinds==r_double ) then + do ii=1,zst%ndim + zst%valuesr4(ii)=zst%valuesr4(ii) + xst%valuesr4(ii)*yst%valuesr8(ii) + enddo endif - if(zst%AllKinds==r_single .and. & - xst%AllKinds==r_double .and. & - yst%AllKinds==r_single ) then - DO ii=1,zst%ndim - zst%valuesR4(ii)=zst%valuesR4(ii) + xst%valuesR8(ii)*yst%valuesR4(ii) - ENDDO + if(zst%allkinds==r_single .and. & + xst%allkinds==r_double .and. & + yst%allkinds==r_single ) then + do ii=1,zst%ndim + zst%valuesr4(ii)=zst%valuesr4(ii) + xst%valuesr8(ii)*yst%valuesr4(ii) + enddo endif return @@ -3476,40 +3551,40 @@ subroutine self_add_st(yst,xst) write(6,*)trim(myname_),': error length' call stop2(313) endif - if (xst%AllKinds<0.or.yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',xst%AllKinds,yst%AllKinds + if (xst%allkinds<0.or.yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',xst%allkinds,yst%allkinds call stop2(999) endif - if(xst%AllKinds==r_double)then - if(yst%AllKinds==r_double)then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+xst%valuesR8(ii) - ENDDO - else if(yst%AllKinds==r_single)then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+xst%valuesR8(ii) - ENDDO + if(xst%allkinds==r_double)then + if(yst%allkinds==r_double)then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+xst%valuesr8(ii) + enddo + else if(yst%allkinds==r_single)then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+xst%valuesr8(ii) + enddo endif - else if(xst%AllKinds==r_single)then - if(yst%AllKinds==r_double )then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+xst%valuesR4(ii) - ENDDO - else if(yst%AllKinds==r_single)then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+xst%valuesR4(ii) - ENDDO + else if(xst%allkinds==r_single)then + if(yst%allkinds==r_double )then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+xst%valuesr4(ii) + enddo + else if(yst%allkinds==r_single)then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+xst%valuesr4(ii) + enddo endif end if return end subroutine self_add_st ! ---------------------------------------------------------------------- -subroutine self_add_R8scal(yst,pa,xst) +subroutine self_add_r8scal(yst,pa,xst) !$$$ subprogram documentation block ! . . . . -! subprogram: self_add_scal +! subprogram: self_add_r8scal ! prgmmr: ! ! abstract: @@ -3535,47 +3610,47 @@ subroutine self_add_R8scal(yst,pa,xst) type(gsi_bundle), intent(inout) :: yst real(r_double), intent(in ) :: pa type(gsi_bundle), intent(in ) :: xst - character(len=*),parameter::myname_='self_add_R8scal_' + character(len=*),parameter::myname_='self_add_r8scal_' integer(i_kind) :: ii if(yst%ndim/=xst%ndim) then write(6,*)trim(myname_),': error length' call stop2(313) endif - if (xst%AllKinds<0.or.yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',xst%AllKinds,yst%AllKinds + if (xst%allkinds<0.or.yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',xst%allkinds,yst%allkinds call stop2(999) endif - if(xst%AllKinds==r_double ) then - if(yst%AllKinds==r_double )then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+pa*xst%valuesR8(ii) - ENDDO - else if(yst%AllKinds==r_single) then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+pa*xst%valuesR8(ii) - ENDDO + if(xst%allkinds==r_double ) then + if(yst%allkinds==r_double )then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+pa*xst%valuesr8(ii) + enddo + else if(yst%allkinds==r_single) then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+pa*xst%valuesr8(ii) + enddo endif - else if(xst%AllKinds==r_single ) then - if(yst%AllKinds==r_double) then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+pa*xst%valuesR4(ii) - ENDDO - else if(yst%AllKinds==r_single)then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+pa*xst%valuesR4(ii) - ENDDO + else if(xst%allkinds==r_single ) then + if(yst%allkinds==r_double) then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+pa*xst%valuesr4(ii) + enddo + else if(yst%allkinds==r_single)then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+pa*xst%valuesr4(ii) + enddo end if endif return -end subroutine self_add_R8scal +end subroutine self_add_r8scal ! ---------------------------------------------------------------------- -subroutine self_add_R4scal(yst,pa,xst) +subroutine self_add_r4scal(yst,pa,xst) !$$$ subprogram documentation block ! . . . . -! subprogram: self_add_scal +! subprogram: self_add_r4scal ! prgmmr: ! ! abstract: @@ -3601,93 +3676,93 @@ subroutine self_add_R4scal(yst,pa,xst) type(gsi_bundle), intent(inout) :: yst real(r_single), intent(in ) :: pa type(gsi_bundle), intent(in ) :: xst - character(len=*),parameter::myname_='self_add_R4scal_' + character(len=*),parameter::myname_='self_add_r4scal_' integer(i_kind) :: ii if(yst%ndim/=xst%ndim) then write(6,*)trim(myname_),': error length' call stop2(313) endif - if (xst%AllKinds<0.or.yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',xst%AllKinds,yst%AllKinds + if (xst%allkinds<0.or.yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',xst%allkinds,yst%allkinds call stop2(999) endif - if(xst%AllKinds==r_double ) then - if(yst%AllKinds==r_double )then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+pa*xst%valuesR8(ii) - ENDDO - else if(yst%AllKinds==r_single) then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+pa*xst%valuesR8(ii) - ENDDO + if(xst%allkinds==r_double ) then + if(yst%allkinds==r_double )then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+pa*xst%valuesr8(ii) + enddo + else if(yst%allkinds==r_single) then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+pa*xst%valuesr8(ii) + enddo endif - else if(xst%AllKinds==r_single ) then - if(yst%AllKinds==r_double) then - DO ii=1,yst%ndim - yst%valuesR8(ii)=yst%valuesR8(ii)+pa*xst%valuesR4(ii) - ENDDO - else if(yst%AllKinds==r_single)then - DO ii=1,yst%ndim - yst%valuesR4(ii)=yst%valuesR4(ii)+pa*xst%valuesR4(ii) - ENDDO + else if(xst%allkinds==r_single ) then + if(yst%allkinds==r_double) then + do ii=1,yst%ndim + yst%valuesr8(ii)=yst%valuesr8(ii)+pa*xst%valuesr4(ii) + enddo + else if(yst%allkinds==r_single)then + do ii=1,yst%ndim + yst%valuesr4(ii)=yst%valuesr4(ii)+pa*xst%valuesr4(ii) + enddo end if endif return -end subroutine self_add_R4scal +end subroutine self_add_r4scal ! ---------------------------------------------------------------------- -subroutine self_mulR8_(yst,pa) +subroutine self_mulr8_(yst,pa) ! 2010-05-15 todling - update to use gsi_bundle implicit none type(gsi_bundle), intent(inout) :: yst real(r_double), intent(in ) :: pa - character(len=*),parameter::myname_='self_mulR8_' + character(len=*),parameter::myname_='self_mulr8_' integer(i_kind) :: ii - if (yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',yst%AllKinds + if (yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',yst%allkinds call stop2(999) endif - if (yst%AllKinds==r_double) then - DO ii=1,yst%ndim - yst%valuesR8(ii)=pa*yst%valuesR8(ii) - ENDDO - else if (yst%AllKinds==r_single) then - DO ii=1,yst%ndim - yst%valuesR4(ii)=pa*yst%valuesR4(ii) - ENDDO + if (yst%allkinds==r_double) then + do ii=1,yst%ndim + yst%valuesr8(ii)=pa*yst%valuesr8(ii) + enddo + else if (yst%allkinds==r_single) then + do ii=1,yst%ndim + yst%valuesr4(ii)=pa*yst%valuesr4(ii) + enddo endif return -end subroutine self_mulR8_ -subroutine self_mulR4_(yst,pa) +end subroutine self_mulr8_ +subroutine self_mulr4_(yst,pa) ! 2010-05-15 todling - update to use gsi_bundle implicit none type(gsi_bundle), intent(inout) :: yst real(r_single), intent(in ) :: pa - character(len=*),parameter::myname_='self_mulR4_' + character(len=*),parameter::myname_='self_mulr4_' integer(i_kind) :: ii - if (yst%AllKinds<0 ) then - write(6,*)trim(myname_),': error bundle precision ',yst%AllKinds + if (yst%allkinds<0 ) then + write(6,*)trim(myname_),': error bundle precision ',yst%allkinds call stop2(999) endif - if (yst%AllKinds==r_double) then - DO ii=1,yst%ndim - yst%valuesR8(ii)=pa*yst%valuesR8(ii) - ENDDO - else if (yst%AllKinds==r_single) then - DO ii=1,yst%ndim - yst%valuesR4(ii)=pa*yst%valuesR4(ii) - ENDDO + if (yst%allkinds==r_double) then + do ii=1,yst%ndim + yst%valuesr8(ii)=pa*yst%valuesr8(ii) + enddo + else if (yst%allkinds==r_single) then + do ii=1,yst%ndim + yst%valuesr4(ii)=pa*yst%valuesr4(ii) + enddo endif return -end subroutine self_mulR4_ +end subroutine self_mulr4_ real(r_quad) function dplevs2dr8_(dx,dy,ihalo) @@ -3800,7 +3875,7 @@ real(r_double) function dplevs3dr4_(dx,dy,ihalo) return end function dplevs3dr4_ -real(r_double) function sum2dR8_(field,ihalo) +real(r_double) function sum2dr8_(field,ihalo) implicit none real(r_double),dimension(:,:),intent(in) :: field integer(i_kind),optional ,intent(in) :: ihalo @@ -3822,10 +3897,10 @@ real(r_double) function sum2dR8_(field,ihalo) sum_mask=sum_mask+field(i,j) end do end do - sum2dR8_=sum_mask + sum2dr8_=sum_mask return -end function sum2dR8_ -real(r_single) function sum2dR4_(field,ihalo) +end function sum2dr8_ +real(r_single) function sum2dr4_(field,ihalo) implicit none real(r_single),dimension(:,:),intent(in) :: field integer(i_kind),optional ,intent(in) :: ihalo @@ -3847,11 +3922,11 @@ real(r_single) function sum2dR4_(field,ihalo) sum_mask=sum_mask+field(i,j) end do end do - sum2dR4_=sum_mask + sum2dr4_=sum_mask return -end function sum2dR4_ +end function sum2dr4_ -real(r_double) function sum3dR8_(field,ihalo) +real(r_double) function sum3dr8_(field,ihalo) implicit none real(r_double),dimension(:,:,:),intent(in) :: field integer(i_kind),optional ,intent(in) :: ihalo @@ -3876,10 +3951,10 @@ real(r_double) function sum3dR8_(field,ihalo) end do end do end do - sum3dR8_=sum_mask + sum3dr8_=sum_mask return -end function sum3dR8_ -real(r_single) function sum3dR4_(field,ihalo) +end function sum3dr8_ +real(r_single) function sum3dr4_(field,ihalo) implicit none real(r_single),dimension(:,:,:),intent(in) :: field integer(i_kind),optional ,intent(in) :: ihalo @@ -3904,18 +3979,20 @@ real(r_single) function sum3dR4_(field,ihalo) end do end do end do - sum3dR4_=sum_mask + sum3dr4_=sum_mask return -end function sum3dR4_ +end function sum3dr4_ !............................................................................................ !BOP ! -! !IROUTINE: Unset_ --- Unset pointers within Bundle +! !IROUTINE: unset_ --- Unset pointers within bundle ! ! !INTERFACE: - subroutine unset_ ( Bundle, istatus ) + subroutine unset_ ( bundle, istatus ) + + implicit none - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle integer(i_kind),intent(out) :: istatus ! !DESCRIPTION: Nullify bundle pointers. @@ -3930,85 +4007,87 @@ subroutine unset_ ( Bundle, istatus ) integer(i_kind) :: i, is, n1d, n2d, n3d - n1d = Bundle%n1d - n2d = Bundle%n2d - n3d = Bundle%n3d + n1d = bundle%n1d + n2d = bundle%n2d + n3d = bundle%n3d is=0 istatus=0 if(n1d>0) then - call clean_(Bundle%r1,n1d,is) + call clean_(bundle%r1,n1d,is) istatus=istatus+is do i = 1, n1d - nullify(Bundle%r1(i)%q) - if (Bundle%r1(i)%myKind==r_single) then - nullify(Bundle%r1(i)%qr4) - else if (Bundle%r1(i)%myKind==r_double) then - nullify(Bundle%r1(i)%qr8) + nullify(bundle%r1(i)%q) + if (bundle%r1(i)%mykind==r_single) then + nullify(bundle%r1(i)%qr4) + else if (bundle%r1(i)%mykind==r_double) then + nullify(bundle%r1(i)%qr8) endif enddo - deallocate(Bundle%r1,stat=is) + deallocate(bundle%r1,stat=is) istatus=istatus+is - deallocate(Bundle%ival1,stat=is) + deallocate(bundle%ival1,stat=is) endif istatus=istatus+is if(n2d>0) then - call clean_(Bundle%r2,n2d,is) + call clean_(bundle%r2,n2d,is) istatus=istatus+is do i = 1, n2d - nullify(Bundle%r2(i)%q) - if (Bundle%r2(i)%myKind==r_single) then - nullify(Bundle%r2(i)%qr4) - else if (Bundle%r2(i)%myKind==r_double) then - nullify(Bundle%r2(i)%qr8) + nullify(bundle%r2(i)%q) + if (bundle%r2(i)%mykind==r_single) then + nullify(bundle%r2(i)%qr4) + else if (bundle%r2(i)%mykind==r_double) then + nullify(bundle%r2(i)%qr8) endif enddo - deallocate(Bundle%r2,stat=is) + deallocate(bundle%r2,stat=is) istatus=istatus+is - deallocate(Bundle%ival2,stat=is) + deallocate(bundle%ival2,stat=is) endif istatus=istatus+is if(n3d>0) then - call clean_(Bundle%r3,n3d,is) + call clean_(bundle%r3,n3d,is) istatus=istatus+is do i = 1, n3d - nullify(Bundle%r3(i)%q) - if (Bundle%r3(i)%myKind==r_single) then - nullify(Bundle%r3(i)%qr4) - else if (Bundle%r3(i)%myKind==r_double) then - nullify(Bundle%r3(i)%qr8) + nullify(bundle%r3(i)%q) + if (bundle%r3(i)%mykind==r_single) then + nullify(bundle%r3(i)%qr4) + else if (bundle%r3(i)%mykind==r_double) then + nullify(bundle%r3(i)%qr8) endif enddo - deallocate(Bundle%r3,stat=is) + deallocate(bundle%r3,stat=is) istatus=istatus+is - deallocate(Bundle%ival3,stat=is) + deallocate(bundle%ival3,stat=is) endif istatus=istatus+is ! .... need grid clean for more general grids - Bundle%grid%im=-1 - Bundle%grid%jm=-1 - Bundle%grid%km=-1 + bundle%grid%im=-1 + bundle%grid%jm=-1 + bundle%grid%km=-1 - Bundle%n1d=-1 - Bundle%n2d=-1 - Bundle%n3d=-1 - Bundle%ndim=-1 + bundle%n1d=-1 + bundle%n2d=-1 + bundle%n3d=-1 + bundle%ndim=-1 end subroutine unset_ !noEOC !............................................................................................ !BOP ! -! !IROUTINE: Destroy_ --- Deallocate contents of Bundle +! !IROUTINE: destroy_ --- Deallocate contents of bundle ! ! !INTERFACE: - subroutine destroy_ ( Bundle, istatus ) + subroutine destroy_ ( bundle, istatus ) + + implicit none ! !INPUT/OUTPUT PARAMETERS: - type(GSI_Bundle),intent(inout) :: Bundle + type(gsi_bundle),intent(inout) :: bundle ! !OUTPUT PARAMETERS: @@ -4031,224 +4110,227 @@ subroutine destroy_ ( Bundle, istatus ) if(present(istatus)) istatus=0 - n1d = Bundle%n1d - n2d = Bundle%n2d - n3d = Bundle%n3d + n1d = bundle%n1d + n2d = bundle%n2d + n3d = bundle%n3d istatus_=0 is=0 ! In opposite order of creation - if(n3d>0) deallocate(Bundle%ival3,stat=istatus_); istatus_=abs(istatus_) + if(n3d>0) deallocate(bundle%ival3,stat=istatus_); istatus_=abs(istatus_) is=istatus_+is - if(n2d>0) deallocate(Bundle%ival2,stat=istatus_); istatus_=abs(istatus_) + if(n2d>0) deallocate(bundle%ival2,stat=istatus_); istatus_=abs(istatus_) is=istatus_+is - if(n1d>0) deallocate(Bundle%ival1,stat=istatus_); istatus_=abs(istatus_) + if(n1d>0) deallocate(bundle%ival1,stat=istatus_); istatus_=abs(istatus_) is=istatus_+is if(is/=0) then - if(.not.present(istatus)) call die(myname_,'failed(ival),istatus =',is) - istatus=is - return + if(.not.present(istatus)) call die(myname_,'failed(ival),istatus =',is) + istatus=is + return endif - if (Bundle%AllKinds==r_single) then - deallocate(Bundle%valuesr4,stat=istatus_); istatus_=abs(istatus_) - else if (Bundle%AllKinds==r_double) then - deallocate(Bundle%valuesr8,stat=istatus_); istatus_=abs(istatus_) + if (bundle%allkinds==r_single) then + deallocate(bundle%valuesr4,stat=istatus_); istatus_=abs(istatus_) + else if (bundle%allkinds==r_double) then + deallocate(bundle%valuesr8,stat=istatus_); istatus_=abs(istatus_) endif - if(associated(Bundle%values)) nullify(Bundle%values) + if(associated(bundle%values)) nullify(bundle%values) is=istatus_+is if(is/=0) then - if(.not.present(istatus)) call die(myname_,'failed(values),istatus =',is) - istatus=is - return + if(.not.present(istatus)) call die(myname_,'failed(values),istatus =',is) + istatus=is + return endif if(n1d>0) then - call clean_(Bundle%r1,n1d,istatus_); istatus_=abs(istatus_) + call clean_(bundle%r1,n1d,istatus_); istatus_=abs(istatus_) is=istatus_+is do i = 1, n1d - nullify(Bundle%r1(i)%q) - if (Bundle%r1(i)%myKind==r_single) then - nullify(Bundle%r1(i)%qr4) - else if (Bundle%r1(i)%myKind==r_double) then - nullify(Bundle%r1(i)%qr8) + nullify(bundle%r1(i)%q) + if (bundle%r1(i)%mykind==r_single) then + nullify(bundle%r1(i)%qr4) + else if (bundle%r1(i)%mykind==r_double) then + nullify(bundle%r1(i)%qr8) endif enddo - deallocate(Bundle%r1,stat=istatus_); istatus_=abs(istatus_) + deallocate(bundle%r1,stat=istatus_); istatus_=abs(istatus_) endif is=istatus_+is if(is/=0) then - if(.not.present(istatus)) call die(myname_,'failed(r1),istatus =',is) - istatus=is - return + if(.not.present(istatus)) call die(myname_,'failed(r1),istatus =',is) + istatus=is + return endif if(n2d>0) then - call clean_(Bundle%r2,n2d,istatus_); istatus_=abs(istatus_) + call clean_(bundle%r2,n2d,istatus_); istatus_=abs(istatus_) is=istatus_+is do i = 1, n2d - nullify(Bundle%r2(i)%q) - if (Bundle%r2(i)%myKind==r_single) then - nullify(Bundle%r2(i)%qr4) - else if (Bundle%r2(i)%myKind==r_double) then - nullify(Bundle%r2(i)%qr8) + nullify(bundle%r2(i)%q) + if (bundle%r2(i)%mykind==r_single) then + nullify(bundle%r2(i)%qr4) + else if (bundle%r2(i)%mykind==r_double) then + nullify(bundle%r2(i)%qr8) endif enddo - deallocate(Bundle%r2,stat=istatus_); istatus_=abs(istatus_) + deallocate(bundle%r2,stat=istatus_); istatus_=abs(istatus_) endif is=istatus_+is if(is/=0) then - if(.not.present(istatus)) call die(myname_,'failed(r2),istatus =',is) - istatus=is - return + if(.not.present(istatus)) call die(myname_,'failed(r2),istatus =',is) + istatus=is + return endif if(n3d>0) then - call clean_(Bundle%r3,n3d,istatus_); istatus_=abs(istatus_) + call clean_(bundle%r3,n3d,istatus_); istatus_=abs(istatus_) is=istatus_+is do i = 1, n3d - nullify(Bundle%r3(i)%q) - if (Bundle%r3(i)%myKind==r_single) then - nullify(Bundle%r3(i)%qr4) - else if (Bundle%r3(i)%myKind==r_double) then - nullify(Bundle%r3(i)%qr8) + nullify(bundle%r3(i)%q) + if (bundle%r3(i)%mykind==r_single) then + nullify(bundle%r3(i)%qr4) + else if (bundle%r3(i)%mykind==r_double) then + nullify(bundle%r3(i)%qr8) endif enddo - deallocate(Bundle%r3,stat=istatus_); istatus_=abs(istatus_) + deallocate(bundle%r3,stat=istatus_); istatus_=abs(istatus_) endif is=istatus_+is ! .... need grid clean for more general grids - Bundle%grid%im=-1 - Bundle%grid%jm=-1 - Bundle%grid%km=-1 + bundle%grid%im=-1 + bundle%grid%jm=-1 + bundle%grid%km=-1 - Bundle%n1d=-1 - Bundle%n2d=-1 - Bundle%n3d=-1 - Bundle%NumVars=-1 - Bundle%ndim=-1 + bundle%n1d=-1 + bundle%n2d=-1 + bundle%n3d=-1 + bundle%numvars=-1 + bundle%ndim=-1 if(is/=0) then - if(.not.present(istatus)) call die(myname_,'istatus =',is) - istatus=is - return + if(.not.present(istatus)) call die(myname_,'istatus =',is) + istatus=is + return endif end subroutine destroy_ !............................................................................................ !BOP ! -! !IROUTINE: Print_ --- Print max/min of bundle contents +! !IROUTINE: print_ --- Print max/min of bundle contents ! ! !INTERFACE: - subroutine print_ ( Bundle ) + subroutine print_ ( bundle ) + + implicit none ! !INPUT PARAMETERS: - type(GSI_Bundle) :: Bundle + type(gsi_bundle) :: bundle ! !DESCRIPTION: Summarize contents of bundle by echoing max/min values. ! ! ! !REMARKS: -! 1. As the rest of the Bundle, this routine is MPI-free, so user +! 1. As the rest of the bundle, this routine is mpi-free, so user ! should be cautions when calling it each process will write its own. ! ! !REVISION HISTORY: ! ! 2010 da Silva Initial code -! 27Apr2010 Todling Adapt to GSI_Bundle +! 27Apr2010 Todling Adapt to gsi_bundle ! !EOP !------------------------------------------------------------------------- !noBOC integer(i_kind) :: i character(len=*),parameter::myname_='print_' - if (Bundle%AllKinds<0 ) then - write(6,*) myname_, ':trouble with bundle precision bundle ', Bundle%AllKinds + if (bundle%allkinds<0 ) then + write(6,*) myname_, ':trouble with bundle precision bundle ', bundle%allkinds call stop2(999) endif print * - print *, 'Bundle: ', trim(Bundle%name) - do i = 1, Bundle%n1d - if (Bundle%r1(i)%myKind==r_single) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [1d] '//Bundle%r1(i)%shortname, & - minval(Bundle%r1(i)%qr4), & - maxval(Bundle%r1(i)%qr4) - else if (Bundle%r1(i)%myKind==r_double) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [1d] '//Bundle%r1(i)%shortname, & - minval(Bundle%r1(i)%qr8), & - maxval(Bundle%r1(i)%qr8) + print *, 'Bundle: ', trim(bundle%name) + do i = 1, bundle%n1d + if (bundle%r1(i)%mykind==r_single) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [1d] '//bundle%r1(i)%shortname, & + minval(bundle%r1(i)%qr4), & + maxval(bundle%r1(i)%qr4) + else if (bundle%r1(i)%mykind==r_double) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [1d] '//bundle%r1(i)%shortname, & + minval(bundle%r1(i)%qr8), & + maxval(bundle%r1(i)%qr8) endif end do - do i = 1, Bundle%n2d - if (Bundle%r2(i)%myKind==r_single) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [2d] '//Bundle%r2(i)%shortname, & - minval(Bundle%r2(i)%qr4), & - maxval(Bundle%r2(i)%qr4) - else if (Bundle%r2(i)%myKind==r_double) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [2d] '//Bundle%r2(i)%shortname, & - minval(Bundle%r2(i)%qr8), & - maxval(Bundle%r2(i)%qr8) + do i = 1, bundle%n2d + if (bundle%r2(i)%mykind==r_single) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [2d] '//bundle%r2(i)%shortname, & + minval(bundle%r2(i)%qr4), & + maxval(bundle%r2(i)%qr4) + else if (bundle%r2(i)%mykind==r_double) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [2d] '//bundle%r2(i)%shortname, & + minval(bundle%r2(i)%qr8), & + maxval(bundle%r2(i)%qr8) endif end do - do i = 1, Bundle%n3d - if (Bundle%r3(i)%myKind==r_single) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [3d] '//Bundle%r3(i)%shortname, & - minval(Bundle%r3(i)%qr4), & - maxval(Bundle%r3(i)%qr4) - else if (Bundle%r3(i)%myKind==r_double) then - write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [3d] '//Bundle%r3(i)%shortname, & - minval(Bundle%r3(i)%qr8), & - maxval(Bundle%r3(i)%qr8) + do i = 1, bundle%n3d + if (bundle%r3(i)%mykind==r_single) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [3d] '//bundle%r3(i)%shortname, & + minval(bundle%r3(i)%qr4), & + maxval(bundle%r3(i)%qr4) + else if (bundle%r3(i)%mykind==r_double) then + write(*,'(a20,2x,1p,e11.4,2x,e11.4)') ' [3d] '//bundle%r3(i)%shortname, & + minval(bundle%r3(i)%qr8), & + maxval(bundle%r3(i)%qr8) endif end do end subroutine print_ !noEOC - logical function redundant_ ( Bundle ) - type(gsi_bundle),intent(in) :: Bundle + logical function redundant_ ( bundle ) + implicit none + type(gsi_bundle),intent(in) :: bundle integer(i_kind) i,j,ic,n1d,n2d,n3d,nvars,istatus - character(len=MAXSTR),allocatable::fnames(:) + character(len=maxstr),allocatable::fnames(:) redundant_=.false. - n1d=Bundle%n1d - n2d=Bundle%n2d - n3d=Bundle%n3d - nvars=Bundle%Numvars + n1d=bundle%n1d + n2d=bundle%n2d + n3d=bundle%n3d + nvars=bundle%numvars allocate(fnames(nvars)) - call inquire_char_ ( Bundle, 'shortnames', fnames, istatus ) + call inquire_char_ ( bundle, 'shortnames', fnames, istatus ) if (istatus/=0) then redundant_=.true. ! what else to do? deallocate(fnames) return endif if (nvars>0) then - do j = 1,nvars - ic=0 - do i = j,nvars - if(trim(fnames(i))==trim(fnames(j))) ic=ic+1 ! this is stupid - enddo - if(ic/=1) then - redundant_=.true. - deallocate(fnames) - return - endif - enddo + do j = 1,nvars + ic=0 + do i = j,nvars + if(trim(fnames(i))==trim(fnames(j))) ic=ic+1 ! this is stupid + enddo + if(ic/=1) then + redundant_=.true. + deallocate(fnames) + return + endif + enddo endif deallocate(fnames) end function redundant_ - subroutine GSI_GridCreate ( grid, im, jm, km ) + subroutine gsi_gridcreate ( grid, im, jm, km ) ! this does not belong to the bundle ... gridmod? implicit none - integer, intent(in) :: im, jm, km - type(GSI_Grid), intent(out) :: grid + integer(i_kind),intent(in) :: im, jm, km + type(gsi_grid), intent(out) :: grid grid%im=im grid%jm=jm grid%km=km - end subroutine GSI_GridCreate + end subroutine gsi_gridcreate -end module GSI_BundleMod +end module gsi_bundlemod !EOC diff --git a/src/gsi/gsi_chemguess_mod.F90 b/src/gsi/gsi_chemguess_mod.F90 index deb45443c3..5e71813d8d 100644 --- a/src/gsi/gsi_chemguess_mod.F90 +++ b/src/gsi/gsi_chemguess_mod.F90 @@ -1,6 +1,6 @@ !BOI -! !TITLE: GSI\_ChemGuess\_Mod: A GSI Bundle to handle Trace Gases and Aerosols +! !TITLE: gsi\_chemguess\_mod: A gsi bundle to handle trace gases and aerosols ! !AUTHORS: Ricardo Todling @@ -11,48 +11,48 @@ ! !INTRODUCTION: Overview #ifdef __PROTEX__ -This module defines to so-called GSI\_ChemGuess\_Bundle. Its main purpose is to -allow GSI to ingest guess fields related to trace gases, aerosols, and chemistry +This module defines to so-called gsi\_chemguess\_bundle. Its main purpose is to +allow gsi to ingest guess fields related to trace gases, aerosols, and chemistry in general. \begin{center} -\fbox{Chem Bundle is a way to ingest Chemistry-related backgrounds into GSI} +\fbox{Chem bundle is a way to ingest chemistry-related backgrounds into gsi} \end{center} -Before the introduction of this module, all guess fields entered GSI through the +Before the introduction of this module, all guess fields entered gsi through the arrays ges\_x, with x standing for particular fields, defined in the guess\_grids module, e.g., ges\_u, ges\_tv, and so on. Extending this approach to handle chemistry-related fields could become rather complex, particularly, because it is in principle not known which fields are -needed for given application. The GSI\_ChemGuess\_Bundle aims at allowing GSI to ingest +needed for given application. The gsi\_chemguess\_bundle aims at allowing gsi to ingest a general set of fields without a given order or particular specification. -\underline{Caution}: An important exception is ozone. Since guess\_grids already handles ozone, this +\underline{Caution}: an important exception is ozone. Since guess\_grids already handles ozone, this is the only chemistry field that should still be dealt through guess\_gridsi, as ges\_oz. \begin{center} -\fbox{Chem Bundle is a GSI\_Bundle} +\fbox{Chem bundle is a gsi\_bundle} \end{center} -The GSI\_ChemGuess\_Bundle uses the GSI\_Bundle. But while the state and control vectors -use the GSI\_Bundle to associate fields used by the observation operator and -those used in the cost function, respectively, the GSI\_ChemGuess\_Bundle -is simply aimed at allowing ingestion of Chemistry Guess fields into GSI. The translation +The gsi\_chemguess\_bundle uses the gsi\_bundle. But while the state and control vectors +use the gsi\_bundle to associate fields used by the observation operator and +those used in the cost function, respectively, the gsi\_chemguess\_bundle +is simply aimed at allowing ingestion of chemistry guess fields into gsi. The translation of these guess fields into state and control vectors is still done via the state and control vectors defining mechanism. -As guess\_grids does, this module still treats the Chemistry Guess fields via a -common-block-like structure. That is, the GSI\_Bundle defined here to hold the -Chemistry Guess fields is an internally defined type that cannot be passed +As guess\_grids does, this module still treats the chemistry guess fields via a +common-block-like structure. That is, the gsi\_bundle defined here to hold the +chemistry guess fields is an internally defined type that cannot be passed around. This will change in the future, but for the time being this is the simplest thing to do given the current code design. \begin{center} -\fbox{Chem Bundle Module provides an (almost) opaque access to the entries in +\fbox{Chem bundle module provides an (almost) opaque access to the entries in the object} \end{center} One of the ideas behind this module is that it defines an opaque-like object. -That is, functions related to contents of the Chem Bundle should can only be +That is, functions related to contents of the chem bundle should can only be extracted via inquires through a ``get-like'' procedures. This is why, only ``methods'' are made public to this module, that is, @@ -64,17 +64,17 @@ public :: gsi_chemguess_final \end{verbatim} -and never the variables themselves; the only exception being the GSI\_ChemGuess\_Bundle itself +and never the variables themselves; the only exception being the gsi\_chemguess\_bundle itself (until it is no longer treated as a common-block). Some of the above public methods are overloaded and all have internal interfaces (name of which appears in the index of this protex document. It should be a rule here that any new routine to be make public should have a declared interface procedure. \begin{center} -\fbox{Chem Bundle is defined via the {\it chem\_guess} table in a resource file} +\fbox{Chem bundle is defined via the {\it chem\_guess} table in a resource file} \end{center} -\underline{Defining the Chem Bundle} is done via the table {\it chem\_guess}, usually +\underline{Defining the chem bundle} is done via the table {\it chem\_guess}, usually embedded in the {\it anavinfo} file. An example of such table follows: \begin{verbatim} chem_guess:: @@ -103,35 +103,35 @@ ocphilic 72 1 10 wet_organic_carbon OCphilic :: \end{verbatim} -This is what GMAO plans to use in the near future. +This is what gmao plans to use in the near future. -As usual, this table follows INPAK/ESMF convention, begining with a name +As usual, this table follows inpak/esmf convention, begining with a name (chem\_guess), followed by double colons (::), and ending with double colons. Any line starting with an exclamation mark or a pound sign is taken as a comment. The current {\it chem\_guess} table has six columns defined as follows: \begin{verbatim} -Column 1: variable name - refers to internally known GSI variable name +Column 1: variable name - refers to internally known gsi variable name Column 2: indicates number of levels (used to distinguish between 2d and 3d fields) Column 3: likely to be redefined sometime soon -Column 4: indicates whether variable is to be passed to CRTM or not according to +Column 4: indicates whether variable is to be passed to crtm or not according to the following scheme: - if<0 general chem variable; not used in CRTM - if=0 general chem variable; use prescribed global mean data to affect CRTM - if=1 general chem variable; use variable in guess field to affect CRTM + if<0 general chem variable; not used in crtm + if=0 general chem variable; use prescribed global mean data to affect crtm + if=1 general chem variable; use variable in guess field to affect crtm if>10 aerosol variable Column 5: type of chemical/aerosol Column 6: original name in file where species is read from \end{verbatim} \begin{center} -\fbox{Examples of extracting information related to the Chem Bundle} +\fbox{Examples of extracting information related to the chem bundle} \end{center} -\underline{Examples} of accessing information related to fields in the Chem Bundle. +\underline{Examples} of accessing information related to fields in the chem bundle. \begin{enumerate} -\item Say a routine wants to know how $CO_2$ is to be used in CRTM. +\item Say a routine wants to know how $CO_2$ is to be used in crtm. This is done via the {\it i4crtm::} tag, as in: \begin{verbatim} call gsi_chemguess_get ( 'i4crtm::co2', igfsco2, ier ) @@ -140,7 +140,7 @@ scheme laid out for entries in column 4 of the resource file (anavinfo). \item Say a routine wants to get the number of all 3d aerosols available in the - Chem Bundle, this can use the tag {\it aerosols::3d}, as in: + chem bundle, this can use the tag {\it aerosols::3d}, as in: \begin{verbatim} call gsi_chemguess_get ( 'aerosols::3d',n_aerosols,ier ) \end{verbatim} @@ -162,7 +162,7 @@ prologue description of the {it get} routines. \begin{center} -\fbox{Conventions and Remarks} +\fbox{Conventions and remarks} \end{center} \underline{Conventions} proposed for entries in this module: @@ -175,11 +175,11 @@ A general remark about the correct {\it chem\_guess} table: it is recognized that the format for general specification related to specific entries in the table is -not general enough. A better approach is the one used by the Registry used in -GEOS-5 GOCART where a table exists to control a particular functionality +not general enough. A better approach is the one used by the registry used in +geos-5 gocart where a table exists to control a particular functionality applicable to a certain set of constituents. For example, use of a variable in -CRTM could be control instead by a specific table listing constituents to be -used in the CRTM and at what extent, for example, a table of the form: +crtm could be control instead by a specific table listing constituents to be +used in the crtm and at what extent, for example, a table of the form: \begin{verbatim} use_in_crtm:: !var use @@ -199,7 +199,7 @@ !------------------------------------------------------------------------- !BOP ! -! !MODULE: ChemguessMod -- Implements Chem Guess capability for GSI +! !MODULE: chemguessmod -- Implements chem guess capability for gsi ! ! !INTERFACE: @@ -210,7 +210,7 @@ module gsi_chemguess_mod ! we'll generalize this. ! ! !REMARKS: -! 1. VERY IMPORTANT: No object from this file is to be make +! 1. Very important: No object from this file is to be make ! explicitly available to the outside world. ! Each object must be opaque with a get and ! a put method associated with it. @@ -225,14 +225,14 @@ module gsi_chemguess_mod use mpimod, only : mype use mpeu_util,only: die use file_utility, only : get_lun -use gsi_bundlemod, only : GSI_BundleCreate -use gsi_bundlemod, only : GSI_BundleGetPointer -use gsi_bundlemod, only : GSI_Bundle -use gsi_bundlemod, only : GSI_BundlePrint -use gsi_bundlemod, only : GSI_BundleDestroy +use gsi_bundlemod, only : gsi_bundlecreate +use gsi_bundlemod, only : gsi_bundlegetpointer +use gsi_bundlemod, only : gsi_bundle +use gsi_bundlemod, only : gsi_bundleprint +use gsi_bundlemod, only : gsi_bundledestroy -use gsi_bundlemod, only : GSI_Grid -use gsi_bundlemod, only : GSI_GridCreate +use gsi_bundlemod, only : gsi_grid +use gsi_bundlemod, only : gsi_gridcreate use mpeu_util, only: gettablesize use mpeu_util, only: gettable @@ -250,41 +250,41 @@ module gsi_chemguess_mod public :: gsi_chemguess_get public :: gsi_chemguess_final -public :: GSI_ChemGuess_Bundle ! still a common for now, ultimately should +public :: gsi_chemguess_bundle ! still a common for now, ultimately should ! be a dynamic "type", passed around in arg list ! !INTERFACE: interface gsi_chemguess_init - module procedure init_ + module procedure init_ end interface interface gsi_chemguess_final - module procedure final_ + module procedure final_ end interface interface gsi_chemguess_create_grids - module procedure create_ + module procedure create_ end interface interface gsi_chemguess_destroy_grids - module procedure destroy_ + module procedure destroy_ end interface interface gsi_chemguess_get - module procedure get_int0d_ - module procedure get_char0d_ - module procedure get_char1d_ + module procedure get_int0d_ + module procedure get_char0d_ + module procedure get_char1d_ end interface -type(GSI_Bundle),pointer :: GSI_ChemGuess_Bundle(:) ! still a common for now +type(gsi_bundle),pointer :: gsi_chemguess_bundle(:) ! still a common for now ! !REVISION HISTORY: ! ! 20Apr2010 Todling Initial code. ! 03May2010 Treadon - add iostat error check to ibm_sp read(lu,chemguess) in init_ -! 19May2010 Todling - porter Hou's igfsco2 flag from setup namelist to this namelist +! 19May2010 Todling - ported hou's igfsco2 flag from setup namelist to this namelist ! 30May2010 Todling - remove namelist; revamp the way fields/info read in (i90-style) ! 25Jun2010 Treadon - consistently intialize ivar; check/use length of desc (gsi_chemguess_get) ! 07Oct2010 Todling - add entry usrname to differentiate gsi-names w/ in-file names -! 01May2011 Todling - rename module and its bundle for parallelism w/ MetGuess +! 01May2011 Todling - rename module and its bundle for parallelism w/ metguess ! !EOP !------------------------------------------------------------------------- @@ -292,7 +292,7 @@ module gsi_chemguess_mod ! !PRIVATE ROUTINES: !BOC -integer(i_kind),parameter::MAXSTR=max_varname_length +integer(i_kind),parameter::maxstr=max_varname_length logical:: chem_grid_initialized_=.false. logical:: chem_initialized_=.false. character(len=*), parameter :: myname = 'gsi_chemguess_mod' @@ -305,17 +305,17 @@ module gsi_chemguess_mod integer(i_kind) :: n3daero=0 integer(i_kind) :: ng3d=-1 integer(i_kind) :: ng2d=-1 -character(len=MAXSTR),allocatable :: tgases(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: tgases3d(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: tgases2d(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: chemtype(:) ! indicate type of chem (used for aerosols for now) -character(len=MAXSTR),allocatable :: chemty3d(:) ! indicate 3d type of chem -character(len=MAXSTR),allocatable :: chemty2d(:) ! indicate 3d type of chem -character(len=MAXSTR),allocatable :: usrname3d(:) ! chem user-defined (original) 3d name (in file) -character(len=MAXSTR),allocatable :: usrname2d(:) ! chem user-defined (original) 2d name (in file) -character(len=MAXSTR),allocatable :: usrname(:) ! chem user-defined (original) name (in file) -integer(i_kind),allocatable,dimension(:) :: i4crtm ! controls use of gas in CRTM: - ! < 0 don't use in CRTM +character(len=maxstr),allocatable :: tgases(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: tgases3d(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: tgases2d(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: chemtype(:) ! indicate type of chem (used for aerosols for now) +character(len=maxstr),allocatable :: chemty3d(:) ! indicate 3d type of chem +character(len=maxstr),allocatable :: chemty2d(:) ! indicate 3d type of chem +character(len=maxstr),allocatable :: usrname3d(:) ! chem user-defined (original) 3d name (in file) +character(len=maxstr),allocatable :: usrname2d(:) ! chem user-defined (original) 2d name (in file) +character(len=maxstr),allocatable :: usrname(:) ! chem user-defined (original) name (in file) +integer(i_kind),allocatable,dimension(:) :: i4crtm ! controls use of gas in crtm: + ! < 0 don't use in crtm ! = 0 use predefined global mean co2 mixing ration ! = 1 use gfs yearly global annual mean historical co2 value ! = 2 use gfs monthly horizontal 2-d historical co2 value @@ -331,7 +331,7 @@ module gsi_chemguess_mod !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: init_ --- Initialize Chem Bundle (read resource table); alloc internal +! !IROUTINE: init_ --- Initialize chem bundle (read resource table); alloc internal ! ! !INTERFACE: ! @@ -339,8 +339,8 @@ subroutine init_ (iamroot) ! USES: implicit none ! !INPUT PARAMETER: - logical,optional,intent(in) :: iamroot -! !DESCRIPTION: Define contents of Chem Bundle through rc file (typilcally +logical,optional,intent(in) :: iamroot +! !DESCRIPTION: Define contents of chem bundle through rc file (typilcally ! embedded in anavinfo text file. ! ! !REVISION HISTORY: @@ -400,9 +400,9 @@ subroutine init_ (iamroot) do ii=1,ntgases read(utable(ii),*) var, ilev, itracer, icrtmuse if(ilev==1) then - ng2d=ng2d+1 + ng2d=ng2d+1 else - ng3d=ng3d+1 + ng3d=ng3d+1 endif enddo @@ -436,8 +436,8 @@ subroutine init_ (iamroot) usrname3d(ng3d)=trim(adjustl(oname)) if(abs(icrtmuse)>=10.and.abs(icrtmuse)<20) n3daero=n3daero+1 ! convention, for now endif - if(abs(icrtmuse)< 10) nghg =nghg +1 ! GHG convention, for now - if(abs(icrtmuse)>=10.and.abs(icrtmuse)<20) naero=naero+1 ! AERO convention, for now + if(abs(icrtmuse)< 10) nghg =nghg +1 ! ghg convention, for now + if(abs(icrtmuse)>=10.and.abs(icrtmuse)<20) naero=naero+1 ! aero convention, for now enddo deallocate(utable) @@ -481,7 +481,7 @@ end subroutine init_ !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: final_ --- Deallocate internal Chem Bundle info arrays +! !IROUTINE: final_ --- Deallocate internal chem bundle info arrays ! ! !INTERFACE: ! @@ -529,7 +529,7 @@ end subroutine final_ ! ! !INTERFACE: ! -!!subroutine create_(GSI_ChemGuess_Bundle,im,jm,km,lm,istatus) ! ultimately +!!subroutine create_(gsi_chemguess_bundle,im,jm,km,lm,istatus) ! ultimately subroutine create_(im,jm,km,lm,istatus) ! !USES: @@ -544,7 +544,7 @@ subroutine create_(im,jm,km,lm,istatus) integer(i_kind),intent(out)::istatus ! !INPUT/OUTPUT PARAMETERS: -!! type(GSI_Bundle) :: GSI_ChemGuess_Bundle +!! type(gsi_bundle) :: gsi_chemguess_bundle ! !DESCRIPTION: allocate grids to hold guess cloud fields ! @@ -564,7 +564,7 @@ subroutine create_(im,jm,km,lm,istatus) character(len=*), parameter :: myname_ = myname//'*create_' integer(i_kind) nt - type(GSI_Grid):: grid + type(gsi_grid):: grid istatus=0 if(ntgases<=0) return @@ -575,16 +575,16 @@ subroutine create_(im,jm,km,lm,istatus) call gsi_gridcreate ( grid, im, jm, km ) nbundles = lm - allocate(GSI_ChemGuess_Bundle(nbundles)) + allocate(gsi_chemguess_bundle(nbundles)) do nt=1,nbundles if (ng2d>0.and.ng3d>0) then - call GSI_BundleCreate ( GSI_ChemGuess_Bundle(nt), grid, 'Trace Gases', istatus, & + call gsi_bundlecreate ( gsi_chemguess_bundle(nt), grid, 'Trace Gases', istatus, & names2d=tgases2d,names3d=tgases3d,bundle_kind=r_kind ) else if (ng2d>0) then - call GSI_BundleCreate ( GSI_ChemGuess_Bundle(nt), grid, 'Trace Gases', istatus, & + call gsi_bundlecreate ( gsi_chemguess_bundle(nt), grid, 'Trace Gases', istatus, & names2d=tgases2d,bundle_kind=r_kind ) else if (ng3d>0) then - call GSI_BundleCreate ( GSI_ChemGuess_Bundle(nt), grid, 'Trace Gases', istatus, & + call gsi_bundlecreate ( gsi_chemguess_bundle(nt), grid, 'Trace Gases', istatus, & names3d=tgases3d,bundle_kind=r_kind ) else istatus=99 @@ -592,9 +592,9 @@ subroutine create_(im,jm,km,lm,istatus) enddo if (istatus/=0) then - if(mype==0) write(6,*)trim(myname_),': allocate error1, istatus=',& - istatus,im,jm,km,lm - return + if(mype==0) write(6,*)trim(myname_),': allocate error1, istatus=',& + istatus,im,jm,km,lm + return endif if (verbose_) then @@ -613,7 +613,7 @@ end subroutine create_ ! ! !INTERFACE: ! -!!subroutine destroy_ (GSI_ChemGuess_Bundle, istatus) ! ultimately +!!subroutine destroy_ (gsi_chemguess_bundle, istatus) ! ultimately subroutine destroy_ (istatus) ! !USES: @@ -625,7 +625,7 @@ subroutine destroy_ (istatus) integer(i_kind), intent(out) :: istatus ! !INPPUT/OUTPUT PARAMETERS: -!! type(GSI_Bundle) :: GSI_ChemGuess_Bundle +!! type(gsi_bundle) :: gsi_chemguess_bundle ! !DESCRIPTION: Dealloc grids holding trace gases ! @@ -649,16 +649,16 @@ subroutine destroy_ (istatus) if(.not.chem_grid_initialized_) return - do nt=1,nbundles - call GSI_BundleDestroy ( GSI_ChemGuess_Bundle(nt), ier ) - istatus=istatus+ier - enddo - deallocate(GSI_ChemGuess_Bundle,stat=istatus) - istatus=istatus+ier + do nt=1,nbundles + call gsi_bundledestroy ( gsi_chemguess_bundle(nt), ier ) + istatus=istatus+ier + enddo + deallocate(gsi_chemguess_bundle,stat=istatus) + istatus=istatus+ier if (istatus/=0) then - if(mype==0) write(6,*)trim(myname_),': deallocate error1, istatus=',istatus - return + if(mype==0) write(6,*)trim(myname_),': deallocate error1, istatus=',istatus + return endif if (verbose_) then @@ -693,11 +693,11 @@ subroutine get_int0d_ ( desc, ivar, istatus ) ! aerosols number of aerosols ! aerosols::3d number of 3d aerosols ! aerosols::2d number of 2d aerosols -! i4crtm::XXX information related to CRTM usage of gas XXX -! var::XXX index of gas XXX in chem-bundle +! i4crtm::xxx information related to crtm usage of gas xxx +! var::xxx index of gas xxx in chem-bundle ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. +! where xxx represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -719,7 +719,7 @@ subroutine get_int0d_ ( desc, ivar, istatus ) integer(i_kind),intent(out):: ivar integer(i_kind),intent(out):: istatus character(len=*),parameter::myname_=myname//'*get_int0d_' - character(len=MAXSTR):: work + character(len=maxstr):: work integer(i_kind) ii,id,ln istatus=1 ivar=0 @@ -790,7 +790,7 @@ subroutine get_char0d_ ( desc, ivar, istatus ) ! list::tracers list of trace gases (non-aerosols) only ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. +! where xxx represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -810,8 +810,8 @@ subroutine get_char0d_ ( desc, ivar, istatus ) character(len=*),intent(out):: ivar integer(i_kind),intent(out):: istatus character(len=*),parameter::myname_=myname//'*get_char0d_' - character(len=MAXSTR):: gaslist - character(len=MAXSTR),allocatable:: work(:) + character(len=maxstr):: gaslist + character(len=maxstr),allocatable:: work(:) integer(i_kind) is,ie,i,i0 logical labfound labfound=.false. @@ -901,16 +901,16 @@ subroutine get_char1d_ ( desc, cvar, istatus ) ! \begin{verbatim} ! Known mnemonics retrieve ! --------------- -------- -! gsinames list of all trace gas names as known in GSI +! gsinames list of all trace gas names as known in gsi ! usrnames list of all user-defined gas names ! aerosols list of all aerosols ! aerosols::3d list of 3d aerosols ! aerosols::2d list of 2d aerosols -! aerosols_4crtm::3d list of 3d aerosols to be passed to CRTM -! aerosols_4crtm_jac::3d list of 3d aerosols to participate in CRTM-Jac calc +! aerosols_4crtm::3d list of 3d aerosols to be passed to crtm +! aerosols_4crtm_jac::3d list of 3d aerosols to participate in crtm-jac calc ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. +! where xxx represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -943,8 +943,8 @@ subroutine get_char1d_ ( desc, cvar, istatus ) labfound=.true. if(nvar>=size(tgases)) then if(allocated(tgases))then - cvar(1:size(tgases)) = tgases - istatus=0 + cvar(1:size(tgases)) = tgases + istatus=0 endif endif endif @@ -952,8 +952,8 @@ subroutine get_char1d_ ( desc, cvar, istatus ) labfound=.true. if(nvar>=size(usrname)) then if(allocated(usrname))then - cvar(1:size(tgases)) = usrname - istatus=0 + cvar(1:size(tgases)) = usrname + istatus=0 endif endif endif diff --git a/src/gsi/gsi_cldchOper.F90 b/src/gsi/gsi_cldchoper.f90 similarity index 70% rename from src/gsi/gsi_cldchOper.F90 rename to src/gsi/gsi_cldchoper.f90 index 96c4a1db78..db3e862c4a 100644 --- a/src/gsi/gsi_cldchOper.F90 +++ b/src/gsi/gsi_cldchoper.f90 @@ -1,12 +1,12 @@ -module gsi_cldchOper +module gsi_cldchoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_cldchOper +! subprogram: module gsi_cldchoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for cldchNode type +! abstract: an oboper extension for cldchnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_cldchOper ! module interface: - use gsi_obOper , only: obOper - use m_cldchNode, only: cldchNode + use gsi_oboper , only: oboper + use m_cldchnode, only: cldchnode implicit none - public:: cldchOper ! data stracture + public:: cldchoper ! data stracture - type,extends(obOper):: cldchOper + type,extends(oboper):: cldchoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type cldchOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type cldchoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_cldchOper' - type(cldchNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_cldchoper' + type(cldchnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[cldchOper]" + mytype="[cldchoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use cldch_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(cldchOper ), intent(inout):: self + class(cldchoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intcldchmod, only: intjo => intcldch use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(cldchOper ),intent(in ):: self + class(cldchoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpcldchmod, only: stpjo => stpcldch use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(cldchOper ),intent(in):: self + class(cldchoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_cldchOper +end module gsi_cldchoper diff --git a/src/gsi/gsi_cldtotOper.F90 b/src/gsi/gsi_cldtotoper.f90 similarity index 60% rename from src/gsi/gsi_cldtotOper.F90 rename to src/gsi/gsi_cldtotoper.f90 index 5a63e24765..41ec92abeb 100644 --- a/src/gsi/gsi_cldtotOper.F90 +++ b/src/gsi/gsi_cldtotoper.f90 @@ -1,12 +1,12 @@ -module gsi_cldtotOper +module gsi_cldtotoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_cldtotOper +! subprogram: module gsi_cldtotoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2019-07-22 ! -! abstract: an obOper extension for cldtot operator +! abstract: an oboper extension for cldtot operator ! ! program history log: ! 2019-07-22 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_cldtotOper ! module interface: - use gsi_obOper, only: obOper - use m_qNode , only: qNode + use gsi_oboper, only: oboper + use m_qnode , only: qnode implicit none - public:: cldtotOper ! data stracture + public:: cldtotoper ! data stracture - type,extends(obOper):: cldtotOper + type,extends(oboper):: cldtotoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type cldtotOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type cldtotoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_cldtotOper' - type(qNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_cldtotoper' + type(qnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[cldtotOper]" + mytype="[cldtotoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use cldtot_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -77,7 +77,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die,perr implicit none - class(cldtotOper), intent(inout):: self + class(cldtotoper), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -97,32 +97,32 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) ! try data header read(lunin,iostat=ier) obstype,isis,nreal,nchanl - if(ier/=0) then - call perr(myname_,'read(obstype,...), iostat =',ier) - call perr(myname_,' nobs =',nobs) - call die(myname_) - endif + if(ier/=0) then + call perr(myname_,'read(obstype,...), iostat =',ier) + call perr(myname_,' nobs =',nobs) + call die(myname_) + endif nele = nreal+nchanl diagsave = write_diag(jiter) .and. diag_conv select case(i_cloud_q_innovation) - case(2) - call setup(self%obsLL(:), self%odiagLL(:), & - lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + case(2) + call setup(self%obsll(:), self%odiagll(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) - case default + case default ! try to skip data record - read(lunin,iostat=ier) - if(ier/=0) then - call perr(myname_,'read(lunin), iostat =',ier) - call perr(myname_,' nobs =',nobs) - call perr(myname_,' obstype =',trim(obstype)) - call perr(myname_,' isis =',trim(isis)) - call perr(myname_,' nreal =',nreal) - call perr(myname_,' nchanl =',nchanl) - call die(myname_) - endif + read(lunin,iostat=ier) + if(ier/=0) then + call perr(myname_,'read(lunin), iostat =',ier) + call perr(myname_,' nobs =',nobs) + call perr(myname_,' obstype =',trim(obstype)) + call perr(myname_,' isis =',trim(isis)) + call perr(myname_,' nreal =',nreal) + call perr(myname_,' nchanl =',nchanl) + call die(myname_) + endif end select end subroutine setup_ @@ -131,11 +131,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intqmod, only: intjo => intq use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(cldtotOper),intent(in ):: self + class(cldtotoper),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -144,25 +144,25 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() - ! qNode is used, so there is no specific operation - return + ! qnode is used, so there is no specific operation + return end subroutine intjo1_ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpqmod, only: stpjo => stpq use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(cldtotOper ),intent(in):: self + class(cldtotoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -175,11 +175,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_cldtotOper +end module gsi_cldtotoper diff --git a/src/gsi/gsi_colvkOper.F90 b/src/gsi/gsi_colvkoper.f90 similarity index 69% rename from src/gsi/gsi_colvkOper.F90 rename to src/gsi/gsi_colvkoper.f90 index 9d32cfb7a9..d17cddadaf 100644 --- a/src/gsi/gsi_colvkOper.F90 +++ b/src/gsi/gsi_colvkoper.f90 @@ -1,12 +1,12 @@ -module gsi_colvkOper +module gsi_colvkoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_colvkOper +! subprogram: module gsi_colvkoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for colvkNode type +! abstract: an oboper extension for colvknode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_colvkOper ! module interface: - use gsi_obOper , only: obOper - use m_colvkNode, only: colvkNode + use gsi_oboper , only: oboper + use m_colvknode, only: colvknode implicit none - public:: colvkOper ! data stracture + public:: colvkoper ! data stracture - type,extends(obOper):: colvkOper + type,extends(oboper):: colvkoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type colvkOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type colvkoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_colvkOper' - type(colvkNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_colvkoper' + type(colvknode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[colvkOper]" + mytype="[colvkoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use colvk_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: stats => rhs_stats_co use obsmod, only: write_diag @@ -73,7 +73,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(colvkOper ), intent(inout):: self + class(colvkoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -96,7 +96,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_co - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) end subroutine setup_ @@ -105,11 +105,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intcomod, only: intjo => intco use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(colvkOper ),intent(in ):: self + class(colvkoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,11 +118,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -130,11 +130,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpcomod, only: stpjo => stpco use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(colvkOper ),intent(in):: self + class(colvkoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_colvkOper +end module gsi_colvkoper diff --git a/src/gsi/gsi_dbzOper.F90 b/src/gsi/gsi_dbzoper.f90 similarity index 72% rename from src/gsi/gsi_dbzOper.F90 rename to src/gsi/gsi_dbzoper.f90 index 74d9bdf65d..aef94bf20d 100644 --- a/src/gsi/gsi_dbzOper.F90 +++ b/src/gsi/gsi_dbzoper.f90 @@ -1,12 +1,12 @@ -module gsi_dbzOper +module gsi_dbzoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_dbzOper +! subprogram: module gsi_dbzoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for dbzNode type +! abstract: an oboper extension for dbznode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -27,53 +27,53 @@ module gsi_dbzOper ! module interface: - use gsi_obOper, only: obOper - use m_dbzNode , only: dbzNode + use gsi_oboper, only: oboper + use m_dbznode , only: dbznode implicit none - public:: dbzOper ! data stracture + public:: dbzoper ! data stracture public:: diag_radardbz - type,extends(obOper):: dbzOper + type,extends(oboper):: dbzoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type dbzOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type dbzoper ! def diag_radardbz- namelist logical to compute/write (=true) radar ! reflectiivty diag files logical,save:: diag_radardbz=.false. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_dbzOper' - type(dbzNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_dbzoper' + type(dbznode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[dbzOper]" + mytype="[dbzoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use dbz_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -84,7 +84,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(dbzOper ), intent(inout):: self + class(dbzoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -108,7 +108,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_radardbz - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) end subroutine setup_ @@ -117,11 +117,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intdbzmod, only: intjo => intdbz use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(dbzOper ),intent(in ):: self + class(dbzoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -130,11 +130,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -142,11 +142,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpdbzmod, only: stpjo => stpdbz use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(dbzOper ),intent(in):: self + class(dbzoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -159,11 +159,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_dbzOper +end module gsi_dbzoper diff --git a/src/gsi/gsi_dwOper.F90 b/src/gsi/gsi_dwoper.f90 similarity index 70% rename from src/gsi/gsi_dwOper.F90 rename to src/gsi/gsi_dwoper.f90 index 1772282912..d415e0cada 100644 --- a/src/gsi/gsi_dwOper.F90 +++ b/src/gsi/gsi_dwoper.f90 @@ -1,12 +1,12 @@ -module gsi_dwOper +module gsi_dwoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_dwOper +! subprogram: module gsi_dwoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for dwNode type +! abstract: an oboper extension for dwnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,49 +23,49 @@ module gsi_dwOper ! module interface: - use gsi_obOper, only: obOper - use m_dwNode , only: dwNode + use gsi_oboper, only: oboper + use m_dwnode , only: dwnode implicit none - public:: dwOper ! data stracture + public:: dwoper ! data stracture - type,extends(obOper):: dwOper + type,extends(oboper):: dwoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type dwOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type dwoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_dwOper' - type(dwNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_dwoper' + type(dwnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[dwOper]" + mytype="[dwoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use dw_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -77,7 +77,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(dwOper ), intent(inout):: self + class(dwoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -101,7 +101,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -110,11 +110,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intdwmod, only: intjo => intdw use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(dwOper ),intent(in ):: self + class(dwoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -123,11 +123,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -135,11 +135,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpdwmod, only: stpjo => stpdw use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(dwOper ),intent(in):: self + class(dwoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -152,11 +152,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_dwOper +end module gsi_dwoper diff --git a/src/gsi/gsi_enscouplermod.f90 b/src/gsi/gsi_enscouplermod.f90 index 6382b1e5b4..b59063ed57 100644 --- a/src/gsi/gsi_enscouplermod.f90 +++ b/src/gsi/gsi_enscouplermod.f90 @@ -1,15 +1,15 @@ !---------------------------------------------------------------------------- !BOP ! -! !MODULE: GSI_EnsCouplerMod --- +! !MODULE: gsi_enscouplermod --- ! ! !INTERFACE: -module GSI_EnsCouplerMod +module gsi_enscouplermod ! !USES: -use abstract_ensmod, only: abstractEnsemble +use abstract_ensmod, only: abstractensemble use gsi_bundlemod, only: gsi_bundle use mpeu_util, only: tell,warn implicit none @@ -17,36 +17,36 @@ module GSI_EnsCouplerMod ! !PUBLIC MEMBER FUNCTIONS: - public GSI_EnsCoupler_localization_grid - public GSI_EnsCoupler_get_user_ens - public GSI_EnsCoupler_get_user_Nens - public GSI_EnsCoupler_put_gsi_ens - public GSI_EnsCoupler_registry - public GSI_EnsCoupler_name - public GSI_EnsCoupler_create_sub2grid_info - public GSI_EnsCoupler_destroy_sub2grid_info + public gsi_enscoupler_localization_grid + public gsi_enscoupler_get_user_ens + public gsi_enscoupler_get_user_Nens + public gsi_enscoupler_put_gsi_ens + public gsi_enscoupler_registry + public gsi_enscoupler_name + public gsi_enscoupler_create_sub2grid_info + public gsi_enscoupler_destroy_sub2grid_info ! !INTERFACES: - interface GSI_EnsCoupler_localization_grid; module procedure non_gaussian_ens_grid_; end interface - interface GSI_EnsCoupler_get_user_ens; module procedure get_user_ens_; end interface - interface GSI_EnsCoupler_get_user_Nens; module procedure get_user_Nens_; end interface - interface GSI_EnsCoupler_put_gsi_ens; module procedure put_user_ens_; end interface + interface gsi_enscoupler_localization_grid; module procedure non_gaussian_ens_grid_; end interface + interface gsi_enscoupler_get_user_ens; module procedure get_user_ens_; end interface + interface gsi_enscoupler_get_user_Nens; module procedure get_user_Nens_; end interface + interface gsi_enscoupler_put_gsi_ens; module procedure put_user_ens_; end interface - interface GSI_EnsCoupler_registry ; module procedure typedef_ ; end interface - interface GSI_EnsCoupler_name; module procedure typename_; end interface - interface GSI_EnsCoupler_create_sub2grid_info ; module procedure create_s2gi; end interface - interface GSI_EnsCoupler_destroy_sub2grid_info; module procedure destroy_s2gi; end interface + interface gsi_enscoupler_registry ; module procedure typedef_ ; end interface + interface gsi_enscoupler_name; module procedure typename_; end interface + interface gsi_enscoupler_create_sub2grid_info ; module procedure create_s2gi; end interface + interface gsi_enscoupler_destroy_sub2grid_info; module procedure destroy_s2gi; end interface ! !CLASSES: - class(abstractEnsemble),allocatable,target,save:: typemold_ - class(abstractEnsemble),allocatable,target,save:: this_ensemble_ + class(abstractensemble),allocatable,target,save:: typemold_ + class(abstractensemble),allocatable,target,save:: this_ensemble_ ! This flag controls internal debugging messages. logical,parameter:: verbose=.false. !logical,parameter:: verbose=.true. - character(len=*),parameter:: myname='GSI_EnsCouplerMod' + character(len=*),parameter:: myname='gsi_enscouplermod' contains subroutine typedef_(mold) @@ -54,31 +54,31 @@ subroutine typedef_(mold) use stub_ensmod, only: stub_ensemble => ensemble implicit none - class(abstractEnsemble),optional,target,intent(in):: mold + class(abstractensemble),optional,target,intent(in):: mold character(len=*),parameter:: myname_=myname//'::typedef_' - class(abstractEnsemble),pointer:: pmold_ + class(abstractensemble),pointer:: pmold_ ! argument checking pmold_ => null() if(present(mold)) then - pmold_ => mold - if(.not.associated(pmold_)) & ! is argument _mold_ a null-object? - call warn(myname_,'a null argument (mold) is given. Will typedef to default') + pmold_ => mold + if(.not.associated(pmold_)) & ! is argument _mold_ a null-object? + call warn(myname_,'a null argument (mold) is given. Will typedef to default') endif ! reset current typemold if(allocated(typemold_)) then - if(verbose) call tell(myname_,'deallocating, typemold_%mytype() = '//typemold_%mytype()) - deallocate(typemold_) + if(verbose) call tell(myname_,'deallocating, typemold_%mytype() = '//typemold_%mytype()) + deallocate(typemold_) endif ! (re)allocate the new typemold_ if(associated(pmold_)) then - allocate(typemold_,mold=pmold_) - pmold_ => null() + allocate(typemold_,mold=pmold_) + pmold_ => null() else - allocate(stub_ensemble::typemold_) + allocate(stub_ensemble::typemold_) endif if(verbose) call tell(myname_,'allocated, typemold_%mytype() = '//typemold_%mytype()) end subroutine typedef_ @@ -86,90 +86,90 @@ end subroutine typedef_ function typename_() result(name) !-- Return the name of the current concrete multi-ensemble type. - use abstract_ensmod, only: abstractEnsemble_typename + use abstract_ensmod, only: abstractensemble_typename implicit none character(len=:),allocatable:: name ! return the type name - name=abstractEnsemble_typename() + name=abstractensemble_typename() if(allocated(typemold_)) name=typemold_%mytype() ! Note the use of typemold_, instead of this_ensemble_. end function typename_ - subroutine get_user_ens_(grd,member,ntindex,atm_bundle,iret) - use kinds, only: i_kind,r_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - implicit none -! Declare passed variables - type(sub2grid_info) ,intent(in ) :: grd - integer(i_kind) ,intent(in ) :: member - integer(i_kind) ,intent(in ) :: ntindex - type(gsi_bundle) ,intent(inout) :: atm_bundle - integer(i_kind) ,intent( out) :: iret - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%get_user_ens(grd,member,ntindex,atm_bundle,iret) - end subroutine get_user_ens_ - - subroutine get_user_Nens_(grd,members,ntindex,atm_bundle,iret) - use kinds, only: i_kind,r_kind - use gsi_bundlemod, only: gsi_bundle - use general_sub2grid_mod, only: sub2grid_info - implicit none -! Declare passed variables - type(sub2grid_info) ,intent(in ) :: grd - integer(i_kind) ,intent(in ) :: members - integer(i_kind) ,intent(in ) :: ntindex - type(gsi_bundle) ,intent(inout) :: atm_bundle(:) - integer(i_kind) ,intent( out) :: iret - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%get_user_Nens(grd,members,ntindex,atm_bundle,iret) - end subroutine get_user_Nens_ - - subroutine put_user_ens_(grd,member,ntindex,pert,iret) - use kinds, only: i_kind,r_kind - use general_sub2grid_mod, only: sub2grid_info - use gsi_bundlemod, only: gsi_bundle - implicit none -! Declare passed variables - type(sub2grid_info),intent(in ) :: grd - integer(i_kind), intent(in ) :: member - integer(i_kind), intent(in ) :: ntindex - type(gsi_bundle), intent(inout) :: pert - integer(i_kind), intent( out) :: iret - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%put_user_ens(grd,member,ntindex,pert,iret) - end subroutine put_user_ens_ - - subroutine non_gaussian_ens_grid_ (elats,elons) - use kinds, only: i_kind,r_kind - implicit none - real(r_kind),intent(out) :: elats(:),elons(:) - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%non_gaussian_ens_grid(elats,elons) - end subroutine non_gaussian_ens_grid_ - - subroutine ifn_alloc_() +subroutine get_user_ens_(grd,member,ntindex,atm_bundle,iret) + use kinds, only: i_kind,r_kind + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + integer(i_kind) ,intent(in ) :: member + integer(i_kind) ,intent(in ) :: ntindex + type(gsi_bundle) ,intent(inout) :: atm_bundle + integer(i_kind) ,intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%get_user_ens(grd,member,ntindex,atm_bundle,iret) +end subroutine get_user_ens_ + +subroutine get_user_nens_(grd,members,ntindex,atm_bundle,iret) + use kinds, only: i_kind,r_kind + use gsi_bundlemod, only: gsi_bundle + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info) ,intent(in ) :: grd + integer(i_kind) ,intent(in ) :: members + integer(i_kind) ,intent(in ) :: ntindex + type(gsi_bundle) ,intent(inout) :: atm_bundle(:) + integer(i_kind) ,intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%get_user_nens(grd,members,ntindex,atm_bundle,iret) +end subroutine get_user_nens_ + +subroutine put_user_ens_(grd,member,ntindex,pert,iret) + use kinds, only: i_kind,r_kind + use general_sub2grid_mod, only: sub2grid_info + use gsi_bundlemod, only: gsi_bundle + implicit none +! Declare passed variables + type(sub2grid_info),intent(in ) :: grd + integer(i_kind), intent(in ) :: member + integer(i_kind), intent(in ) :: ntindex + type(gsi_bundle), intent(inout) :: pert + integer(i_kind), intent( out) :: iret + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%put_user_ens(grd,member,ntindex,pert,iret) +end subroutine put_user_ens_ + +subroutine non_gaussian_ens_grid_ (elats,elons) + use kinds, only: i_kind,r_kind + implicit none + real(r_kind),intent(out) :: elats(:),elons(:) + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%non_gaussian_ens_grid(elats,elons) +end subroutine non_gaussian_ens_grid_ + +subroutine ifn_alloc_() !-- If-not-properly-allocated(this_ensemble_), do something - implicit none - class(abstractEnsemble),pointer:: pmold_ + implicit none + class(abstractensemble),pointer:: pmold_ ! First, check to make sure typemold_ is type-defined, at least to a ! default multi-ensemble type. - pmold_ => typemold_ - if(.not.associated(pmold_)) call typedef_() - pmold_ => null() + pmold_ => typemold_ + if(.not.associated(pmold_)) call typedef_() + pmold_ => null() ! Then, check and possibly instantiate this_ensemble_, which is must be ! typed the same as typemold_ - if(allocated(this_ensemble_)) then + if(allocated(this_ensemble_)) then if(same_type_as(typemold_,this_ensemble_)) return ! Everything seems good. ! Otherwise, this_ensemble_ must be re-intentiated with a different type. deallocate(this_ensemble_) - endif - allocate(this_ensemble_,mold=typemold_) - end subroutine ifn_alloc_ + endif + allocate(this_ensemble_,mold=typemold_) +end subroutine ifn_alloc_ ! !DESCRIPTION: This module provides general interface for ! ensemble capability @@ -184,28 +184,28 @@ end subroutine ifn_alloc_ !------------------------------------------------------------------------- subroutine create_s2gi(s2gi, nsig, npe, s2gi_ref) - use kinds, only: i_kind - use general_sub2grid_mod, only: sub2grid_info - implicit none -! Declare passed variables - type(sub2grid_info),intent( out) :: s2gi - integer(i_kind), intent(in ) :: nsig - integer(i_kind), intent(in ) :: npe - type(sub2grid_info),intent(in ) :: s2gi_ref - - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%create_sub2grid_info(s2gi, nsig,npe, s2gi_ref) + use kinds, only: i_kind + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info),intent( out) :: s2gi + integer(i_kind), intent(in ) :: nsig + integer(i_kind), intent(in ) :: npe + type(sub2grid_info),intent(in ) :: s2gi_ref + + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%create_sub2grid_info(s2gi, nsig,npe, s2gi_ref) return end subroutine create_s2gi subroutine destroy_s2gi(s2gi) - use general_sub2grid_mod, only: sub2grid_info - implicit none -! Declare passed variables - type(sub2grid_info),intent(inout) :: s2gi + use general_sub2grid_mod, only: sub2grid_info + implicit none +! Declare passed variables + type(sub2grid_info),intent(inout) :: s2gi - call ifn_alloc_() ! to ensure an allocated(this_ensemble_) - call this_ensemble_%destroy_sub2grid_info(s2gi) + call ifn_alloc_() ! to ensure an allocated(this_ensemble_) + call this_ensemble_%destroy_sub2grid_info(s2gi) return end subroutine destroy_s2gi -end module GSI_EnsCouplerMod +end module gsi_enscouplermod diff --git a/src/gsi/gsi_fixture_GFS.F90 b/src/gsi/gsi_fixture_gfs.f90 similarity index 78% rename from src/gsi/gsi_fixture_GFS.F90 rename to src/gsi/gsi_fixture_gfs.f90 index 3be63f5908..2b38e0f9e2 100644 --- a/src/gsi/gsi_fixture_GFS.F90 +++ b/src/gsi/gsi_fixture_gfs.f90 @@ -1,12 +1,12 @@ module gsi_fixture !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_fixture_GFS (but named as gsi_fixture) +! subprogram: module gsi_fixture_gfs (but named as gsi_fixture) ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2019-08-04 ! -! abstract: - configure GSI extensions for GFS global fixture. +! abstract: - configure gsi extensions for gfs global fixture. ! ! program history log: ! 2019-08-04 j guo - initial code @@ -27,7 +27,7 @@ module gsi_fixture ! module interface: implicit none - private ! except + private ! except public:: fixture_config ! fixture_config() is the interface to all configuration extension @@ -35,13 +35,13 @@ module gsi_fixture ! its exclusiveness. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_fixture_GFS' + character(len=*),parameter :: myname='gsi_fixture_gfs' contains subroutine fixture_config() -!> In a GFS fixture as it is, -!> - use GSI stub_timer -!> - use GSI get_gfs_ensmod_mod from cplr_gfs_ensmod.f90. +!> In a gfs fixture as it is, +!> - use gsi stub_timer +!> - use gsi get_gfs_ensmod_mod from cplr_gfs_ensmod.f90. !> singleton timermod and gsi_enscouplemod, which manage the actual timer and !> gfs_ensenble extentions. @@ -51,12 +51,12 @@ subroutine fixture_config() !> Define the actual extensions (timermod and gfs_ensemble) to be used. - use m_stubTimer , only: my_timer_mold => timer_typemold + use m_stubtimer , only: my_timer_mold => timer_typemold use get_gfs_ensmod_mod, only: my_ensemble_mold => ensemble_typemold implicit none -!> Fix up the extensions used by corresponding GSI singleton modules. +!> Fix up the extensions used by corresponding gsi singleton modules. call timer_typedef(my_timer_mold()) call ensemble_typedef(my_ensemble_mold()) diff --git a/src/gsi/gsi_fixture_REGIONAL.F90 b/src/gsi/gsi_fixture_regional.f90 similarity index 74% rename from src/gsi/gsi_fixture_REGIONAL.F90 rename to src/gsi/gsi_fixture_regional.f90 index 69e923e720..69832fd56a 100644 --- a/src/gsi/gsi_fixture_REGIONAL.F90 +++ b/src/gsi/gsi_fixture_regional.f90 @@ -1,12 +1,12 @@ module gsi_fixture !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_fixture_REGIONAL (but named as gsi_fixture) +! subprogram: module gsi_fixture_regional (but named as gsi_fixture) ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2019-08-04 ! -! abstract: - configure GSI extensions for a REGIONAL fixture. +! abstract: - configure gsi extensions for a regional fixture. ! ! program history log: ! 2019-08-04 j guo - initial code @@ -27,7 +27,7 @@ module gsi_fixture ! module interface: implicit none - private ! except + private ! except public:: fixture_config ! fixture_config() is the interface to all configuration extension @@ -35,16 +35,16 @@ module gsi_fixture ! its exclusiveness. !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_fixture_REGIONAL' + character(len=*),parameter :: myname='gsi_fixture_regional' contains subroutine fixture_config() -!> In a REGIONAL fixture as it is, -!> - use GSI stub_timer +!> In a regional fixture as it is, +!> - use gsi stub_timer !> - if (use_gfs_ens) then -!> use GSI get_gfs_ensmod_mod from cplr_gfs_ensmod.f90 +!> use gsi get_gfs_ensmod_mod from cplr_gfs_ensmod.f90 !> else -!> use GSI stub_ensmod from stub_ensmod.f90 +!> use gsi stub_ensmod from stub_ensmod.f90 !> endif !> singleton timermod and gsi_enscouplemod, which manage the actual timer and @@ -55,20 +55,20 @@ subroutine fixture_config() !> Define the actual extensions (timermod and gfs_ensemble) to be used. use hybrid_ensemble_parameters, only: use_gfs_ens - use m_stubTimer , only: my_timer_mold => timer_typemold + use m_stubtimer , only: my_timer_mold => timer_typemold use stub_ensmod , only: stub_ensemble_mold => ensemble_typemold use get_gfs_ensmod_mod, only: gfs_ensemble_mold => ensemble_typemold implicit none -!> Fix up the extensions used by corresponding GSI singleton modules. +!> Fix up the extensions used by corresponding gsi singleton modules. call timer_typedef(my_timer_mold()) if(use_gfs_ens) then - call ensemble_typedef( gfs_ensemble_mold()) + call ensemble_typedef( gfs_ensemble_mold()) else - call ensemble_typedef(stub_ensemble_mold()) + call ensemble_typedef(stub_ensemble_mold()) endif end subroutine fixture_config diff --git a/src/gsi/gsi_gpsbendOper.F90 b/src/gsi/gsi_gpsbendoper.f90 similarity index 70% rename from src/gsi/gsi_gpsbendOper.F90 rename to src/gsi/gsi_gpsbendoper.f90 index 66a0376055..46518b3471 100644 --- a/src/gsi/gsi_gpsbendOper.F90 +++ b/src/gsi/gsi_gpsbendoper.f90 @@ -1,12 +1,12 @@ -module gsi_gpsbendOper +module gsi_gpsbendoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_gpsbendOper +! subprogram: module gsi_gpsbendoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for gpsNode type +! abstract: an oboper extension for gpsnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_gpsbendOper ! module interface: - use gsi_obOper, only: obOper - use m_gpsNode, only: gpsNode + use gsi_oboper, only: oboper + use m_gpsnode, only: gpsnode implicit none - public:: gpsbendOper ! data stracture + public:: gpsbendoper ! data stracture - type,extends(obOper):: gpsbendOper + type,extends(oboper):: gpsbendoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type gpsbendOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gpsbendoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_gpsbendOper' - type(gpsNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_gpsbendoper' + type(gpsnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[gpsbendOper]" + mytype="[gpsbendoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use gpsbend_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: iwork => i_gps @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: perr,die implicit none - class(gpsbendOper), intent(inout):: self + class(gpsbendoper), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,awork(:,iwork),nele,nobs,toss_gps_sub,is,init_pass,last_pass,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intgpsmod, only: intjo => intgps use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(gpsbendOper),intent(in ):: self + class(gpsbendoper),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpgpsmod, only: stpjo => stpgps use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(gpsbendOper),intent(in):: self + class(gpsbendoper),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_gpsbendOper +end module gsi_gpsbendoper diff --git a/src/gsi/gsi_gpsrefOper.F90 b/src/gsi/gsi_gpsrefoper.f90 similarity index 69% rename from src/gsi/gsi_gpsrefOper.F90 rename to src/gsi/gsi_gpsrefoper.f90 index edadba119c..0f03836f76 100644 --- a/src/gsi/gsi_gpsrefOper.F90 +++ b/src/gsi/gsi_gpsrefoper.f90 @@ -1,12 +1,12 @@ -module gsi_gpsrefOper +module gsi_gpsrefoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_gpsrefOper +! subprogram: module gsi_gpsrefoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for gpsNode type +! abstract: an oboper extension for gpsnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_gpsrefOper ! module interface: - use gsi_gpsbendOper, only: gpsbendOper - use m_gpsNode, only: gpsNode + use gsi_gpsbendoper, only: gpsbendoper + use m_gpsnode, only: gpsnode implicit none - public:: gpsrefOper ! data stracture + public:: gpsrefoper ! data stracture - type,extends(gpsbendOper):: gpsrefOper + type,extends(gpsbendoper):: gpsrefoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type gpsrefOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gpsrefoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_gpsrefOper' - type(gpsNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_gpsrefoper' + type(gpsnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[gpsrefOper]" + mytype="[gpsrefoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use gpsref_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: iwork => i_gps @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: perr,die implicit none - class(gpsrefOper ), intent(inout):: self + class(gpsrefoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,21 +100,21 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,awork(:,iwork),nele,nobs,toss_gps_sub,is,init_pass,last_pass,diagsave) - return + return end subroutine setup_ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intgpsmod, only: intjo => intgps use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(gpsrefOper ),intent(in ):: self + class(gpsrefoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -123,11 +123,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -135,11 +135,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpgpsmod, only: stpjo => stpgps use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(gpsrefOper ),intent(in):: self + class(gpsrefoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -152,11 +152,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_gpsrefOper +end module gsi_gpsrefoper diff --git a/src/gsi/gsi_gustOper.F90 b/src/gsi/gsi_gustoper.f90 similarity index 70% rename from src/gsi/gsi_gustOper.F90 rename to src/gsi/gsi_gustoper.f90 index 522fa0da39..ae689537bb 100644 --- a/src/gsi/gsi_gustOper.F90 +++ b/src/gsi/gsi_gustoper.f90 @@ -1,12 +1,12 @@ -module gsi_gustOper +module gsi_gustoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_gustOper +! subprogram: module gsi_gustoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for gustNode type +! abstract: an oboper extension for gustnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_gustOper ! module interface: - use gsi_obOper, only: obOper - use m_gustNode, only: gustNode + use gsi_oboper, only: oboper + use m_gustnode, only: gustnode implicit none - public:: gustOper ! data stracture + public:: gustoper ! data stracture - type,extends(obOper):: gustOper + type,extends(oboper):: gustoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type gustOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type gustoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_gustOper' - type(gustNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_gustoper' + type(gustnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[gustOper]" + mytype="[gustoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use gust_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(gustOper ), intent(inout):: self + class(gustoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intgustmod, only: intjo => intgust use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(gustOper ),intent(in ):: self + class(gustoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpgustmod, only: stpjo => stpgust use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(gustOper ),intent(in):: self + class(gustoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_gustOper +end module gsi_gustoper diff --git a/src/gsi/gsi_howvOper.F90 b/src/gsi/gsi_howvoper.f90 similarity index 70% rename from src/gsi/gsi_howvOper.F90 rename to src/gsi/gsi_howvoper.f90 index ade0567007..13b1706bae 100644 --- a/src/gsi/gsi_howvOper.F90 +++ b/src/gsi/gsi_howvoper.f90 @@ -1,12 +1,12 @@ -module gsi_howvOper +module gsi_howvoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_howvOper +! subprogram: module gsi_howvoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for howvNode type +! abstract: an oboper extension for howvnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_howvOper ! module interface: - use gsi_obOper, only: obOper - use m_howvNode, only: howvNode + use gsi_oboper, only: oboper + use m_howvnode, only: howvnode implicit none - public:: howvOper ! data stracture + public:: howvoper ! data stracture - type,extends(obOper):: howvOper + type,extends(oboper):: howvoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type howvOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type howvoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_howvOper' - type(howvNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_howvoper' + type(howvnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[howvOper]" + mytype="[howvoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use howv_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(howvOper ), intent(inout):: self + class(howvoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use inthowvmod, only: intjo => inthowv use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(howvOper ),intent(in ):: self + class(howvoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stphowvmod, only: stpjo => stphowv use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(howvOper ),intent(in):: self + class(howvoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_howvOper +end module gsi_howvoper diff --git a/src/gsi/gsi_lcbasOper.F90 b/src/gsi/gsi_lcbasoper.f90 similarity index 70% rename from src/gsi/gsi_lcbasOper.F90 rename to src/gsi/gsi_lcbasoper.f90 index 329c478c4c..1b006d06ce 100644 --- a/src/gsi/gsi_lcbasOper.F90 +++ b/src/gsi/gsi_lcbasoper.f90 @@ -1,12 +1,12 @@ -module gsi_lcbasOper +module gsi_lcbasoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_lcbasOper +! subprogram: module gsi_lcbasoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for lcbasNode type +! abstract: an oboper extension for lcbasnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_lcbasOper ! module interface: - use gsi_obOper , only: obOper - use m_lcbasNode, only: lcbasNode + use gsi_oboper , only: oboper + use m_lcbasnode, only: lcbasnode implicit none - public:: lcbasOper ! data stracture + public:: lcbasoper ! data stracture - type,extends(obOper):: lcbasOper + type,extends(oboper):: lcbasoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type lcbasOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lcbasoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_lcbasOper' - type(lcbasNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_lcbasoper' + type(lcbasnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[lcbasOper]" + mytype="[lcbasoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use lcbas_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(lcbasOper ), intent(inout):: self + class(lcbasoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intlcbasmod, only: intjo => intlcbas use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(lcbasOper ),intent(in ):: self + class(lcbasoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stplcbasmod, only: stpjo => stplcbas use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(lcbasOper ),intent(in):: self + class(lcbasoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_lcbasOper +end module gsi_lcbasoper diff --git a/src/gsi/gsi_lightOper.F90 b/src/gsi/gsi_lightoper.f90 similarity index 60% rename from src/gsi/gsi_lightOper.F90 rename to src/gsi/gsi_lightoper.f90 index 54bd583f1c..05fd8232bb 100644 --- a/src/gsi/gsi_lightOper.F90 +++ b/src/gsi/gsi_lightoper.f90 @@ -1,12 +1,12 @@ -module gsi_lightOper +module gsi_lightoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_lightOper +! subprogram: module gsi_lightoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for lightNode type +! abstract: an oboper extension for lightnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,34 +23,34 @@ module gsi_lightOper ! module interface: - use gsi_obOper, only: obOper - use m_lightNode, only: lightNode + use gsi_oboper, only: oboper + use m_lightnode, only: lightnode use kinds , only: i_kind implicit none - public:: lightOper ! data stracture - public:: lightOper_config - interface lightOper_config; module procedure config_; end interface + public:: lightoper ! data stracture + public:: lightoper_config + interface lightoper_config; module procedure config_; end interface - type,extends(obOper):: lightOper + type,extends(oboper):: lightoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type lightOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lightoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_lightOper' - type(lightNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_lightoper' + type(lightnode),save,target:: mynodemold_ !> Configurations specific to this observation operator. - logical,parameter:: DEFAULT_USE_NSIG_SAVED_=.false. - logical ,save:: use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ + logical,parameter:: default_use_nsig_saved_=.false. + logical ,save:: use_nsig_saved_=default_use_nsig_saved_ integer(kind=i_kind),save:: nsig_saved_ -!> At gsi_obOpers coupling time, e.g. +!> At gsi_obopers coupling time, e.g. !> !> > call obopers_config() !> @@ -58,61 +58,61 @@ module gsi_lightOper !> !> > use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save !> > if (use_gfs_stratosphere) then -!> > call lightOper_config(nsig_save=nsig_save) +!> > call lightoper_config(nsig_save=nsig_save) !> > endif !> contains -subroutine config_(nsig_save,use_nsig_save) -!> config_() is the place to couple configurations external to -!> gsi_lwOper and gsi_obOper. Some of these external configurations will -!> gradually become obsolete through refactorings. + subroutine config_(nsig_save,use_nsig_save) + !> config_() is the place to couple configurations external to + !> gsi_lwoper and gsi_oboper. Some of these external configurations will + !> gradually become obsolete through refactorings. -!> call + !> call - implicit none - integer(i_kind),optional:: nsig_save ! set nsig_save if present - logical ,optional:: use_nsig_save ! switch the use of nsig_save - - logical:: reset_ - reset_=.true. - if(present(use_nsig_save)) then - use_nsig_saved_=use_nsig_save - reset_=.false. - endif - if(present( nsig_save)) then - nsig_saved_=nsig_save - use_nsig_saved_=.true. - reset_=.false. - endif - if(reset_) use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ -end subroutine config_ + implicit none + integer(i_kind),optional:: nsig_save ! set nsig_save if present + logical ,optional:: use_nsig_save ! switch the use of nsig_save + + logical:: reset_ + reset_=.true. + if(present(use_nsig_save)) then + use_nsig_saved_=use_nsig_save + reset_=.false. + endif + if(present( nsig_save)) then + nsig_saved_=nsig_save + use_nsig_saved_=.true. + reset_=.false. + endif + if(reset_) use_nsig_saved_=default_use_nsig_saved_ + end subroutine config_ !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[lightOper]" + mytype="[lightoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use light_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -124,7 +124,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(lightOper ), intent(inout):: self + class(lightoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -148,7 +148,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_light - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave,init_pass) end subroutine setup_ @@ -156,11 +156,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intlightmod, only: intjo => intlight use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(lightOper ),intent(in ):: self + class(lightoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -169,11 +169,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -181,11 +181,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stplightmod, only: stpjo => stplight use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(lightOper ),intent(in):: self + class(lightoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -198,11 +198,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_lightOper +end module gsi_lightoper diff --git a/src/gsi/gsi_lwcpOper.F90 b/src/gsi/gsi_lwcpoper.f90 similarity index 58% rename from src/gsi/gsi_lwcpOper.F90 rename to src/gsi/gsi_lwcpoper.f90 index 3c966b3731..45457b65fc 100644 --- a/src/gsi/gsi_lwcpOper.F90 +++ b/src/gsi/gsi_lwcpoper.f90 @@ -1,12 +1,12 @@ -module gsi_lwcpOper +module gsi_lwcpoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_lwcpOper +! subprogram: module gsi_lwcpoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for lwcpNode type +! abstract: an oboper extension for lwcpnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,34 +23,34 @@ module gsi_lwcpOper ! module interface: - use gsi_obOper, only: obOper - use m_lwcpNode, only: lwcpNode + use gsi_oboper, only: oboper + use m_lwcpnode, only: lwcpnode use kinds , only: i_kind implicit none - public:: lwcpOper ! data stracture - public:: lwcpOper_config - interface lwcpOper_config; module procedure config_; end interface + public:: lwcpoper ! data stracture + public:: lwcpoper_config + interface lwcpoper_config; module procedure config_; end interface - type,extends(obOper):: lwcpOper + type,extends(oboper):: lwcpoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type lwcpOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type lwcpoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_lwcpOper' - type(lwcpNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_lwcpoper' + type(lwcpnode),save,target:: mynodemold_ !> Configurations specific to this observation operator. - logical,parameter:: DEFAULT_USE_NSIG_SAVED_=.false. - logical ,save:: use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ + logical,parameter:: default_use_nsig_saved_=.false. + logical ,save:: use_nsig_saved_=default_use_nsig_saved_ integer(kind=i_kind),save:: nsig_saved_ -!> At gsi_obOpers coupling time, e.g. +!> At gsi_obopers coupling time, e.g. !> !> > call obopers_config() !> @@ -58,61 +58,61 @@ module gsi_lwcpOper !> !> > use gfs_stratosphere, only: use_gfs_stratosphere, nsig_save !> > if (use_gfs_stratosphere) then -!> > call lwcpOper_config(nsig_save=nsig_save) +!> > call lwcpoper_config(nsig_save=nsig_save) !> > endif !> contains -subroutine config_(nsig_save,use_nsig_save) -!> config_() is the place to couple configurations external to -!> gsi_lwOper and gsi_obOper. Some of these external configurations will -!> gradually become obsolete through refactorings. + subroutine config_(nsig_save,use_nsig_save) + !> config_() is the place to couple configurations external to + !> gsi_lwoper and gsi_oboper. Some of these external configurations will + !> gradually become obsolete through refactorings. -!> call + !> call - implicit none - integer(i_kind),optional:: nsig_save ! set nsig_save if present - logical ,optional:: use_nsig_save ! switch the use of nsig_save - - logical:: reset_ - reset_=.true. - if(present(use_nsig_save)) then - use_nsig_saved_=use_nsig_save - reset_=.false. - endif - if(present( nsig_save)) then - nsig_saved_=nsig_save - use_nsig_saved_=.true. - reset_=.false. - endif - if(reset_) use_nsig_saved_=DEFAULT_USE_NSIG_SAVED_ -end subroutine config_ + implicit none + integer(i_kind),optional:: nsig_save ! set nsig_save if present + logical ,optional:: use_nsig_save ! switch the use of nsig_save + + logical:: reset_ + reset_=.true. + if(present(use_nsig_save)) then + use_nsig_saved_=use_nsig_save + reset_=.false. + endif + if(present( nsig_save)) then + nsig_saved_=nsig_save + use_nsig_saved_=.true. + reset_=.false. + endif + if(reset_) use_nsig_saved_=default_use_nsig_saved_ + end subroutine config_ !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[lwcpOper]" + mytype="[lwcpoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use lwcp_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -124,7 +124,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(lwcpOper ), intent(inout):: self + class(lwcpoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -149,12 +149,12 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv if(use_nsig_saved_) then - call setup(self%obsLL(:), self%odiagLL(:), & - lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave, & - nsig_saved=nsig_saved_) + call setup(self%obsll(:), self%odiagll(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave, & + nsig_saved=nsig_saved_) else - call setup(self%obsLL(:), self%odiagLL(:), & - lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) + call setup(self%obsll(:), self%odiagll(:), & + lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) endif end subroutine setup_ @@ -163,11 +163,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intlwcpmod, only: intjo => intlwcp use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(lwcpOper ),intent(in ):: self + class(lwcpoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -176,11 +176,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -188,11 +188,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stplwcpmod, only: stpjo => stplwcp use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(lwcpOper ),intent(in):: self + class(lwcpoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -205,11 +205,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_lwcpOper +end module gsi_lwcpoper diff --git a/src/gsi/gsi_metguess_mod.F90 b/src/gsi/gsi_metguess_mod.F90 index d6d741426b..24083ebb62 100644 --- a/src/gsi/gsi_metguess_mod.F90 +++ b/src/gsi/gsi_metguess_mod.F90 @@ -1,6 +1,6 @@ !BOI -! !TITLE: GSI\_MetGuess\_Mod: A GSI Bundle to handle Guess Fields +! !TITLE: gsi\_metguess\_mod: A gsi bundle to handle guess fields ! !AUTHORS: Ricardo Todling @@ -11,51 +11,51 @@ ! !INTRODUCTION: Overview #ifdef __PROTEX__ -This module defines the so-called GSI\_MetGuess\_Bundle. Its main purpose is to -allow GSI to ingest guess fields other than those pre-set in guess\_grids, -refered to here as Meteorological Guess. +This module defines the so-called gsi\_metguess\_bundle. Its main purpose is to +allow gsi to ingest guess fields other than those pre-set in guess\_grids, +refered to here as meteorological guess. Eventually it would be nice to see all guess fields defined via the present module, and a complete revamp of guess\_grids. This is aimed at for example extending the -current ability to run GSI for say analyzing a single field, such as Ozone, and -only have to bring in the necessary background fields, such Ozone it self when +current ability to run gsi for say analyzing a single field, such as ozone, and +only have to bring in the necessary background fields, such ozone it self when temperature interdependencies are neglected. \begin{center} -\fbox{MetGuess Bundle is a way to ingest Meterological Guess (background fields) into GSI} +\fbox{Metguess bundle is a way to ingest meterological guess (background fields) into gsi} \end{center} -Before the introduction of this module, all guess fields entered GSI through the +Before the introduction of this module, all guess fields entered gsi through the and the wired-in arrays ges\_x, with x standing for particular fields, defined in the guess\_grids module, e.g., ges\_u, ges\_tv, and so on. This becomes cumbersome the -more one wants to add new features to GSI. Chemistry-related fields -- aerosols and trace gases -- are -already handled separately from guess\_grids using GSI\_ChemBundle. The present +more one wants to add new features to gsi. Chemistry-related fields -- aerosols and trace gases -- are +already handled separately from guess\_grids using gsi\_chembundle. The present modules extends this capability to any new guess field. \begin{center} -\fbox{MetGuess\_Bundle is a GSI\_Bundle} +\fbox{Metguess\_bundle is a gsi\_bundle} \end{center} -The GSI\_MetGuess\_Bundle uses the GSI\_Bundle. But while the state and control vectors -use the GSI\_Bundle to associate fields used by the observation operator and -those used in the cost function, respectively, the GSI\_MetGuess\_Bundle -is simply aimed at allowing gather together Guess fields in a flexible way. Just +The gsi\_metguess\_bundle uses the gsi\_bundle. But while the state and control vectors +use the gsi\_bundle to associate fields used by the observation operator and +those used in the cost function, respectively, the gsi\_metguess\_bundle +is simply aimed at allowing gather together guess fields in a flexible way. Just as with the bundle, all parallel distribution must have already been done before -filling in the fields in the bundle, that is, GSI\_MetGuess\_Bundle does not +filling in the fields in the bundle, that is, gsi\_metguess\_bundle does not handle distribution. -As guess\_grids does, this module still treats the Meteorological Guess fields -as in a common-block-like structure. That is, the GSI\_Bundle defined here to hold the -Meteorological Guess fields is an internally defined type that cannot be passed +As guess\_grids does, this module still treats the meteorological guess fields +as in a common-block-like structure. That is, the gsi\_bundle defined here to hold the +meteorological guess fields is an internally defined type that cannot be passed around; cannot be instanciated. This will change in the future, but for the time being this is the simplest thing to do given the current code design. This is -identical to what is done in defining the GSI\_ChemBundle. +identical to what is done in defining the gsi\_chembundle. \begin{center} -\fbox{MetGuess Bundle Module provides an (almost) opaque access to its entries} +\fbox{Metguess bundle module provides an (almost) opaque access to its entries} \end{center} One of the ideas behind this module is that it defines an opaque-like object. -That is, functions related to contents of the MetGuess Bundle should only be +That is, functions related to contents of the metguess bundle should only be extracted via inquires using a ``get-like'' procedures. This is why, only ``methods'' are made public to this module, that is, @@ -67,17 +67,17 @@ public :: gsi_metguess_final \end{verbatim} -and never the variables themselves; the only exception being the GSI\_MetGuess\_Bundle itself +and never the variables themselves; the only exception being the gsi\_metguess\_bundle itself (until it is no longer treated as a common-block). Some of the public methods above are overloaded and all have internal interfaces (name of which appears in the index of this protex document. It should be a rule here that any new routine to be made public should have a declared interface procedure. \begin{center} -\fbox{MetGuess\_Bundle is defined via the {\it met\_guess} table in a resource file} +\fbox{Metguess\_bundle is defined via the {\it met\_guess} table in a resource file} \end{center} -\underline{Defining the MetGuess\_Bundle} is done via the table {\it met\_guess}, usually +\underline{Defining the metguess\_bundle} is done via the table {\it met\_guess}, usually embedded in the {\it anavinfo} file. An example of such table follows: \begin{verbatim} met_guess:: @@ -87,37 +87,37 @@ :: \end{verbatim} -As usual, this table follows INPAK/ESMF convention, begining with a name +As usual, this table follows inpak/esmf convention, begining with a name (met\_guess), followed by double colons (::), and ending with double colons. Any line starting with an exclamation mark or a pound sign is taken as a comment. The current {\it met\_guess} table has five columns defined as follows: \begin{verbatim} -Column 1: variable name - refers to internally known GSI variable name +Column 1: variable name - refers to internally known gsi variable name Column 2: indicates number of levels (used to distinguish between 2d and 3d fields) -Column 3: indicates whether variable is to be passed to CRTM or not according to +Column 3: indicates whether variable is to be passed to crtm or not according to the following scheme: - if<0 general variable; not used in CRTM - if=0 general variable; use prescribed global mean data to affect CRTM - if=1 general variable; use variable in guess field to affect CRTM + if<0 general variable; not used in crtm + if=0 general variable; use prescribed global mean data to affect crtm + if=1 general variable; use variable in guess field to affect crtm Column 4: description of variable (defined by user) Column 5: user-defined variable name associated with name read in from file \end{verbatim} \begin{center} -\fbox{Examples of extracting information related to the MetGuess\_Bundle} +\fbox{Examples of extracting information related to the metguess\_bundle} \end{center} -\underline{Examples} of accessing information related to fields in the MetGuess\_Bundle. +\underline{Examples} of accessing information related to fields in the metguess\_bundle. \begin{enumerate} \item Say a routine wants to whether or not the variable ``cw'' is in - MetGuess\_Bundle. This can be done simply with the call + metguess\_bundle. This can be done simply with the call \begin{verbatim} call gsi_metguess_get ( 'var::cw', ivar, ier ) \end{verbatim} if ivar is grater than zero, the variable is present in the bundle. -\item Say a routine wants to know how $qi$ is to be used in CRTM. +\item Say a routine wants to know how $qi$ is to be used in crtm. This is done via the {\it i4crtm::} tag, as in: \begin{verbatim} call gsi_metguess_get ( 'i4crtm::qi', iqi, ier ) @@ -126,7 +126,7 @@ scheme laid out for entries in column 3 of the resource file (anavinfo). \item Say a routine wants to get the number of all 3d cloud fields in the - MetGuess\_Bundle, this can use the tag {\it clouds::3d}, as in: + metguess\_bundle, this can use the tag {\it clouds::3d}, as in: \begin{verbatim} call gsi_metguess_get ( 'clouds::3d',n,ier ) \end{verbatim} @@ -148,7 +148,7 @@ prologue description of the {it get} routines. \begin{center} -\fbox{Conventions and Remarks} +\fbox{Conventions and remarks} \end{center} \underline{Conventions} proposed for entries in this module: @@ -162,10 +162,10 @@ A general remark about the correct {\it met\_guess} table: it is recognized that the format for general specification related to specific entries in the table is not general enough. A better approach is the one used by the Registry used in -GEOS-5 GOCART where a table exists to control a particular functionality +geos-5 gocart where a table exists to control a particular functionality applicable to a certain set of constituents. For example, use of a variable in CRTM could be control instead by a specific table listing constituents to be -used in the CRTM and at what extent, for example, a table of the form: +used in the crtm and at what extent, for example, a table of the form: \begin{verbatim} use_in_crtm:: !var use @@ -185,7 +185,7 @@ !------------------------------------------------------------------------- !BOP ! -! !MODULE: GSI_MetGuess_Mod -- Implements Meteorological Guess for GSI +! !MODULE: gsi_metguess_mod -- Implements meteorological guess for gsi ! ! !INTERFACE: @@ -196,7 +196,7 @@ module gsi_metguess_mod ! we'll generalize this. ! ! !REMARKS: -! 1. VERY IMPORTANT: No object from this file is to be make +! 1. Very Important: No object from this file is to be make ! explicitly available to the outside world. ! Each object must be opaque with a get and ! a put method associated with it. @@ -211,14 +211,14 @@ module gsi_metguess_mod use mpimod, only : mype use mpeu_util,only: die use file_utility, only : get_lun -use gsi_bundlemod, only : GSI_BundleCreate -use gsi_bundlemod, only : GSI_BundleGetPointer -use gsi_bundlemod, only : GSI_Bundle -use gsi_bundlemod, only : GSI_BundlePrint -use gsi_bundlemod, only : GSI_BundleDestroy +use gsi_bundlemod, only : gsi_bundlecreate +use gsi_bundlemod, only : gsi_bundlegetpointer +use gsi_bundlemod, only : gsi_bundle +use gsi_bundlemod, only : gsi_bundleprint +use gsi_bundlemod, only : gsi_bundledestroy -use gsi_bundlemod, only : GSI_Grid -use gsi_bundlemod, only : GSI_GridCreate +use gsi_bundlemod, only : gsi_grid +use gsi_bundlemod, only : gsi_gridcreate use mpeu_util, only: gettablesize use mpeu_util, only: gettable @@ -236,31 +236,31 @@ module gsi_metguess_mod public :: gsi_metguess_get public :: gsi_metguess_final -public :: GSI_MetGuess_Bundle ! still a common for now, ultimately should +public :: gsi_metguess_bundle ! still a common for now, ultimately should ! be a dynamic "type", passed around in arg list ! !INTERFACE: interface gsi_metguess_init - module procedure init_ + module procedure init_ end interface interface gsi_metguess_final - module procedure final_ + module procedure final_ end interface interface gsi_metguess_create_grids - module procedure create_ + module procedure create_ end interface interface gsi_metguess_destroy_grids - module procedure destroy_ + module procedure destroy_ end interface interface gsi_metguess_get - module procedure get_int0d_ - module procedure get_int1d_ - module procedure get_char0d_ - module procedure get_char1d_ + module procedure get_int0d_ + module procedure get_int1d_ + module procedure get_char0d_ + module procedure get_char1d_ end interface -type(GSI_Bundle),pointer :: GSI_MetGuess_Bundle(:) ! still a common block for now +type(gsi_bundle),pointer :: gsi_metguess_bundle(:) ! still a common block for now ! !REVISION HISTORY: @@ -273,7 +273,7 @@ module gsi_metguess_mod ! !PRIVATE ROUTINES: !BOC -integer(i_kind),parameter::MAXSTR=max_varname_length +integer(i_kind),parameter::maxstr=max_varname_length logical:: guess_grid_initialized_=.false. logical:: guess_initialized_=.false. character(len=*), parameter :: myname = 'gsi_metguess_mod' @@ -285,17 +285,17 @@ module gsi_metguess_mod integer(i_kind) :: n3dcloud=0 integer(i_kind) :: ng3d=-1 integer(i_kind) :: ng2d=-1 -character(len=MAXSTR),allocatable :: mguess(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: mguess3d(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: mguess2d(:) ! same as list above, but each var as element of array -character(len=MAXSTR),allocatable :: metstype(:) ! indicate type of meteorological field -character(len=MAXSTR),allocatable :: metsty3d(:) ! indicate 3d type of met-guess -character(len=MAXSTR),allocatable :: metsty2d(:) ! indicate 3d type of met-guess -character(len=MAXSTR),allocatable :: usrname2d(:) ! user-defined 2d field names -character(len=MAXSTR),allocatable :: usrname3d(:) ! user-defined 3d field names -character(len=MAXSTR),allocatable :: usrname(:) ! user-defined field names -integer(i_kind),allocatable,dimension(:) :: i4crtm ! controls use of gas in CRTM: - ! < 0 don't use in CRTM +character(len=maxstr),allocatable :: mguess(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: mguess3d(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: mguess2d(:) ! same as list above, but each var as element of array +character(len=maxstr),allocatable :: metstype(:) ! indicate type of meteorological field +character(len=maxstr),allocatable :: metsty3d(:) ! indicate 3d type of met-guess +character(len=maxstr),allocatable :: metsty2d(:) ! indicate 3d type of met-guess +character(len=maxstr),allocatable :: usrname2d(:) ! user-defined 2d field names +character(len=maxstr),allocatable :: usrname3d(:) ! user-defined 3d field names +character(len=maxstr),allocatable :: usrname(:) ! user-defined field names +integer(i_kind),allocatable,dimension(:) :: i4crtm ! controls use of gas in crtm: + ! < 0 don't use in crtm ! = 0 use predefined global mean ! = 1 use gfs yearly global annual mean historical value ! = 2 use gfs 3d background field @@ -313,7 +313,7 @@ module gsi_metguess_mod !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: init_ --- Initialize MetGuess Bundle (read resource table); alloc internal +! !IROUTINE: init_ --- Initialize metguess bundle (read resource table); alloc internal ! ! !INTERFACE: ! @@ -321,8 +321,8 @@ subroutine init_ (iamroot) ! USES: implicit none ! !INPUT PARAMETER: - logical,optional,intent(in) :: iamroot -! !DESCRIPTION: Define contents of Meteorological Guess Bundle through rc +logical,optional,intent(in) :: iamroot +! !DESCRIPTION: Define contents of meteorological guess bundle through rc ! file (typilcally embedded in anavinfo text file. ! ! !REVISION HISTORY: @@ -405,8 +405,8 @@ subroutine init_ (iamroot) usrname2d(ng2d)) end if - allocate(levels(nmguess),i4crtm(nmguess),usrname(nmguess),& - mguess(nmguess),metstype(nmguess)) +allocate(levels(nmguess),i4crtm(nmguess),usrname(nmguess),& + mguess(nmguess),metstype(nmguess)) ! Now load information from table ng3d=0;ng2d=0 @@ -475,14 +475,14 @@ end subroutine init_ !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: final_ --- Deallocate internal MetGuess Bundle info arrays +! !IROUTINE: final_ --- Deallocate internal metguess bundle info arrays ! ! !INTERFACE: ! subroutine final_ implicit none -! !DESCRIPTION: Dealloc grids holding trace gases +! !DESCRIPTION: Dealloc grids holding meteorological guess fields ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -525,22 +525,22 @@ end subroutine final_ ! ! !INTERFACE: ! -!!subroutine create_(GSI_MetGuess_Bundle,im,jm,km,lm,istatus) ! ultimately - subroutine create_(im,jm,km,lm,istatus) +!!subroutine create_(gsi_metguess_bundle,im,jm,km,lm,istatus) ! ultimately +subroutine create_(im,jm,km,lm,istatus) ! !USES: - use constants,only: zero - implicit none +use constants,only: zero +implicit none ! !INPUT PARAMETERS: - integer(i_kind),intent(in)::im,jm,km,lm +integer(i_kind),intent(in)::im,jm,km,lm ! !OUTPUT PARAMETERS: - integer(i_kind),intent(out)::istatus +integer(i_kind),intent(out)::istatus ! !INPUT/OUTPUT PARAMETERS: -!! type(GSI_Bundle) :: GSI_MetGuess_Bundle +!! type(gsi_bundle) :: gsi_metguess_bundle ! !DESCRIPTION: allocate grids to hold guess cloud fields ! @@ -558,40 +558,40 @@ subroutine create_(im,jm,km,lm,istatus) !------------------------------------------------------------------------- !BOC - character(len=*), parameter :: myname_ = myname//'*create_' - integer(i_kind) nt,ier - type(GSI_Grid):: grid +character(len=*), parameter :: myname_ = myname//'*create_' +integer(i_kind) nt,ier +type(gsi_grid):: grid - istatus=0 - if(nmguess<=0) return +istatus=0 +if(nmguess<=0) return - if(guess_grid_initialized_) return +if(guess_grid_initialized_) return -! Create simple regular grid - call gsi_gridcreate ( grid, im, jm, km ) +! Create simple regular grid +call gsi_gridcreate ( grid, im, jm, km ) - nbundles = lm - allocate(GSI_MetGuess_Bundle(nbundles)) - do nt=1,nbundles - call GSI_BundleCreate ( GSI_MetGuess_Bundle(nt), grid, 'Meteo Guess', ier, & - names3d=mguess3d,names2d=mguess2d,levels=levels3d,& - bundle_kind=r_kind ) - istatus=istatus+ier - enddo +nbundles = lm +allocate(gsi_metguess_bundle(nbundles)) +do nt=1,nbundles + call gsi_bundlecreate ( gsi_metguess_bundle(nt), grid, 'Meteo Guess', ier, & + names3d=mguess3d,names2d=mguess2d,levels=levels3d,& + bundle_kind=r_kind ) + istatus=istatus+ier +enddo - if (istatus/=0) then - if(mype==0) write(6,*)trim(myname_),': allocate error1, istatus=',& - istatus,im,jm,km,lm - return - endif +if (istatus/=0) then + if(mype==0) write(6,*)trim(myname_),': allocate error1, istatus=',& + istatus,im,jm,km,lm + return +endif - if (verbose_) then - if(mype==0) write(6,*) trim(myname_),': alloc() for met-guess done' - endif - guess_grid_initialized_=.true. +if (verbose_) then + if(mype==0) write(6,*) trim(myname_),': alloc() for met-guess done' +endif +guess_grid_initialized_=.true. - return - end subroutine create_ +return +end subroutine create_ !EOC !------------------------------------------------------------------------- @@ -601,19 +601,19 @@ end subroutine create_ ! ! !INTERFACE: ! -!!subroutine destroy_ (GSI_MetGuess_Bundle, istatus) ! ultimately - subroutine destroy_ (istatus) +!!subroutine destroy_ (gsi_metguess_bundle, istatus) ! ultimately +subroutine destroy_ (istatus) ! !USES: - implicit none +implicit none ! !INPUT PARAMETERS: ! !OUTPUT PARAMETERS: - integer(i_kind), intent(out) :: istatus +integer(i_kind), intent(out) :: istatus -! !INPPUT/OUTPUT PARAMETERS: -!! type(GSI_Bundle) :: GSI_MetGuess_Bundle +! !INPUT/OUTPUT PARAMETERS: +!! type(gsi_bundle) :: gsi_metguess_bundle ! !DESCRIPTION: Dealloc grids holding for meteorological guess ! @@ -631,31 +631,31 @@ subroutine destroy_ (istatus) !------------------------------------------------------------------------- !BOC - character(len=*), parameter :: myname_ = myname//'*destroy_' - integer(i_kind) :: nt,ier +character(len=*), parameter :: myname_ = myname//'*destroy_' +integer(i_kind) :: nt,ier - istatus=0 - if(.not.guess_grid_initialized_) return +istatus=0 +if(.not.guess_grid_initialized_) return - do nt=1,nbundles - call GSI_BundleDestroy ( GSI_MetGuess_Bundle(nt), ier ) - istatus=istatus+ier - enddo - deallocate(GSI_MetGuess_Bundle,stat=istatus) - istatus=istatus+ier +do nt=1,nbundles + call gsi_bundledestroy ( gsi_metguess_bundle(nt), ier ) + istatus=istatus+ier +enddo +deallocate(gsi_metguess_bundle,stat=istatus) +istatus=istatus+ier - if (istatus/=0) then - if(mype==0) write(6,*)trim(myname_),': deallocate error1, istatus=',istatus - return - endif +if (istatus/=0) then + if(mype==0) write(6,*)trim(myname_),': deallocate error1, istatus=',istatus + return +endif - if (verbose_) then - if(mype==0) write(6,*) trim(myname_),': dealloc() for met-guess done' - endif - guess_grid_initialized_=.false. +if (verbose_) then + if(mype==0) write(6,*) trim(myname_),': dealloc() for met-guess done' +endif +guess_grid_initialized_=.false. - return - end subroutine destroy_ +return +end subroutine destroy_ !EOC ! ---------------------------------------------------------- @@ -668,21 +668,21 @@ end subroutine destroy_ ! !IROUTINE: get_int0d_ --- inquire rank-0 integer ! ! !INTERFACE: - subroutine get_int0d_ ( desc, ivar, istatus ) +subroutine get_int0d_ ( desc, ivar, istatus ) ! !USES: - implicit none +implicit none ! ! !DESCRIPTION: Rank-0 integer inquire routine; integer mnemonics: ! \begin{verbatim} ! Known mnemonics retrieve ! --------------- -------- ! dim total number of meteorological guesses -! i4crtm::XXX information related to CRTM usage of gas XXX -! var::XXX index of gas XXX in met-bundle +! i4crtm::xxx information related to crtm usage of gas xxx +! var::xxx index of gas xxx in met-bundle ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. +! where xxx represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -698,63 +698,63 @@ subroutine get_int0d_ ( desc, ivar, istatus ) !EOP !------------------------------------------------------------------------- !BOC - character(len=*),intent(in):: desc - integer(i_kind),intent(out):: ivar - integer(i_kind),intent(out):: istatus - character(len=*),parameter:: myname_=myname//"*get_int0d_" - character(len=MAXSTR):: work - integer(i_kind) ii,id,ln - istatus=1 - ivar=0 - if(.not.guess_initialized_) return - if(trim(desc)=='dim') then - ivar = nmguess - istatus=0 - else if(trim(desc)=='clouds') then - ivar = ncloud - istatus=0 - else if(trim(desc)=='clouds::3d') then - ivar = n3dcloud - istatus=0 - else if(trim(desc)=='clouds::2d') then - ivar = n2dcloud - istatus=0 - else if(trim(desc)=='meteo_4crtm_jac::3d') then - do ii=1,ng3d - if (i4crtm3d(ii)==2) ivar=ivar+1 - enddo - istatus=0 - else if(trim(desc)=='clouds_4crtm_jac::3d') then - do ii=1,ng3d - if (i4crtm3d(ii)==12) ivar=ivar+1 - enddo - istatus=0 - else if(trim(desc)=='clouds_4crtm_fwd::3d') then - do ii=1,ng3d - if (i4crtm3d(ii)>10) ivar=ivar+1 - enddo - istatus=0 - else if(index(trim(desc),'i4crtm::')/=0) then - ln=len_trim(desc) - work=desc(9:ln) - if(allocated(mguess)) then - id=getindex(mguess,trim(work)) - if(id>0) ivar=i4crtm(id) - else - ivar=0 - endif - istatus=0 - else if(desc(1:5)=='var::') then - if(allocated(mguess)) then - id=len_trim(desc) - if(id>=6) ivar=getindex(mguess,desc(6:id)) - endif - istatus=0 - else - call die(myname_,'label unavailable :'//trim(desc),99) - endif - return - end subroutine get_int0d_ +character(len=*),intent(in):: desc +integer(i_kind),intent(out):: ivar +integer(i_kind),intent(out):: istatus +character(len=*),parameter:: myname_=myname//"*get_int0d_" +character(len=maxstr):: work +integer(i_kind) ii,id,ln +istatus=1 +ivar=0 +if(.not.guess_initialized_) return +if(trim(desc)=='dim') then + ivar = nmguess + istatus=0 +else if(trim(desc)=='clouds') then + ivar = ncloud + istatus=0 +else if(trim(desc)=='clouds::3d') then + ivar = n3dcloud + istatus=0 +else if(trim(desc)=='clouds::2d') then + ivar = n2dcloud + istatus=0 +else if(trim(desc)=='meteo_4crtm_jac::3d') then + do ii=1,ng3d + if (i4crtm3d(ii)==2) ivar=ivar+1 + enddo + istatus=0 +else if(trim(desc)=='clouds_4crtm_jac::3d') then + do ii=1,ng3d + if (i4crtm3d(ii)==12) ivar=ivar+1 + enddo + istatus=0 +else if(trim(desc)=='clouds_4crtm_fwd::3d') then + do ii=1,ng3d + if (i4crtm3d(ii)>10) ivar=ivar+1 + enddo + istatus=0 +else if(index(trim(desc),'i4crtm::')/=0) then + ln=len_trim(desc) + work=desc(9:ln) + if(allocated(mguess)) then + id=getindex(mguess,trim(work)) + if(id>0) ivar=i4crtm(id) + else + ivar=0 + endif + istatus=0 +else if(desc(1:5)=='var::') then + if(allocated(mguess)) then + id=len_trim(desc) + if(id>=6) ivar=getindex(mguess,desc(6:id)) + endif + istatus=0 +else + call die(myname_,'label unavailable :'//trim(desc),99) +endif +return +end subroutine get_int0d_ !EOC !------------------------------------------------------------------------- !BOP @@ -762,10 +762,10 @@ end subroutine get_int0d_ ! !IROUTINE: get_int1d_ --- inquire rank-1 integer ! ! !INTERFACE: - subroutine get_int1d_ ( desc, ivar, istatus ) +subroutine get_int1d_ ( desc, ivar, istatus ) ! !USES: - implicit none +implicit none ! ! !DESCRIPTION: Rank-1 integer inquire routine; integer mnemonics: ! \begin{verbatim} @@ -775,7 +775,6 @@ subroutine get_int1d_ ( desc, ivar, istatus ) ! clouds_level::3d levels of all 3d clouds ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2011-05-17 todling initial code @@ -791,49 +790,49 @@ subroutine get_int1d_ ( desc, ivar, istatus ) !EOP !------------------------------------------------------------------------- !BOC - character(len=*),intent(in):: desc - integer(i_kind),intent(out):: ivar(:) - integer(i_kind),intent(out):: istatus - character(len=*),parameter:: myname_=myname//"*get_int1d_" - integer(i_kind) i,ii - logical labfound - labfound=.false. - istatus=1 - ivar=0 - if(.not.guess_initialized_) return - if(trim(desc)=='guesses_level') then - labfound=.true. - do i=1,nmguess - ivar(i)=levels(i) - enddo - istatus=0 - endif - if(trim(desc)=='clouds_level') then - labfound=.true. - ii=0 - do i=1,nmguess - if(i4crtm(i)>=10.and.i4crtm(i)<20) then - ii=ii+1 - ivar(ii)=levels(i) - endif - enddo - if(ii>0) istatus=0 - endif - if(trim(desc)=='clouds_level::3d') then - labfound=.true. - ii=0 - do i=1,ng3d - if(i4crtm3d(i)>=10.and.i4crtm3d(i)<20) then - ii=ii+1 - ivar(ii)=levels3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - if (.not.labfound) then - call die(myname_,'label unavailable :'//trim(desc),99) - endif - end subroutine get_int1d_ +character(len=*),intent(in):: desc +integer(i_kind),intent(out):: ivar(:) +integer(i_kind),intent(out):: istatus +character(len=*),parameter:: myname_=myname//"*get_int1d_" +integer(i_kind) i,ii +logical labfound +labfound=.false. +istatus=1 +ivar=0 +if(.not.guess_initialized_) return +if(trim(desc)=='guesses_level') then + labfound=.true. + do i=1,nmguess + ivar(i)=levels(i) + enddo + istatus=0 +endif +if(trim(desc)=='clouds_level') then + labfound=.true. + ii=0 + do i=1,nmguess + if(i4crtm(i)>=10.and.i4crtm(i)<20) then + ii=ii+1 + ivar(ii)=levels(i) + endif + enddo + if(ii>0) istatus=0 +endif +if(trim(desc)=='clouds_level::3d') then + labfound=.true. + ii=0 + do i=1,ng3d + if(i4crtm3d(i)>=10.and.i4crtm3d(i)<20) then + ii=ii+1 + ivar(ii)=levels3d(i) + endif + enddo + if(ii>0) istatus=0 +endif +if (.not.labfound) then + call die(myname_,'label unavailable :'//trim(desc),99) +endif +end subroutine get_int1d_ !EOC !------------------------------------------------------------------------- @@ -842,9 +841,9 @@ end subroutine get_int1d_ ! !IROUTINE: get_char0d_ --- inquire rank-0 character ! ! !INTERFACE: - subroutine get_char0d_ ( desc, ivar, istatus ) +subroutine get_char0d_ ( desc, ivar, istatus ) ! !USES: - implicit none +implicit none ! ! !DESCRIPTION: Character-string mnemonics (rank-0): ! \begin{verbatim} @@ -854,7 +853,6 @@ subroutine get_char0d_ ( desc, ivar, istatus ) ! list::clouds list of all cloud-related guesses ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -870,63 +868,63 @@ subroutine get_char0d_ ( desc, ivar, istatus ) !EOP !------------------------------------------------------------------------- !BOC - character(len=*),intent(in):: desc - character(len=*),intent(out):: ivar - integer(i_kind),intent(out):: istatus - character(len=*),parameter:: myname_=myname//"*get_char0d_" - character(len=MAXSTR):: gaslist - character(len=MAXSTR),allocatable:: work(:) - integer(i_kind) is,ie,i,i0 - logical labfound - labfound=.false. - istatus=1 - ivar='' - if(.not.guess_initialized_) return - if(trim(desc)=='list'.or.trim(desc)=='olist') then - labfound=.true. - if(nmguess>0) then - allocate(work(size(mguess))) - work=mguess - if(desc(1:1)=='o') work=usrname - gaslist=trim(work(1)) - do i=2,nmguess - i0=len_trim(gaslist) - is=i0+1 - ie=is+len_trim(work(i))+1 - gaslist(is:ie)=','//work(i) - enddo - if(nmguess>1.and.gaslist(1:1)==',') gaslist=gaslist(2:ie) - ivar = trim(gaslist) - if(ivar/='') istatus=0 - deallocate(work) - endif - endif - if(trim(desc)=='list::clouds'.or.trim(desc)=='olist::clouds') then - labfound=.true. - if(ncloud>0) then - allocate(work(size(mguess))) - work=mguess - if(desc(1:1)=='o') work=usrname - gaslist='' - if(abs(i4crtm(1))>=10.and.abs(i4crtm(1))<20) gaslist=trim(work(1)) - do i=2,nmguess - if(abs(i4crtm(i))>=10.and.abs(i4crtm(i))<20) then - i0=len_trim(gaslist) - is=i0+1 - ie=is+len_trim(work(i))+1 - gaslist(is:ie)=','//work(i) - endif - enddo - if(nmguess>1.and.gaslist(1:1)==',') gaslist=gaslist(2:ie) - ivar = trim(gaslist) - if(ivar/='') istatus=0 - deallocate(work) - endif - endif - if (.not.labfound) then - call die(myname_,'label unavailable :'//trim(desc),99) - endif - end subroutine get_char0d_ +character(len=*),intent(in):: desc +character(len=*),intent(out):: ivar +integer(i_kind),intent(out):: istatus +character(len=*),parameter:: myname_=myname//"*get_char0d_" +character(len=maxstr):: gaslist +character(len=maxstr),allocatable:: work(:) +integer(i_kind) is,ie,i,i0 +logical labfound +labfound=.false. +istatus=1 +ivar='' +if(.not.guess_initialized_) return +if(trim(desc)=='list'.or.trim(desc)=='olist') then + labfound=.true. + if(nmguess>0) then + allocate(work(size(mguess))) + work=mguess + if(desc(1:1)=='o') work=usrname + gaslist=trim(work(1)) + do i=2,nmguess + i0=len_trim(gaslist) + is=i0+1 + ie=is+len_trim(work(i))+1 + gaslist(is:ie)=','//work(i) + enddo + if(nmguess>1.and.gaslist(1:1)==',') gaslist=gaslist(2:ie) + ivar = trim(gaslist) + if(ivar/='') istatus=0 + deallocate(work) + endif +endif +if(trim(desc)=='list::clouds'.or.trim(desc)=='olist::clouds') then + labfound=.true. + if(ncloud>0) then + allocate(work(size(mguess))) + work=mguess + if(desc(1:1)=='o') work=usrname + gaslist='' + if(abs(i4crtm(1))>=10.and.abs(i4crtm(1))<20) gaslist=trim(work(1)) + do i=2,nmguess + if(abs(i4crtm(i))>=10.and.abs(i4crtm(i))<20) then + i0=len_trim(gaslist) + is=i0+1 + ie=is+len_trim(work(i))+1 + gaslist(is:ie)=','//work(i) + endif + enddo + if(nmguess>1.and.gaslist(1:1)==',') gaslist=gaslist(2:ie) + ivar = trim(gaslist) + if(ivar/='') istatus=0 + deallocate(work) + endif +endif +if (.not.labfound) then + call die(myname_,'label unavailable :'//trim(desc),99) +endif +end subroutine get_char0d_ !EOC !------------------------------------------------------------------------- @@ -935,23 +933,22 @@ end subroutine get_char0d_ ! !IROUTINE: get_char1d_ --- inquire rank-1 character ! ! !INTERFACE: - subroutine get_char1d_ ( desc, ivar, istatus ) +subroutine get_char1d_ ( desc, ivar, istatus ) ! !USES: - implicit none +implicit none ! ! !DESCRIPTION: Rank-1 character inquire routine; character mnemonics: ! \begin{verbatim} ! Known mnemonics retrieve ! --------------- -------- -! gsinames list of short names for met-fields as known in GSI +! gsinames list of short names for met-fields as known in gsi ! usrnames list of user-difined met-fields ! clouds::3d list of 3d cloud fields -! meteo_4crtm_jac::3d list of 3d meteorology fields to participate in CRTM-Jac calc -! clouds_4crtm_jac::3d list of 3d cloud fields to participate in CRTM-Jac calc -! clouds_4crtm_fwd::3d list of 3d cloud fields to participate in CRTM-fwd calc +! meteo_4crtm_jac::3d list of 3d meteorology fields to participate in crtm-jac calc +! clouds_4crtm_jac::3d list of 3d cloud fields to participate in crtm-jac calc +! clouds_4crtm_fwd::3d list of 3d cloud fields to participate in crtm-fwd calc ! ! \end{verbatim} -! where XXX represents the name of the gas of interest. ! ! !REVISION HISTORY: ! 2010-04-10 todling initial code @@ -970,122 +967,122 @@ subroutine get_char1d_ ( desc, ivar, istatus ) !EOP !------------------------------------------------------------------------- !BOC - character(len=*),intent(in):: desc - character(len=*),intent(out):: ivar(:) - character(len=*),parameter:: myname_=myname//"*get_char1d_" - integer(i_kind),intent(out):: istatus - integer(i_kind) i,ii - logical labfound - labfound=.false. - istatus=1 - ivar='' - if(.not.guess_initialized_) return - if(trim(desc)=='gsinames') then - labfound=.true. - if(size(ivar)>=size(mguess)) then - if(allocated(mguess))then - ivar = mguess - istatus=0 - endif - endif - endif - if(trim(desc)=='usrnames') then - labfound=.true. - if(size(ivar)>=size(usrname)) then - if(allocated(usrname))then - ivar = usrname - istatus=0 - endif - endif - endif - if(trim(desc)=='clouds') then - labfound=.true. - if(size(ivar)>=ncloud) then - ii=0 - do i=1,nmguess - if(abs(i4crtm(i))>=10.and.abs(i4crtm(i))<20) then - ii=ii+1 - ivar(ii)=mguess(ii) - endif - enddo - if(ii>0) istatus=0 - endif - endif - if(trim(desc)=='meteo_4crtm_jac::3d') then - labfound=.true. - ii=0 - do i=1,ng3d - if(i4crtm3d(i)==2) then - ii=ii+1 - ivar(ii)=mguess3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - if(trim(desc)=='clouds_4crtm_jac::3d') then - labfound=.true. - ii=0 - do i=1,ng3d - if(i4crtm3d(i)==12) then - ii=ii+1 - ivar(ii)=mguess3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - if(trim(desc)=='clouds_4crtm_fwd::3d') then - labfound=.true. - ii=0 - do i=1,ng3d - if(i4crtm3d(i)>10) then - ii=ii+1 - ivar(ii)=mguess3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - if(trim(desc)=='clouds::3d') then - labfound=.true. - if(size(ivar)>=n3dcloud) then - ii=0 - do i=1,ng3d - if(abs(i4crtm3d(i))>=10.and.abs(i4crtm3d(i))<20) then - ii=ii+1 - ivar(ii)=mguess3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - endif - if(trim(desc)=='clouds::2d') then - labfound=.true. - if(size(ivar)>=n2dcloud) then - ii=0 - do i=1,ng2d - if(abs(i4crtm2d(i))>=10.and.abs(i4crtm2d(i))<20) then - ii=ii+1 - ivar(ii)=mguess2d(i) - endif - enddo - if(ii>0) istatus=0 - endif - endif - if(trim(desc)=='cloud_types::3d') then - labfound=.true. - if(size(ivar)>=n3dcloud) then - ii=0 - do i=1,ng3d - if(abs(i4crtm3d(i))>=10.and.abs(i4crtm3d(i))<20) then - ii=ii+1 - ivar(ii)=metsty3d(i) - endif - enddo - if(ii>0) istatus=0 - endif - endif - if (.not.labfound) then - call die(myname_,'label unavailable :'//trim(desc),99) - endif - end subroutine get_char1d_ +character(len=*),intent(in):: desc +character(len=*),intent(out):: ivar(:) +character(len=*),parameter:: myname_=myname//"*get_char1d_" +integer(i_kind),intent(out):: istatus +integer(i_kind) i,ii +logical labfound +labfound=.false. +istatus=1 +ivar='' +if(.not.guess_initialized_) return +if(trim(desc)=='gsinames') then + labfound=.true. + if(size(ivar)>=size(mguess)) then + if(allocated(mguess))then + ivar = mguess + istatus=0 + endif + endif +endif +if(trim(desc)=='usrnames') then + labfound=.true. + if(size(ivar)>=size(usrname)) then + if(allocated(usrname))then + ivar = usrname + istatus=0 + endif + endif +endif +if(trim(desc)=='clouds') then + labfound=.true. + if(size(ivar)>=ncloud) then + ii=0 + do i=1,nmguess + if(abs(i4crtm(i))>=10.and.abs(i4crtm(i))<20) then + ii=ii+1 + ivar(ii)=mguess(ii) + endif + enddo + if(ii>0) istatus=0 + endif +endif +if(trim(desc)=='meteo_4crtm_jac::3d') then + labfound=.true. + ii=0 + do i=1,ng3d + if(i4crtm3d(i)==2) then + ii=ii+1 + ivar(ii)=mguess3d(i) + endif + enddo + if(ii>0) istatus=0 +endif +if(trim(desc)=='clouds_4crtm_jac::3d') then + labfound=.true. + ii=0 + do i=1,ng3d + if(i4crtm3d(i)==12) then + ii=ii+1 + ivar(ii)=mguess3d(i) + endif + enddo + if(ii>0) istatus=0 +endif +if(trim(desc)=='clouds_4crtm_fwd::3d') then + labfound=.true. + ii=0 + do i=1,ng3d + if(i4crtm3d(i)>10) then + ii=ii+1 + ivar(ii)=mguess3d(i) + endif + enddo + if(ii>0) istatus=0 +endif +if(trim(desc)=='clouds::3d') then + labfound=.true. + if(size(ivar)>=n3dcloud) then + ii=0 + do i=1,ng3d + if(abs(i4crtm3d(i))>=10.and.abs(i4crtm3d(i))<20) then + ii=ii+1 + ivar(ii)=mguess3d(i) + endif + enddo + if(ii>0) istatus=0 + endif +endif +if(trim(desc)=='clouds::2d') then + labfound=.true. + if(size(ivar)>=n2dcloud) then + ii=0 + do i=1,ng2d + if(abs(i4crtm2d(i))>=10.and.abs(i4crtm2d(i))<20) then + ii=ii+1 + ivar(ii)=mguess2d(i) + endif + enddo + if(ii>0) istatus=0 + endif +endif +if(trim(desc)=='cloud_types::3d') then + labfound=.true. + if(size(ivar)>=n3dcloud) then + ii=0 + do i=1,ng3d + if(abs(i4crtm3d(i))>=10.and.abs(i4crtm3d(i))<20) then + ii=ii+1 + ivar(ii)=metsty3d(i) + endif + enddo + if(ii>0) istatus=0 + endif +endif +if (.not.labfound) then + call die(myname_,'label unavailable :'//trim(desc),99) +endif +end subroutine get_char1d_ end module gsi_metguess_mod !EOC diff --git a/src/gsi/gsi_mitmOper.F90 b/src/gsi/gsi_mitmoper.f90 similarity index 70% rename from src/gsi/gsi_mitmOper.F90 rename to src/gsi/gsi_mitmoper.f90 index 6c63c7565c..de1e045725 100644 --- a/src/gsi/gsi_mitmOper.F90 +++ b/src/gsi/gsi_mitmoper.f90 @@ -1,12 +1,12 @@ -module gsi_mitmOper +module gsi_mitmoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_mitmOper +! subprogram: module gsi_mitmoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for mitmNode type +! abstract: an oboper extension for mitmnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_mitmOper ! module interface: - use gsi_obOper, only: obOper - use m_mitmNode, only: mitmNode + use gsi_oboper, only: oboper + use m_mitmnode, only: mitmnode implicit none - public:: mitmOper ! data stracture + public:: mitmoper ! data stracture - type,extends(obOper):: mitmOper + type,extends(oboper):: mitmoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type mitmOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type mitmoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_mitmOper' - type(mitmNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_mitmoper' + type(mitmnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[mitmOper]" + mytype="[mitmoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mitm_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(mitmOper ), intent(inout):: self + class(mitmoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intmitmmod, only: intjo => intmitm use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(mitmOper ),intent(in ):: self + class(mitmoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpmitmmod, only: stpjo => stpmitm use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(mitmOper ),intent(in):: self + class(mitmoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_mitmOper +end module gsi_mitmoper diff --git a/src/gsi/gsi_mxtmOper.F90 b/src/gsi/gsi_mxtmoper.f90 similarity index 70% rename from src/gsi/gsi_mxtmOper.F90 rename to src/gsi/gsi_mxtmoper.f90 index e0eae49dc5..4ff4b37b00 100644 --- a/src/gsi/gsi_mxtmOper.F90 +++ b/src/gsi/gsi_mxtmoper.f90 @@ -1,12 +1,12 @@ -module gsi_mxtmOper +module gsi_mxtmoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_mxtmOper +! subprogram: module gsi_mxtmoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for mxtmNode type +! abstract: an oboper extension for mxtmnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_mxtmOper ! module interface: - use gsi_obOper, only: obOper - use m_mxtmNode, only: mxtmNode + use gsi_oboper, only: oboper + use m_mxtmnode, only: mxtmnode implicit none - public:: mxtmOper ! data stracture + public:: mxtmoper ! data stracture - type,extends(obOper):: mxtmOper + type,extends(oboper):: mxtmoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type mxtmOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type mxtmoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_mxtmOper' - type(mxtmNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_mxtmoper' + type(mxtmnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[mxtmOper]" + mytype="[mxtmoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mxtm_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(mxtmOper ), intent(inout):: self + class(mxtmoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intmxtmmod, only: intjo => intmxtm use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(mxtmOper ),intent(in ):: self + class(mxtmoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpmxtmmod, only: stpjo => stpmxtm use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(mxtmOper ),intent(in):: self + class(mxtmoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_mxtmOper +end module gsi_mxtmoper diff --git a/src/gsi/gsi_nemsio_mod.f90 b/src/gsi/gsi_nemsio_mod.f90 index 87b5c232ff..c7ddd8348a 100644 --- a/src/gsi/gsi_nemsio_mod.f90 +++ b/src/gsi/gsi_nemsio_mod.f90 @@ -201,26 +201,26 @@ subroutine gsi_nemsio_update(file_name,message,mype,mype_io) ntimestep=0 - call nemsio_setheadvar(gfile,'idate',jdate,iret) - write(6,*)' after setheadvar, jdate,iret=',jdate,iret - call nemsio_setheadvar(gfile,'nfhour',nfhour,iret) - write(6,*)' after setheadvar, nfhour,iret=',nfhour,iret - call nemsio_setheadvar(gfile,'nfminute',nfminute,iret) - write(6,*)' after setheadvar, nfminute,iret=',nfminute,iret - call nemsio_setheadvar(gfile,'nfsecondn',nfsecondn,iret) - write(6,*)' after setheadvar, nfsecondn,iret=',nfsecondn,iret + call nemsio_setheadvar(gfile,'idate',jdate,iret) + write(6,*)' after setheadvar, jdate,iret=',jdate,iret + call nemsio_setheadvar(gfile,'nfhour',nfhour,iret) + write(6,*)' after setheadvar, nfhour,iret=',nfhour,iret + call nemsio_setheadvar(gfile,'nfminute',nfminute,iret) + write(6,*)' after setheadvar, nfminute,iret=',nfminute,iret + call nemsio_setheadvar(gfile,'nfsecondn',nfsecondn,iret) + write(6,*)' after setheadvar, nfsecondn,iret=',nfsecondn,iret ! - idat(3)=jdate(1) ! forecast starting year - idat(2)=jdate(2) ! forecast starting month - idat(1)=jdate(3) ! forecast starting day - ihrst=jdate(4) ! forecast starting hour (0-23) - call nemsio_setheadvar(gfile,'idat',idat,iret) - write(6,*)' after setheadvar, idat,iret=',idat,iret - call nemsio_setheadvar(gfile,'ihrst',ihrst,iret) - write(6,*)' after setheadvar, ihrst,iret=',ihrst,iret - call nemsio_setheadvar(gfile,'ntimestep',ntimestep,iret) - write(6,*)' after setheadvar, ntimestep,iret=',ntimestep,iret + idat(3)=jdate(1) ! forecast starting year + idat(2)=jdate(2) ! forecast starting month + idat(1)=jdate(3) ! forecast starting day + ihrst=jdate(4) ! forecast starting hour (0-23) + call nemsio_setheadvar(gfile,'idat',idat,iret) + write(6,*)' after setheadvar, idat,iret=',idat,iret + call nemsio_setheadvar(gfile,'ihrst',ihrst,iret) + write(6,*)' after setheadvar, ihrst,iret=',ihrst,iret + call nemsio_setheadvar(gfile,'ntimestep',ntimestep,iret) + write(6,*)' after setheadvar, ntimestep,iret=',ntimestep,iret @@ -341,7 +341,7 @@ subroutine gsi_nemsio_read(varname,vartype,gridtype,lev,var,mype,mype_io,good_va use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a implicit none - character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' + character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='h' or 'v' integer(i_kind),intent(in ) :: lev ! vertical level of desired variable real(r_kind) ,intent( out) :: var(lat2*lon2) integer(i_kind),intent(in ) :: mype,mype_io @@ -402,13 +402,13 @@ subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,var ! subprogram: gsi_nemsio_read_fraction ! pgrmmr: Shun Liu ! -! abstract: copy from gsi_nemsio_read. To read in NMMB f_rain, f_ice, f_rime and -! T together and then convert to rain water mixing ratio and snow +! abstract: copy from gsi_nemsio_read. To read in nmmb f_rain, f_ice, f_rime and +! t together and then convert to rain water mixing ratio and snow ! mixing ratio ! ! program history log: -! 2015-06-5 S.Liu - read in f_rain, f_ice, f_rimef and T +! 2015-06-5 S.Liu - read in f_rain, f_ice, f_rimef and t ! 2016-02-10 S.Liu - remove gridtype if-test since all variables are in mass point ! ! input argument list: @@ -440,8 +440,8 @@ subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,var use mod_nmmb_to_a, only: nmmb_h_to_a,nmmb_v_to_a implicit none - character(*) ,intent(in ) :: vartype ! gridtype='H' or 'V' - character(*) ,intent(in ) :: varname_frain, varname_fice, varname_clwmr, varname_t ! gridtype='H' or 'V' + character(*) ,intent(in ) :: vartype ! gridtype='h' or 'v' + character(*) ,intent(in ) :: varname_frain, varname_fice, varname_clwmr, varname_t ! gridtype='h' or 'v' integer(i_kind),intent(in ) :: lev ! vertical level of desired variable real(r_kind) ,intent( out) :: var_qi(lat2*lon2) @@ -489,15 +489,15 @@ subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,var call nemsio_readrecv(gfile,trim(varname_t),trim(vartype),lev,work_b_t,iret=iret) do n=1,nlon_regional*nlat_regional - t=work_b_t(n) - f_rain=work_b_frain(n) - f_ice=work_b_fice(n) - wc=work_b_clwmr(n) - call fraction2variable(t,f_ice,f_rain,wc,qi,qs,qr,qw) - work_b_qi(n)=qi - work_b_qs(n)=qs - work_b_qr(n)=qr - work_b_qw(n)=qw + t=work_b_t(n) + f_rain=work_b_frain(n) + f_ice=work_b_fice(n) + wc=work_b_clwmr(n) + call fraction2variable(t,f_ice,f_rain,wc,qi,qs,qr,qw) + work_b_qi(n)=qi + work_b_qs(n)=qs + work_b_qr(n)=qr + work_b_qw(n)=qw end do if(iret==0) then @@ -536,14 +536,14 @@ subroutine gsi_nemsio_read_fraction(varname_frain,varname_fice,varname_clwmr,var if(present(good_var)) good_var=good_var_loc if(good_var_loc) then - call mpi_scatterv(work_qi,ijn_s,displs_s,mpi_rtype, & - var_qi,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qs,ijn_s,displs_s,mpi_rtype, & - var_qs,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qr,ijn_s,displs_s,mpi_rtype, & - var_qr,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) - call mpi_scatterv(work_qw,ijn_s,displs_s,mpi_rtype, & - var_qw,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qi,ijn_s,displs_s,mpi_rtype, & + var_qi,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qs,ijn_s,displs_s,mpi_rtype, & + var_qs,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qr,ijn_s,displs_s,mpi_rtype, & + var_qr,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) + call mpi_scatterv(work_qw,ijn_s,displs_s,mpi_rtype, & + var_qw,ijn_s(mm1),mpi_rtype,mype_io,mpi_comm_world,ierror) end if end subroutine gsi_nemsio_read_fraction @@ -583,7 +583,7 @@ subroutine gsi_nemsio_write(varname,vartype,gridtype,lev,var,mype,mype_io,add_sa use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v implicit none - character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='H' or 'V' + character(*) ,intent(in ) :: varname,vartype,gridtype ! gridtype='h' or 'v' integer(i_kind),intent(in ) :: lev ! vertical level of desired variable real(r_kind) ,intent(in ) :: var(lat2,lon2) integer(i_kind),intent(in ) :: mype,mype_io @@ -630,7 +630,7 @@ subroutine gsi_nemsio_write_fraction(varname_frain,varname_fice,vartype,lev,var_ ! abstract: ! ! program history log: -! 2015-05-12 S.Liu - copy from gsi_nemsio_write and modify to handle NMMB hydrometor fraction variable +! 2015-05-12 S.Liu - copy from gsi_nemsio_write and modify to handle nmmb hydrometor fraction variable ! ! input argument list: ! varname,vartype,gridtype @@ -656,7 +656,7 @@ subroutine gsi_nemsio_write_fraction(varname_frain,varname_fice,vartype,lev,var_ use mod_nmmb_to_a, only: nmmb_a_to_h,nmmb_a_to_v implicit none - character(*) ,intent(in ) :: varname_frain,varname_fice,vartype ! gridtype='H' or 'V' + character(*) ,intent(in ) :: varname_frain,varname_fice,vartype ! gridtype='h' or 'v' integer(i_kind),intent(in ) :: lev ! vertical level of desired variable real(r_kind) ,intent(in ) :: var_i(lat2,lon2), var_r(lat2,lon2), var_l(lat2,lon2), var_t(lat2,lon2) integer(i_kind),intent(in ) :: mype,mype_io @@ -731,13 +731,13 @@ subroutine gsi_nemsio_write_fraction(varname_frain,varname_fice,vartype,lev,var_ ! write(6,*)'writeout4', maxval(work_b_r),maxval(work_b_l) ! write(6,*)'writeout44',nlon_regional,nlat_regional,nlon,nlat do n=1,nlon_regional*nlat_regional - t=work_b_t(n) - qfi=work_b_i(n) - qfr=work_b_r(n) - qfw=work_b_l(n) - call variable2fraction(t, qfi, qfr, qfw, f_ice, f_rain) - work_b_frain(n)=f_rain - work_b_fice(n)=f_ice + t=work_b_t(n) + qfi=work_b_i(n) + qfr=work_b_r(n) + qfw=work_b_l(n) + call variable2fraction(t, qfi, qfr, qfw, f_ice, f_rain) + work_b_frain(n)=f_rain + work_b_fice(n)=f_ice ! work_b_frain(n)=qfr ! work_b_fice(n)=qfw end do @@ -761,77 +761,78 @@ Subroutine fraction2variable(t,f_ice,f_rain, wc, qi,qs,qr,qw) ! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor ! analysis ! -! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2015-05-28 +! prgmmr: Shun Liu org: EMC/NCEP date: 2015-05-28 ! -! ABSTRACT: +! abstract: ! This subroutine fraction to qi, qs, qr, qw ! -! PROGRAM HISTORY LOG: -! 2015-05-28 Shun Liu Add NCO document block +! program history log: +! 2015-05-28 Shun Liu Add nco document block ! 2016-06-21 Shun Liu give number precisio and remove f_rimef ! ! ! input argument list: -! mype - processor ID that does this IO +! mype - processor id that does this io ! ! output argument list: ! -! USAGE: -! INTPUT: +! usage: +! input: ! t - sensible temperature ! f_ice - fraction of condensate in form of ice ! f_rain - fraction of liquid water in form of rain ! f_rimef - ratio of total ice growth to deposition groth -! OUTPUT +! output ! qi - cloud ice mixing ratio ! qs - large ice mixing ratio ! qr - rain mixing ratio ! qw - cloud water mixing ratio ! ! -! REMARKS: +! remarks: ! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! attributes: +! language: FORTRAN 90 +! machine: WCOSS at NOAA/ESRL - college park, DC ! !$$$ - use kinds, only: r_kind,r_single - - real(r_single) t, qi,qs, qr, qw, wc - real(r_single) f_ice, f_rain - real(r_single),parameter:: epsq=1.e-12_r_single - real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single - real(r_single),parameter:: tice_mix=243.15_r_single - real(r_single) ::t1,t2, coef1, coef2, coef - - - qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single - if(wc > 0.0_r_single) then - - if(f_ice>1.0_r_single) f_ice=1.0_r_single - if(f_ice<0.0_r_single) f_ice=0.0_r_single - if(f_rain>1.0_r_single) f_rain=1.0_r_single - if(f_rain<0.0_r_single) f_rain=0.0_r_single - - qi=0.05_r_single*wc*f_ice - qs=0.95_r_single*wc*f_ice + use kinds, only: r_kind,r_single + implicit none - if(t<=tice_mix)then - t1=tice_mix - t2=tice - coef1=0.05_r_single - coef2=0.10_r_single - coef=(t-t2)/(t1-t2)*coef1+(t-t1)/(t2-t1)*coef2 - qi=coef*wc*f_ice - qs=(1.0_r_single-coef)*wc*f_ice - end if + real(r_single) t, qi,qs, qr, qw, wc + real(r_single) f_ice, f_rain + real(r_single),parameter:: epsq=1.e-12_r_single + real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single + real(r_single),parameter:: tice_mix=243.15_r_single + real(r_single) ::t1,t2, coef1, coef2, coef + + + qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single + if(wc > 0.0_r_single) then + + if(f_ice>1.0_r_single) f_ice=1.0_r_single + if(f_ice<0.0_r_single) f_ice=0.0_r_single + if(f_rain>1.0_r_single) f_rain=1.0_r_single + if(f_rain<0.0_r_single) f_rain=0.0_r_single + + qi=0.05_r_single*wc*f_ice + qs=0.95_r_single*wc*f_ice + + if(t<=tice_mix)then + t1=tice_mix + t2=tice + coef1=0.05_r_single + coef2=0.10_r_single + coef=(t-t2)/(t1-t2)*coef1+(t-t1)/(t2-t1)*coef2 + qi=coef*wc*f_ice + qs=(1.0_r_single-coef)*wc*f_ice + end if -!* do not consider frime at the moment - qr=wc*(1.0_r_single-f_ice)*f_rain - qw=wc*(1.0_r_single-f_ice)*(1.0_r_single-f_rain) - end if +!* do not consider frime at the moment + qr=wc*(1.0_r_single-f_ice)*f_rain + qw=wc*(1.0_r_single-f_ice)*(1.0_r_single-f_rain) + end if end subroutine fraction2variable @@ -842,72 +843,73 @@ subroutine variable2fraction(t, qi, qr, qw, f_ice, f_rain) ! . . . . ! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis ! -! PRGMMR: Shun Liu ORG: EMC/NCEP DATE: 2012-10-24 +! prgmmr: Shun Liu org: EMC/NCEP date: 2012-10-24 ! -! ABSTRACT: +! abstract: ! This subroutine qi qr qw to fraction ! -! PROGRAM HISTORY LOG: -! 2013-10-18 Shun Liu Add NCO document block +! program history log: +! 2013-10-18 Shun Liu Add nco document block ! 2015-11-16 Shun Liu move from gsdcldanalysis4nmmb.F90 to this module -! 2016-06-21 Shun Liu give number precisio +! 2016-06-21 Shun Liu give number precision ! ! ! input argument list: -! mype - processor ID that does this IO +! mype - processor id that does this io ! ! output argument list: ! -! USAGE: -! INPUT +! usage: +! input: ! qi - cloud ice mixing ratio ! qr - rain mixing ratio ! qw - cloud water mixing ratio -! OUTPUT: +! output: ! f_ice - fraction of condensate in form of ice ! f_rain - fraction of liquid water in form of rain ! f_rimef - ratio of total ice growth to deposition groth ! ! -! REMARKS: +! remarks: ! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! attributes: +! language: FORTRAN 90 +! machine: WCOSS at NOAA/ESRL - college park, DC ! !$$$ - use kinds, only: r_kind,r_single - - real(r_single) t, qi, qr, qw, wc, dum - real(r_single) f_ice, f_rain - real(r_single),parameter:: epsq=1.e-12_r_single - real(r_single),parameter:: tice=233.15_r_single,ticek=273.15_r_single - - wc=qi+qr+qw - if(wc > 0.0_r_single) then - if(qi 0.0_r_single) then + if(qi 0.0_r_single) then - - if(f_ice>1.0_r_single) f_ice=1.0_r_single - if(f_ice<0.0_r_single) f_ice=0.0_r_single - if(f_rain>1.0_r_single) f_rain=1.0_r_single - if(f_rain<0.0_r_single) f_rain=0.0_r_single - qs=f_ice*wc - qr=f_rain*onemf_ice*wc - qw=onemf_rain*onemf_ice*wc - qi=qs*f_rimef -else - qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single - end if + if(wc > 0.0_r_single) then + + if(f_ice>1.0_r_single) f_ice=1.0_r_single + if(f_ice<0.0_r_single) f_ice=0.0_r_single + if(f_rain>1.0_r_single) f_rain=1.0_r_single + if(f_rain<0.0_r_single) f_rain=0.0_r_single + qs=f_ice*wc + qr=f_rain*onemf_ice*wc + qw=onemf_rain*onemf_ice*wc + qi=qs*f_rimef + else + qi=0.0_r_single; qs=0.0_r_single; qr=0.0_r_single; qw=0.0_r_single + end if end subroutine fraction2variablenew subroutine variable2fractionnew( qs,qi, qr, qw, f_ice, f_rain,f_rimef) @@ -1275,91 +1278,92 @@ subroutine variable2fractionnew( qs,qi, qr, qw, f_ice, f_rain,f_rimef) ! . . . . ! subprogram: gsdcloudanalysis driver for generalized cloud/hydrometeor analysis ! -! PRGMMR: Ting Lei ORG: EMC/NCEP DATE: 2016 +! prgmmr: Ting Lei org: EMC/NCEP date: 2016 ! -! ABSTRACT: +! abstract: ! This subroutine qi qr qw and qs to fraction -! following their theorectical formula in NMMB ferrier-Algo scheme +! following their theorectical formula in nmmb ferrier-algo scheme ! and, the exact physical meaning of qi, qs, qr, qw are not considerred ! and are only used as the intermidiate variables ! -! PROGRAM HISTORY LOG: +! program history log: ! ! ! input argument list: -! mype - processor ID that does this IO +! mype - processor id that does this io ! ! output argument list: ! -! USAGE: -! INPUT +! usage: +! input: ! qi - ! qi - ! qr - ! qw - -! OUTPUT: +! output: ! f_ice - fraction of condensate in form of ice ! f_rain - fraction of liquid water in form of rain ! f_rimef - ratio of total ice growth to deposition groth ! ! -! REMARKS: +! remarks: ! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE: WCOSS at NOAA/ESRL - college park, DC +! attributes: +! language: FORTRAN 90 +! machine: WCOSS at NOAA/ESRL - college park, DC ! !$$$ - use kinds, only: r_kind,r_single - - real(r_single) qi, qr, qw, wc, dum - real(r_single) qs - real(r_single) f_ice, f_rain,f_rimef - real(r_single),parameter:: epsq=1.e-12_r_single - real(r_single) onemf_ice - - wc=qs+qr+qw - if(wc > 0.0_r_single) then - if(qs 0.0_r_single) then + if(qsepsq) then - f_rimef=min(qi/qs,50.0_r_single) - else - f_rimef=1.0_r_single !cltthinkdeb + endif + end if + if(qi< epsq) then + f_rimef=1.0_r_single + else + if(qs>epsq) then + f_rimef=min(qi/qs,50.0_r_single) + else + f_rimef=1.0_r_single !cltthinkdeb endif - endif + endif - else - f_rain=0.0_r_single - f_ice=0.0_r_single - f_rimef=1.0_r_single - end if + else + f_rain=0.0_r_single + f_ice=0.0_r_single + f_rimef=1.0_r_single + end if end subroutine variable2fractionnew diff --git a/src/gsi/gsi_nstcouplermod.f90 b/src/gsi/gsi_nstcouplermod.f90 index 1ed6fefcff..08b6eb487c 100644 --- a/src/gsi/gsi_nstcouplermod.f90 +++ b/src/gsi/gsi_nstcouplermod.f90 @@ -1,38 +1,38 @@ !---------------------------------------------------------------------------- !BOP ! -! !MODULE: GSI_NSTCouplerMod --- +! !MODULE: gsi_nstcouplermod --- ! ! !INTERFACE: ! ! !DESCRIPTION: This module provides general interface for -! NST- sea surface skin temp analysis +! nst- sea surface skin temp analysis ! ! !REVISION HISTORY: ! ! 2011-10-20 RT/ Akella- Initial code -! 2012-03-05 SA- _full fields: tref, dt_cool, dt_warm, z_c, z_w, ... are declared here INSTEAD of satthin +! 2012-03-05 SA- _full fields: tref, dt_cool, dt_warm, z_c, z_w, ... are declared here instead of satthin ! 2015-05-01 Li- Change the nst fields to be single precision ! 2017-09-14 LI- Change the default value to be 1 for fac_dtl & fac_tsl ! !EOP !------------------------------------------------------------------------- -! def tref_full - sea surface reference temperature-- foundation SST +! def tref_full - sea surface reference temperature-- foundation sst ! def dt_cool_full - sea cooling amount across sub-layer (or, cool-layer) ! def z_c_full - sub-layer thickness ! def dt_warm_full - sea diurnal warming amount ! def z_w_full - diurnal warming layer thickness ! ********************************************************* -! FOLLOWING 4 FIELDS ARE FOR GFS +! Following 4 fields are for gfs ! ********************************************************* -! def c_0_full - coefficient 1 to calculate d(Tz)/d(Tr) -! def c_d_full - coefficient 2 to calculate d(Tz)/d(Tr) -! def w_0_full - coefficient 3 to calculate d(Tz)/d(Tr) -! def w_d_full - coefficient 4 to calculate d(Tz)/d(Tr) +! def c_0_full - coefficient 1 to calculate d(tz)/d(tr) +! def c_d_full - coefficient 2 to calculate d(tz)/d(tr) +! def w_0_full - coefficient 3 to calculate d(tz)/d(tr) +! def w_d_full - coefficient 4 to calculate d(tz)/d(tr) ! ********************************************************* !------------------------------------------------------------------------- -module GSI_NSTCouplerMod +module gsi_nstcouplermod ! !USES: use kinds, only: r_single, r_kind, i_kind @@ -43,23 +43,23 @@ module GSI_NSTCouplerMod ! ! !PUBLIC MEMBER FUNCTIONS: ! -public GSI_NSTCoupler_init_nml -public GSI_NSTCoupler_init -public GSI_NSTCoupler_read -public GSI_NSTCoupler_skindepth -public GSI_NSTCoupler_deter -public GSI_NSTCoupler_final +public gsi_nstcoupler_init_nml +public gsi_nstcoupler_init +public gsi_nstcoupler_read +public gsi_nstcoupler_skindepth +public gsi_nstcoupler_deter +public gsi_nstcoupler_final public :: nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl public :: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full public :: c_0_full,c_d_full,w_0_full,w_d_full -integer(i_kind) :: nst_gsi ! indicator of Tr Analysis +integer(i_kind) :: nst_gsi ! indicator of tr analysis integer(i_kind) :: nstinfo ! number of nst variables integer(i_kind) :: zsea1 ! upper depth (in mm) to do the mean integer(i_kind) :: zsea2 ! lower depth (in mm) to do the mean -integer(i_kind) :: fac_dtl ! indicator of DTL -integer(i_kind) :: fac_tsl ! indicator of TSL +integer(i_kind) :: fac_dtl ! indicator of dtl +integer(i_kind) :: fac_tsl ! indicator of tsl real(r_single),allocatable,dimension(:,:,:):: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full real(r_single),allocatable,dimension(:,:,:):: c_0_full,c_d_full,w_0_full,w_d_full @@ -126,18 +126,18 @@ subroutine gsi_nstcoupler_init_nml nst_gsi = 0 ! 0 = no nst info at all in gsi ! 1 = read nst info but not applied - ! 2 = read nst info, applied to Tb simulation but no Tr analysis - ! 3 = read nst info, applied to Tb simulation and do Tr Analysis - nstinfo = 0 ! number of nst fields used in Tr analysis + ! 2 = read nst info, applied to tb simulation but no tr analysis + ! 3 = read nst info, applied to tb simulation and do tr Analysis + nstinfo = 0 ! number of nst fields used in tr analysis zsea1 = 0 ! upper depth to do the mean zsea2 = 0 ! lower depth to do the mean - fac_dtl = 1 ! indicator to apply DTL model - fac_tsl = 1 ! indicator to apply TSL model + fac_dtl = 1 ! indicator to apply dtl model + fac_tsl = 1 ! indicator to apply tsl model return end subroutine gsi_nstcoupler_init_nml !------------------- -end module GSI_NSTCouplerMod +end module gsi_nstcouplermod diff --git a/src/gsi/gsi_o3lOper.F90 b/src/gsi/gsi_o3loper.f90 similarity index 69% rename from src/gsi/gsi_o3lOper.F90 rename to src/gsi/gsi_o3loper.f90 index 60ef0b9c28..34e537779b 100644 --- a/src/gsi/gsi_o3lOper.F90 +++ b/src/gsi/gsi_o3loper.f90 @@ -1,12 +1,12 @@ -module gsi_o3lOper +module gsi_o3loper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_o3lOper +! subprogram: module gsi_o3loper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for o3lNode type +! abstract: an oboper extension for o3lnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_o3lOper ! module interface: - use gsi_obOper, only: obOper - use m_o3lNode , only: o3lNode + use gsi_oboper, only: oboper + use m_o3lnode , only: o3lnode implicit none - public:: o3lOper ! data stracture + public:: o3loper ! data stracture - type,extends(obOper):: o3lOper + type,extends(oboper):: o3loper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type o3lOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type o3loper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_o3lOper' - type(o3lNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_o3loper' + type(o3lnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[o3lOper]" + mytype="[o3loper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use o3l_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: stats => rhs_stats_oz use obsmod, only: write_diag @@ -73,7 +73,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(o3lOper ), intent(inout):: self + class(o3loper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -96,7 +96,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_ozone - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) end subroutine setup_ @@ -105,11 +105,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use into3lmod, only: intjo => intozlev use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(o3lOper ),intent(in ):: self + class(o3loper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,11 +118,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -130,11 +130,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpo3lmod, only: stpjo => stpozlev use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(o3lOper ),intent(in):: self + class(o3loper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_o3lOper +end module gsi_o3loper diff --git a/src/gsi/gsi_obOperTypeManager.F90 b/src/gsi/gsi_obOperTypeManager.F90 deleted file mode 100644 index 9af3a62a7f..0000000000 --- a/src/gsi/gsi_obOperTypeManager.F90 +++ /dev/null @@ -1,606 +0,0 @@ -module gsi_obOperTypeManager -!$$$ subprogram documentation block -! . . . . -! subprogram: module gsi_obOperTypeManager -! prgmmr: j guo -! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 -! date: 2018-07-12 -! -! abstract: GSI observation operator (obOper) type manager -! -! program history log: -! 2018-07-12 j guo - a type-manager for all obOper extensions. -! - an enum mapping of obsinput::dtype(:) to obOper type -! extensions. -! -! input argument list: see Fortran 90 style document below -! -! output argument list: see Fortran 90 style document below -! -! attributes: -! language: Fortran 90 and/or above -! machine: -! -!$$$ end subprogram documentation block - -! module interface: - - use gsi_obOper, only: obOper - - use gsi_aeroOper , only: aeroOper - use gsi_cldchOper , only: cldchOper - use gsi_colvkOper , only: colvkOper - use gsi_dwOper , only: dwOper - use gsi_gpsbendOper , only: gpsbendOper - use gsi_gpsrefOper , only: gpsrefOper - use gsi_gustOper , only: gustOper - use gsi_howvOper , only: howvOper - use gsi_lcbasOper , only: lcbasOper - use gsi_lwcpOper , only: lwcpOper - use gsi_mitmOper , only: mitmOper - use gsi_mxtmOper , only: mxtmOper - use gsi_o3lOper , only: o3lOper - use gsi_ozOper , only: ozOper - use gsi_pblhOper , only: pblhOper - use gsi_pcpOper , only: pcpOper - use gsi_pm10Oper , only: pm10Oper - use gsi_pm2_5Oper , only: pm2_5Oper - use gsi_pmslOper , only: pmslOper - use gsi_psOper , only: psOper - use gsi_pwOper , only: pwOper - use gsi_qOper , only: qOper - use gsi_radOper , only: radOper - use gsi_rwOper , only: rwOper - use gsi_spdOper , only: spdOper - use gsi_sstOper , only: sstOper - use gsi_swcpOper , only: swcpOper - use gsi_tcamtOper , only: tcamtOper - use gsi_tcpOper , only: tcpOper - use gsi_td2mOper , only: td2mOper - use gsi_tOper , only: tOper - use gsi_uwnd10mOper , only: uwnd10mOper - use gsi_visOper , only: visOper - use gsi_vwnd10mOper , only: vwnd10mOper - use gsi_wOper , only: wOper - use gsi_wspd10mOper , only: wspd10mOper - - use gsi_lightOper , only: lightOper - use gsi_dbzOper , only: dbzOper - use gsi_cldtotOper , only: cldtotOper - - use kinds , only: i_kind - use mpeu_util , only: perr,die - implicit none - private ! except - - public:: obOper_typeMold - public:: obOper_typeIndex - public:: obOper_typeInfo - interface obOper_typeMold; module procedure & - dtype2vmold_, & - index2vmold_ ; end interface - interface obOper_typeIndex; module procedure & - vmold2index_, & - dtype2index_ ; end interface - interface obOper_typeInfo; module procedure & - vmold2tinfo_, & - index2tinfo_ ; end interface - - !public:: obOper_config - ! interface obOper_config; module procedure config_; end interface - - public:: obOper_undef - public:: obOper_lbound - public:: obOper_ubound - !public:: obOper_size - public:: obOper_count - - public:: iobOper_kind - public:: iobOper_ps - public:: iobOper_t - public:: iobOper_w - public:: iobOper_q - public:: iobOper_spd - public:: iobOper_rw - public:: iobOper_dw - public:: iobOper_sst - public:: iobOper_pw - public:: iobOper_pcp - public:: iobOper_oz - public:: iobOper_o3l - public:: iobOper_gpsbend - public:: iobOper_gpsref - public:: iobOper_rad - public:: iobOper_tcp - !public:: iobOper_lag - public:: iobOper_colvk - public:: iobOper_aero - !public:: iobOper_aerol - public:: iobOper_pm2_5 - public:: iobOper_gust - public:: iobOper_vis - public:: iobOper_pblh - public:: iobOper_wspd10m - public:: iobOper_td2m - public:: iobOper_mxtm - public:: iobOper_mitm - public:: iobOper_pmsl - public:: iobOper_howv - public:: iobOper_tcamt - public:: iobOper_lcbas - public:: iobOper_pm10 - public:: iobOper_cldch - public:: iobOper_uwnd10m - public:: iobOper_vwnd10m - public:: iobOper_swcp - public:: iobOper_lwcp - public:: iobOper_light - public:: iobOper_dbz - public:: iobOper_cldtot - - enum, bind(C) - enumerator:: iobOper_zero_ = 0 - - enumerator:: iobOper_ps - enumerator:: iobOper_t - enumerator:: iobOper_w - enumerator:: iobOper_q - enumerator:: iobOper_spd - enumerator:: iobOper_rw - enumerator:: iobOper_dw - enumerator:: iobOper_sst - enumerator:: iobOper_pw - enumerator:: iobOper_pcp - enumerator:: iobOper_oz - enumerator:: iobOper_o3l - enumerator:: iobOper_gpsbend - enumerator:: iobOper_gpsref - enumerator:: iobOper_rad - enumerator:: iobOper_tcp - !enumerator:: iobOper_lag - enumerator:: iobOper_colvk - enumerator:: iobOper_aero - !enumerator:: iobOper_aerol - enumerator:: iobOper_pm2_5 - enumerator:: iobOper_gust - enumerator:: iobOper_vis - enumerator:: iobOper_pblh - enumerator:: iobOper_wspd10m - enumerator:: iobOper_td2m - enumerator:: iobOper_mxtm - enumerator:: iobOper_mitm - enumerator:: iobOper_pmsl - enumerator:: iobOper_howv - enumerator:: iobOper_tcamt - enumerator:: iobOper_lcbas - enumerator:: iobOper_pm10 - enumerator:: iobOper_cldch - enumerator:: iobOper_uwnd10m - enumerator:: iobOper_vwnd10m - enumerator:: iobOper_swcp - enumerator:: iobOper_lwcp - enumerator:: iobOper_light - enumerator:: iobOper_dbz - enumerator:: iobOper_cldtot - - enumerator:: iobOper_extra_ - end enum - - integer(i_kind),parameter:: enum_kind = kind(iobOper_zero_) - integer(i_kind),parameter:: iobOper_kind = enum_kind - - integer(enum_kind),parameter:: obOper_undef = -1_enum_kind - integer(enum_kind),parameter:: obOper_lbound = iobOper_zero_ +1 - integer(enum_kind),parameter:: obOper_ubound = iobOper_extra_-1 - integer(enum_kind),parameter:: obOper_size = obOper_ubound-obOper_lbound+1 - integer(enum_kind),parameter:: obOper_count = obOper_size - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_obOperTypeManager' - logical,save:: obOper_configured_ = .false. - - character(len=20),dimension(obOper_lbound:obOper_ubound):: cobstype - logical,save:: cobstype_configured_=.false. - - type( psOper), target, save:: psOper_mold - type( tOper), target, save:: tOper_mold - type( wOper), target, save:: wOper_mold - type( qOper), target, save:: qOper_mold - type( spdOper), target, save:: spdOper_mold - type( rwOper), target, save:: rwOper_mold - type( dwOper), target, save:: dwOper_mold - type( sstOper), target, save:: sstOper_mold - type( pwOper), target, save:: pwOper_mold - type( pcpOper), target, save:: pcpOper_mold - type( ozOper), target, save:: ozOper_mold - type( o3lOper), target, save:: o3lOper_mold - type(gpsbendOper), target, save:: gpsbendOper_mold - type( gpsrefOper), target, save:: gpsrefOper_mold - type( radOper), target, save:: radOper_mold - type( tcpOper), target, save:: tcpOper_mold - !type( lagOper), target, save:: lagOper_mold - type( colvkOper), target, save:: colvkOper_mold - type( aeroOper), target, save:: aeroOper_mold - !type( aerolOper), target, save:: aerolOper_mold - type( pm2_5Oper), target, save:: pm2_5Oper_mold - type( gustOper), target, save:: gustOper_mold - type( visOper), target, save:: visOper_mold - type( pblhOper), target, save:: pblhOper_mold - type(wspd10mOper), target, save:: wspd10mOper_mold - type( td2mOper), target, save:: td2mOper_mold - type( mxtmOper), target, save:: mxtmOper_mold - type( mitmOper), target, save:: mitmOper_mold - type( pmslOper), target, save:: pmslOper_mold - type( howvOper), target, save:: howvOper_mold - type( tcamtOper), target, save:: tcamtOper_mold - type( lcbasOper), target, save:: lcbasOper_mold - type( pm10Oper), target, save:: pm10Oper_mold - type( cldchOper), target, save:: cldchOper_mold - type(uwnd10mOper), target, save:: uwnd10mOper_mold - type(vwnd10mOper), target, save:: vwnd10mOper_mold - type( swcpOper), target, save:: swcpOper_mold - type( lwcpOper), target, save:: lwcpOper_mold - type( lightOper), target, save:: lightOper_mold - type( dbzOper), target, save:: dbzOper_mold - type( cldtotOper), target, save:: cldtotOper_mold - -contains -function dtype2index_(dtype) result(index_) - use mpeu_util, only: lowercase - implicit none - integer(i_kind):: index_ - character(len=*),intent(in):: dtype - - select case(lowercase(dtype)) - case("ps" ,"[psoper]" ); index_= iobOper_ps - case("t" ,"[toper]" ); index_= iobOper_t - - case("w" ,"[woper]" ); index_= iobOper_w - case("uv" ); index_= iobOper_w - - case("q" ,"[qoper]" ); index_= iobOper_q - case("spd" ,"[spdoper]" ); index_= iobOper_spd - case("rw" ,"[rwoper]" ); index_= iobOper_rw - case("dw" ,"[dwoper]" ); index_= iobOper_dw - case("sst" ,"[sstoper]" ); index_= iobOper_sst - case("pw" ,"[pwoper]" ); index_= iobOper_pw - - case("pcp" ,"[pcpoper]" ); index_= iobOper_pcp - case("pcp_ssmi"); index_= iobOper_pcp - case("pcp_tmi" ); index_= iobOper_pcp - - case("oz" ,"[ozoper]" ); index_= iobOper_oz - case("sbuv2" ); index_= iobOper_oz - case("omi" ); index_= iobOper_oz - case("gome" ); index_= iobOper_oz - case("ompstc8"); index_= iobOper_oz - case("ompsnp" ); index_= iobOper_oz - case("ompsnm" ); index_= iobOper_oz - - case("o3l" ,"[o3loper]" ); index_= iobOper_o3l - case("o3lev" ); index_= iobOper_o3l - case("mls20" ); index_= iobOper_o3l - case("mls22" ); index_= iobOper_o3l - case("mls30" ); index_= iobOper_o3l - case("mls55" ); index_= iobOper_o3l - case("omieff" ); index_= iobOper_o3l - case("tomseff" ); index_= iobOper_o3l - case("ompslpuv" ); index_= iobOper_o3l - case("ompslpvis"); index_= iobOper_o3l - case("ompslp" ); index_= iobOper_o3l - - case("gpsbend","[gpsbendoper]"); index_= iobOper_gpsbend - case("gps_bnd"); index_= iobOper_gpsbend - - case("gpsref" ,"[gpsrefoper]" ); index_= iobOper_gpsref - case("gps_ref"); index_= iobOper_gpsref - - case("rad" ,"[radoper]" ); index_= iobOper_rad - ! - case("abi" ); index_= iobOper_rad - ! - case("amsua" ); index_= iobOper_rad - case("amsub" ); index_= iobOper_rad - case("msu" ); index_= iobOper_rad - case("mhs" ); index_= iobOper_rad - case("hirs2" ); index_= iobOper_rad - case("hirs3" ); index_= iobOper_rad - case("hirs4" ); index_= iobOper_rad - case("ssu" ); index_= iobOper_rad - ! - case("atms" ); index_= iobOper_rad - case("saphir" ); index_= iobOper_rad - ! - case("airs" ); index_= iobOper_rad - case("hsb" ); index_= iobOper_rad - ! - case("iasi" ); index_= iobOper_rad - case("cris" ); index_= iobOper_rad - case("cris-fsr" ); index_= iobOper_rad - ! - case("sndr" ); index_= iobOper_rad - case("sndrd1" ); index_= iobOper_rad - case("sndrd2" ); index_= iobOper_rad - case("sndrd3" ); index_= iobOper_rad - case("sndrd4" ); index_= iobOper_rad - ! - case("ssmi" ); index_= iobOper_rad - ! - case("amsre" ); index_= iobOper_rad - case("amsre_low"); index_= iobOper_rad - case("amsre_mid"); index_= iobOper_rad - case("amsre_hig"); index_= iobOper_rad - ! - case("ssmis" ); index_= iobOper_rad - case("ssmis_las"); index_= iobOper_rad - case("ssmis_uas"); index_= iobOper_rad - case("ssmis_img"); index_= iobOper_rad - case("ssmis_env"); index_= iobOper_rad - ! - case("amsr2" ); index_= iobOper_rad - case("goes_img"); index_= iobOper_rad - case("gmi" ); index_= iobOper_rad - case("seviri" ); index_= iobOper_rad - case("ahi" ); index_= iobOper_rad - ! - case("avhrr_navy"); index_= iobOper_rad - case("avhrr" ); index_= iobOper_rad - - case("tcp" ,"[tcpoper]" ); index_= iobOper_tcp - - !case("lag" ,"[lagoper]" ); index_= iobOper_lag - - case("colvk" ,"[colvkoper]" ); index_= iobOper_colvk - case("mopitt" ); index_= iobOper_colvk - - case("aero" ,"[aerooper]" ); index_= iobOper_aero - case("aod" ); index_= iobOper_aero - case("modis_aod"); index_= iobOper_aero - - !case("aerol" ,"[aeroloper]" ); index_= iobOper_aerol - - case("pm2_5" ,"[pm2_5oper]" ); index_= iobOper_pm2_5 - case("gust" ,"[gustoper]" ); index_= iobOper_gust - case("vis" ,"[visoper]" ); index_= iobOper_vis - case("pblh" ,"[pblhoper]" ); index_= iobOper_pblh - - case("wspd10m","[wspd10moper]"); index_= iobOper_wspd10m - case("uwnd10m","[uwnd10moper]"); index_= iobOper_uwnd10m - case("vwnd10m","[vwnd10moper]"); index_= iobOper_vwnd10m - - case("td2m" ,"[td2moper]" ); index_= iobOper_td2m - case("mxtm" ,"[mxtmoper]" ); index_= iobOper_mxtm - case("mitm" ,"[mitmoper]" ); index_= iobOper_mitm - case("pmsl" ,"[pmsloper]" ); index_= iobOper_pmsl - case("howv" ,"[howvoper]" ); index_= iobOper_howv - case("tcamt" ,"[tcamtoper]" ); index_= iobOper_tcamt - case("lcbas" ,"[lcbasoper]" ); index_= iobOper_lcbas - - case("pm10" ,"[pm10oper]" ); index_= iobOper_pm10 - case("cldch" ,"[cldchoper]" ); index_= iobOper_cldch - - case("swcp" ,"[swcpoper]" ); index_= iobOper_swcp - case("lwcp" ,"[lwcpoper]" ); index_= iobOper_lwcp - - case("light" ,"[lightoper]" ); index_= iobOper_light - case("goes_glm" ); index_= iobOper_light - - case("dbz" ,"[dbzoper]" ); index_= iobOper_dbz - - case("cldtot" ,"[cldtotoper]" ); index_= iobOper_cldtot - case("mta_cld" ); index_= iobOper_cldtot - - ! Known dtype values, but no known obOper type defined - case("gos_ctp"); index_= obOper_undef - case("rad_ref"); index_= obOper_undef - case("lghtn" ); index_= obOper_undef - case("larccld"); index_= obOper_undef - case("larcglb"); index_= obOper_undef - - ! A catch all case - case default ; index_= obOper_undef - end select -end function dtype2index_ - -function vmold2index_(mold) result(index_) - implicit none - integer(i_kind):: index_ - class(obOper),target,intent(in):: mold - - character(len=*),parameter:: myname_=myname//"::vmold2index_" - class(obOper),pointer:: ptr_ - ptr_ => mold - if(.not.associated(ptr_)) call die(myname_,'not assoicated, argument mold') - nullify(ptr_) - - index_=dtype2index_(mold%mytype()) - - ! An alternative implementation to cache a managed iobOper value inside each - ! obOper class. This implementation requires two new TBPs, %myinfo_get() and - ! %myinfo_set(). - ! - ! call mold%myinfo_get(iobOper=index_) - ! if(index_obOper_ubound) then - ! index_=dtype2index_(mold%mytype()) - ! call mold%myinfo_set(iobOper_=index_) - ! endif - -end function vmold2index_ - -function dtype2vmold_(dtype) result(vmold_) - implicit none - class(obOper),pointer:: vmold_ - character(len=*),intent(in):: dtype - - integer(i_kind):: iobOper_ - iobOper_ = dtype2index_(dtype) - vmold_ => index2vmold_(iobOper_) -end function dtype2vmold_ - -function index2vmold_(iobOper) result(vmold_) - implicit none - class(obOper),pointer:: vmold_ - integer(i_kind),intent(in):: iobOper - select case(iobOper) - - case(iobOper_ps ); vmold_ => psOper_mold - case(iobOper_t ); vmold_ => tOper_mold - case(iobOper_w ); vmold_ => wOper_mold - case(iobOper_q ); vmold_ => qOper_mold - case(iobOper_spd ); vmold_ => spdOper_mold - case(iobOper_rw ); vmold_ => rwOper_mold - case(iobOper_dw ); vmold_ => dwOper_mold - case(iobOper_sst ); vmold_ => sstOper_mold - case(iobOper_pw ); vmold_ => pwOper_mold - case(iobOper_pcp ); vmold_ => pcpOper_mold - case(iobOper_oz ); vmold_ => ozOper_mold - case(iobOper_o3l ); vmold_ => o3lOper_mold - case(iobOper_gpsbend ); vmold_ => gpsbendOper_mold - case(iobOper_gpsref ); vmold_ => gpsrefOper_mold - case(iobOper_rad ); vmold_ => radOper_mold - case(iobOper_tcp ); vmold_ => tcpOper_mold - !case(iobOper_lag ); vmold_ => lagOper_mold - case(iobOper_colvk ); vmold_ => colvkOper_mold - case(iobOper_aero ); vmold_ => aeroOper_mold - !case(iobOper_aerol ); vmold_ => aerolOper_mold - case(iobOper_pm2_5 ); vmold_ => pm2_5Oper_mold - case(iobOper_gust ); vmold_ => gustOper_mold - case(iobOper_vis ); vmold_ => visOper_mold - case(iobOper_pblh ); vmold_ => pblhOper_mold - case(iobOper_wspd10m ); vmold_ => wspd10mOper_mold - case(iobOper_td2m ); vmold_ => td2mOper_mold - case(iobOper_mxtm ); vmold_ => mxtmOper_mold - case(iobOper_mitm ); vmold_ => mitmOper_mold - case(iobOper_pmsl ); vmold_ => pmslOper_mold - case(iobOper_howv ); vmold_ => howvOper_mold - case(iobOper_tcamt ); vmold_ => tcamtOper_mold - case(iobOper_lcbas ); vmold_ => lcbasOper_mold - case(iobOper_pm10 ); vmold_ => pm10Oper_mold - case(iobOper_cldch ); vmold_ => cldchOper_mold - case(iobOper_uwnd10m ); vmold_ => uwnd10mOper_mold - case(iobOper_vwnd10m ); vmold_ => vwnd10mOper_mold - case(iobOper_swcp ); vmold_ => swcpOper_mold - case(iobOper_lwcp ); vmold_ => lwcpOper_mold - case(iobOper_light ); vmold_ => lightOper_mold - case(iobOper_dbz ); vmold_ => dbzOper_mold - case(iobOper_cldtot ); vmold_ => cldtotOper_mold - - case( obOper_undef ); vmold_ => null() - case default ; vmold_ => null() - end select -end function index2vmold_ - -function vmold2tinfo_(mold) result(info_) -!>> Simply mold%info(), but just in case one needs some indirection, with -!>> multiple obOper classes. - implicit none - character(len=:),allocatable:: info_ - class(obOper),target,intent(in):: mold - - character(len=*),parameter:: myname_=myname//"::vmold2tinfo_" - class(obOper),pointer:: vmold__ - vmold__ => mold - - if(.not.associated(vmold__)) call die(myname_,'not assoicated, argument mold') - nullify(vmold__) - - info_=index2tinfo_(vmold2index_(mold)) -end function vmold2tinfo_ - -function index2tinfo_(iobOper) result(info_) -!>> - implicit none - character(len=:),allocatable:: info_ - integer(i_kind),intent(in):: iobOper - - if(.not.cobstype_configured_) call cobstype_config_() - info_="" - if(iobOper>=obOper_lbound .and. & - iobOper<=obOper_ubound) info_=cobstype(iobOper) -end function index2tinfo_ - -subroutine config_() - implicit none - character(len=*),parameter:: myname_=myname//"::config_" - class(obOper),pointer:: vmold_ - integer(i_kind):: iset_,iget_ - logical:: good_ - - good_=.true. - do iset_ = obOper_lbound, obOper_ubound - vmold_ => index2vmold_(iset_) - if(.not.associated(vmold_)) then - call perr(myname_,'unexpected index, iset_ =',iset_) - call perr(myname_,' obOper_lbound =',obOper_lbound) - call perr(myname_,' obOper_ubound =',obOper_ubound) - call die(myname_) - endif - - iget_=iset_ ! for additional test. - !call vmold_%myinfo_set(iobOper=iset_) - !call vmold_%myinfo_get(iobOper=iget_) - if(iget_/=iset_) then - call perr(myname_,'unexpected return, %myinfo_get(iobOper) =',iget_) - call perr(myname_,' %myinfo_set(iobOper) =',iset_) - call perr(myname_,' %mytype() =',vmold_%mytype()) - good_=.false. - endif - - vmold_ => null() - enddo - if(.not.good_) call die(myname_) - - obOper_configured_ = .true. -end subroutine config_ - -subroutine cobstype_config_() -!>> Should this information be provided by individual obOper extensions, or -!>> be provided by this manager? There are pros and cons in either approach. - - implicit none - cobstype(iobOper_ps ) ="surface pressure " ! ps_ob_type - cobstype(iobOper_t ) ="temperature " ! t_ob_type - cobstype(iobOper_w ) ="wind " ! w_ob_type - cobstype(iobOper_q ) ="moisture " ! q_ob_type - cobstype(iobOper_spd ) ="wind speed " ! spd_ob_type - cobstype(iobOper_rw ) ="radial wind " ! rw_ob_type - cobstype(iobOper_dw ) ="doppler wind " ! dw_ob_type - cobstype(iobOper_sst ) ="sst " ! sst_ob_type - cobstype(iobOper_pw ) ="precipitable water " ! pw_ob_type - cobstype(iobOper_pcp ) ="precipitation " ! pcp_ob_type - cobstype(iobOper_oz ) ="ozone " ! oz_ob_type - cobstype(iobOper_o3l ) ="level ozone " ! o3l_ob_type - cobstype(iobOper_gpsbend ) ="gps bending angle " ! using gps_ob_type - cobstype(iobOper_gpsref ) ="gps refractivity " ! using gps_ob_type - cobstype(iobOper_rad ) ="radiance " ! rad_ob_type - cobstype(iobOper_tcp ) ="tcp (tropic cyclone)" ! tcp_ob_type - !cobstype(iobOper_lag ) ="lagrangian tracer " ! lag_ob_type - cobstype(iobOper_colvk ) ="carbon monoxide " ! colvk_ob_type - cobstype(iobOper_aero ) ="aerosol aod " ! aero_ob_type - !cobstype(iobOper_aerol ) ="level aero aod " ! aerol_ob_type - cobstype(iobOper_pm2_5 ) ="in-situ pm2_5 obs " ! pm2_5_ob_type - cobstype(iobOper_pm10 ) ="in-situ pm10 obs " ! pm10_ob_type - cobstype(iobOper_gust ) ="gust " ! gust_ob_type - cobstype(iobOper_vis ) ="vis " ! vis_ob_type - cobstype(iobOper_pblh ) ="pblh " ! pblh_ob_type - cobstype(iobOper_wspd10m ) ="wspd10m " ! wspd10m_ob_type - cobstype(iobOper_td2m ) ="td2m " ! td2m_ob_type - cobstype(iobOper_mxtm ) ="mxtm " ! mxtm_ob_type - cobstype(iobOper_mitm ) ="mitm " ! mitm_ob_type - cobstype(iobOper_pmsl ) ="pmsl " ! pmsl_ob_type - cobstype(iobOper_howv ) ="howv " ! howv_ob_type - cobstype(iobOper_tcamt ) ="tcamt " ! tcamt_ob_type - cobstype(iobOper_lcbas ) ="lcbas " ! lcbas_ob_type - cobstype(iobOper_cldch ) ="cldch " ! cldch_ob_type - cobstype(iobOper_uwnd10m ) ="uwnd10m " ! uwnd10m_ob_type - cobstype(iobOper_vwnd10m ) ="vwnd10m " ! vwnd10m_ob_type - cobstype(iobOper_swcp ) ="swcp " ! swcp_ob_type - cobstype(iobOper_lwcp ) ="lwcp " ! lwcp_ob_type - cobstype(iobOper_light ) ="light " ! light_ob_type - cobstype(iobOper_dbz ) ="dbz " ! dbz_ob_type - cobstype(iobOper_cldtot ) ="cldtot " ! using q_ob_type - - cobstype_configured_=.true. -end subroutine cobstype_config_ - -end module gsi_obOperTypeManager diff --git a/src/gsi/gsi_obOper.F90 b/src/gsi/gsi_oboper.F90 similarity index 54% rename from src/gsi/gsi_obOper.F90 rename to src/gsi/gsi_oboper.F90 index 0b07161590..bd50332602 100644 --- a/src/gsi/gsi_obOper.F90 +++ b/src/gsi/gsi_oboper.F90 @@ -1,15 +1,15 @@ -module gsi_obOper +module gsi_oboper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_obOper +! subprogram: module gsi_oboper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-06-26 ! -! abstract: GSI observation operator, bundling obs_diags and obsLList objects +! abstract: gsi observation operator, bundling obs_diags and obsllist objects ! ! program history log: -! 2018-06-26 j guo - a new module for abstract GSI obOper. +! 2018-06-26 j guo - a new module for abstract GSI oboper. ! ! input argument list: see Fortran 90 style document below ! @@ -23,141 +23,141 @@ module gsi_obOper ! module interface: - use m_obsdiagNode, only: obs_diags - use m_obsLList , only: obsLList + use m_obsdiagnode, only: obs_diags + use m_obsllist , only: obsllist use kinds, only: i_kind use mpeu_util, only: assert_ implicit none - private ! except - public :: obOper ! data structure + private ! except + public :: oboper ! data structure public :: len_obstype public :: len_isis - integer(i_kind),parameter:: len_obstype=10 - integer(i_kind),parameter:: len_isis =20 + integer(i_kind),parameter:: len_obstype=10 + integer(i_kind),parameter:: len_isis =20 - ! obOper is a bundle of observation operator arrays (or lists), such as - ! linked-lists of obs_diag (obs_diags) and obsNode (obsLList), plus type + ! oboper is a bundle of observation operator arrays (or lists), such as + ! linked-lists of obs_diag (obs_diags) and obsnode (obsllist), plus type ! specific parameters. ! - ! In this implementation, an obOper, with pointers _associated_ to - ! rank-1 arrays of obs_diags and obsLList, where both targets are + ! In this implementation, an oboper, with pointers _associated_ to + ! rank-1 arrays of obs_diags and obsllist, where both targets are ! instantiated separately with own fixed dimensions in nobs_type and ! nobs_bins. ! - ! It is planned in the future, to implement an obOper _contains_ dynamic + ! It is planned in the future, to implement an oboper _contains_ dynamic ! components of these rank-1 arrays. - type,abstract:: obOper + type,abstract:: oboper !private - ! In the first obOper implementation, %obsLL(:) and odiagLL(:) are + ! In the first oboper implementation, %obsll(:) and odiagll(:) are ! treated as aliases to the instances of m_obsdiags::obsdiags(:,:) and - ! m_obsdiagss::obsLLists(:,:). Both linked-lists are dimensioned for + ! m_obsdiagss::obsllists(:,:). Both linked-lists are dimensioned for ! 1:nobs_type in the current implementation, and accesssed once per type ! and per bin, in intjo() and stpjo(). ! - ! On the other hand, in the current setuprhsall() implementation, obOper + ! On the other hand, in the current setuprhsall() implementation, oboper ! objects are accessed for 1:ndat, or once per obs-stream, where each ! type is in general accessed in zero or multiple times. - type(obs_diags),pointer,dimension(:):: odiagLL ! (1:nobs_bins) - type(obsLList ),pointer,dimension(:):: obsLL ! (1:nobs_bins) + type(obs_diags),pointer,dimension(:):: odiagll ! (1:nobs_bins) + type(obsllist ),pointer,dimension(:):: obsll ! (1:nobs_bins) - contains - procedure(mytype ),deferred,nopass:: mytype ! type information - procedure(nodeMold),deferred,nopass:: nodeMold ! type information + contains + procedure(mytype ),deferred,nopass:: mytype ! type information + procedure(nodemold),deferred,nopass:: nodemold ! type information - procedure, non_overridable:: init => init_ ! initialize - procedure, non_overridable:: clean => clean_ ! finalize + procedure, non_overridable:: init => init_ ! initialize + procedure, non_overridable:: clean => clean_ ! finalize - generic:: setup => setup_ - procedure(setup_ ),deferred:: setup_ ! incremental object initialization - generic:: intjo => intjo_, intjo1_ - procedure, non_overridable:: intjo_ ! interface supporting intjo() - procedure(intjo1_),deferred:: intjo1_ ! interface for 1-bin intjo() - generic:: stpjo => stpjo_, stpjo1_ - procedure, non_overridable:: stpjo_ ! interface supporting stpjo() - procedure(stpjo1_),deferred:: stpjo1_ ! interface for 1-bin stpjo() + generic:: setup => setup_ + procedure(setup_ ),deferred:: setup_ ! incremental object initialization + generic:: intjo => intjo_, intjo1_ + procedure, non_overridable:: intjo_ ! interface supporting intjo() + procedure(intjo1_),deferred:: intjo1_ ! interface for 1-bin intjo() + generic:: stpjo => stpjo_, stpjo1_ + procedure, non_overridable:: stpjo_ ! interface supporting stpjo() + procedure(stpjo1_),deferred:: stpjo1_ ! interface for 1-bin stpjo() - end type obOper + end type oboper ! In setuprhsall(), ! - ! | use m_obsdiags, only: obOper_associate, obOper_dissociate - ! | use gsi_obOper, only: obOper - ! | use gsi_obOperTypeManager, only: obOper_typeMold + ! | use m_obsdiags, only: oboper_associate, oboper_dissociate + ! | use gsi_oboper, only: oboper + ! | use gsi_obopertypemanager, only: oboper_typemold ! | use obsmod, only: ndat,dtype ! ! then in a loop of obs-streams ! - ! | class(obOper),pointer:: my_obOper + ! | class(oboper),pointer:: my_oboper ! | do is=1,ndat - ! | my_obOper => obOper_associate(obOper_typeMold(dtype(is))) - ! | call my_obOper%setup(...) - ! | call obOper_dissociate(my_obOper) + ! | my_oboper => oboper_associate(oboper_typemold(dtype(is))) + ! | call my_oboper%setup(...) + ! | call oboper_dissociate(my_oboper) ! | enddo ! ! In intjo() or stpjo(), ! - ! | use gsi_obOperTypeManager, only: lbound_obOper - ! | use gsi_obOperTypeManager, only: ubound_obOper - ! | use gsi_obOperTypeManager, only: obOper_typeMold + ! | use gsi_obopertypemanager, only: lbound_oboper + ! | use gsi_obopertypemanager, only: ubound_oboper + ! | use gsi_obopertypemanager, only: oboper_typemold ! - ! then in a loop of obOper + ! then in a loop of oboper ! - ! | class(obOper),pointer:: my_obOper - ! | do iOp=lbound_obOper,ubound_obOper - ! | my_obOper => obOper_associate(obOper_typeMold(iOp)) - ! | call my_obOper%intjo(...) - ! | call obOper_dissociate(my_obOper) + ! | class(oboper),pointer:: my_oboper + ! | do iop=lbound_oboper,ubound_oboper + ! | my_oboper => oboper_associate(oboper_typemold(iOp)) + ! | call my_oboper%intjo(...) + ! | call oboper_dissociate(my_oboper) ! | enddo -!--- Design Considerations --- -! (1) Fully objectize obOper, meaning, capable of being instantiated where and +!--- Design considerations --- +! (1) Fully objectize oboper, meaning, capable of being instantiated where and ! when it is needed. ! ! ! (2) For continuity, its instantiation is a type-indexed array of polymorphic -! class(obOper), containing rank-1 pointers aliased to obsLList(1:nobs_bins) -! and diagLList(1:nobs_bins). This means its current instantiation is +! class(oboper), containing rank-1 pointers aliased to obsllist(1:nobs_bins) +! and diagllist(1:nobs_bins). This means its current instantiation is ! declared based on a type-wrapper-array structure, ! -! type,abstract:: obOper; ... -! type:: obOper_element; class(obOper),pointer:: ptr; ... -! type(obOper_element),dimension(nobs_type):: obopers +! type,abstract:: oboper; ... +! type:: oboper_element; class(oboper),pointer:: ptr; ... +! type(oboper_element),dimension(nobs_type):: obopers ! ! defined in a type-loop, (m_obsdiags?) ! -! allocate(obopers(it)%ptr,mold=obOper_typeMold(it)) +! allocate(obopers(it)%ptr,mold=oboper_typemold(it)) ! -! | oboper_typeMold(it) result(mold) +! | oboper_typemold(it) result(mold) ! | select case(it) -! | case(iobType_rad); mold => radOper_mold() -! | case ... +! | case(iobtype_rad); mold => radoper_mold() +! | case ... ! ! followed by ! ! associate(i_op => obopers(...)%ptr) -! call i_op%init(...) # type-bound init(), with a line of -! # self%nodetype=obOper%mytype(nodetype=.true.) +! call i_op%init(...) # type-bound init(), with a line of +! # self%nodetype=oboper%mytype(nodetype=.true.) ! end associate ! ! -! (3) In future implementations, one might want to define obOper on a per-stream +! (3) In future implementations, one might want to define oboper on a per-stream ! base. Then it would be instantiated in a stream-loop, ! -! allocate(obopers(is)%ptr,mold=obOper_typeMold(dtype(is))) +! allocate(obopers(is)%ptr,mold=oboper_typemold(dtype(is))) ! -! | oboper_typeMold(dtype) result(mold) +! | oboper_typemold(dtype) result(mold) ! | select case(dtype) -! | case("rad","amsua",...); mold => radOper_mold() -! | case ... +! | case("rad","amsua",...); mold => radoper_mold() +! | case ... ! -! (4) So types of obOpers are now one-to-one mapped to obsNode types. This means -! that each obOper type must be hardwired to a known obsNode type, while -! dtype(:) to obOpers(:) types are not. +! (4) So types of obopers are now one-to-one mapped to obsnode types. This means +! that each oboper type must be hardwired to a known obsnode type, while +! dtype(:) to obopers(:) types are not. ! !--------- interfaces @@ -167,46 +167,46 @@ function mytype(nodetype) ! %mytype(nodetype=.true.) for self's corresponding node type name implicit none character(len=:), allocatable:: mytype - logical, optional, intent(in):: nodetype ! if .true., return %mytype() of its obsNode + logical, optional, intent(in):: nodetype ! if .true., return %mytype() of its obsnode ! logical:: nodetype_ ! nodetype_=.false. ! if(present(nodetype)) nodetype_=nodetype ! if(nodetype_) then - ! if(nodetype) mytype=myNodeMold_%mytype() + ! if(nodetype) mytype=mynodemold_%mytype() ! else - ! mytype="[radOper]" + ! mytype="[radoper]" ! endif end function mytype end interface abstract interface - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold + class(obsnode),pointer:: nodemold !> For a given - !> type(someOper):: myOper + !> type(someoper):: myoper !> !> then code !> - !> class(obsNode),pointer:: myNodeMold_ - !> myNodeMold_ => myOper%nodeMold() + !> class(obsnode),pointer:: mynodemold_ + !> mynodemold_ => myoper%nodemold() !> - !> would return a mold of myOper's corresponding obsNode type + !> would return a mold of myoper's corresponding obsnode type - end function nodeMold + end function nodemold end interface abstract interface subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use kinds, only: i_kind - import:: obOper + import:: oboper implicit none - class(obOper ), intent(inout):: self + class(oboper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -214,7 +214,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) logical , intent(in):: init_pass ! supporting multi-pass setup() logical , intent(in):: last_pass ! with incremental backgrounds. - ! An example in radOper%setup(), + ! An example in radoper%setup(), ! ! if(nobs == 0) return ! @@ -222,7 +222,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) ! if(ier/=0) call die(myname_,'read(), iostat =',ier) ! nele=nreal+nchanl ! - ! call setuprad(self%obsLL(:),self%odiagLL(:), lunin, mype, & + ! call setuprad(self%obsll(:),self%odiagll(:), lunin, mype, & ! aivals,stats,nchanl,nreal,nobs,obstype,isis,is,rad_diagsave,init_pass,last_pass) end subroutine setup_ @@ -236,21 +236,21 @@ subroutine intjo1_(self, ibin, rval, sval, qpred, sbias) use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use kinds , only: i_kind, r_quad - import:: obOper + import:: oboper implicit none - class(obOper ), intent(in ):: self + class(oboper ), intent(in ):: self integer(i_kind ), intent(in ):: ibin type(gsi_bundle), intent(inout):: rval type(gsi_bundle), intent(in ):: sval real(r_quad ), target, dimension(:),intent(inout):: qpred ! a buffer of rbias type(predictors), target, intent(in ):: sbias - ! This implementation can be used both to an obOper instance with - ! multiple bins, or a "slice" of obOper instance with a single bin, + ! This implementation can be used both to an oboper instance with + ! multiple bins, or a "slice" of oboper instance with a single bin, ! where the slice of self contains arrays (ibin:ibin) of components. - !do ibin=lbound(self%obsLL,1),ubound(self%obsLL,1) - ! call self%intjo(ibin, rval(ibin),sval(ibin), qpred(:,ibin),sbias) + !do ibin=lbound(self%obsll,1),ubound(self%obsll,1) + ! call self%intjo(ibin, rval(ibin),sval(ibin), qpred(:,ibin),sbias) !enddo end subroutine intjo1_ end interface @@ -263,9 +263,9 @@ subroutine stpjo1_(self, ibin,dval,xval,pbcjo,sges,nstep,dbias,xbias) use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use kinds , only: r_quad,r_kind,i_kind - import:: obOper + import:: oboper implicit none - class(obOper ),intent(in):: self + class(oboper ),intent(in):: self integer(i_kind),intent(in):: ibin type(gsi_bundle),intent(in ):: dval @@ -281,26 +281,26 @@ end subroutine stpjo1_ !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter:: myname="gsi_obOper" + character(len=*),parameter:: myname="gsi_oboper" contains #include "myassert.H" -subroutine init_(self,obsLL,odiagLL) +subroutine init_(self,obsll,odiagll) implicit none - class(obOper),intent(inout):: self - type(obsLList ),target,dimension(:),intent(in):: obsLL - type(obs_diags),target,dimension(:),intent(in):: odiagLL + class(oboper),intent(inout):: self + type(obsllist ),target,dimension(:),intent(in):: obsll + type(obs_diags),target,dimension(:),intent(in):: odiagll - self%odiagLL => odiagLL(:) - self% obsLL => obsLL(:) + self%odiagll => odiagll(:) + self% obsll => obsll(:) end subroutine init_ subroutine clean_(self) implicit none - class(obOper),intent(inout):: self - self%odiagLL => null() - self% obsLL => null() + class(oboper),intent(inout):: self + self%odiagll => null() + self% obsll => null() end subroutine clean_ subroutine intjo_(self, rval,sval,qpred,sbias) @@ -308,7 +308,7 @@ subroutine intjo_(self, rval,sval,qpred,sbias) use bias_predictors, only: predictors use kinds, only: i_kind, r_quad implicit none - class(obOper ), intent(in):: self + class(oboper ), intent(in):: self type(gsi_bundle), dimension(: ),intent(inout):: rval type(gsi_bundle), dimension(: ),intent(in ):: sval real(r_quad ), dimension(:,:),intent(inout):: qpred @@ -316,26 +316,26 @@ subroutine intjo_(self, rval,sval,qpred,sbias) ! nb=nobs_bins ! do ityp=1,nobs_type - ! iop => obOper_associate(mold=obOper_typemold(ityp)) + ! iop => oboper_associate(mold=oboper_typemold(ityp)) ! call iop%intjo(rval(:nb),sval(:nb), qpred(:,:nb),sbias) - ! call obOper_dissociate(iop) + ! call oboper_dissociate(iop) ! enddo ! - ! This implementation can be used both to an obOper instance with - ! multiple bins, or a "slice" of obOper instance with a single bin, + ! This implementation can be used both to an oboper instance with + ! multiple bins, or a "slice" of oboper instance with a single bin, ! where the slice of self contains arrays (ibin:ibin) of components. character(len=*),parameter:: myname_=myname//"::intjo_" integer(i_kind):: lbnd,ubnd,ibin - lbnd = lbound(self%obsLL,1) - ubnd = ubound(self%obsLL,1) + lbnd = lbound(self%obsll,1) + ubnd = ubound(self%obsll,1) ASSERT(lbnd == lbound( rval,1) .and. ubnd == ubound( rval,1)) ASSERT(lbnd == lbound( sval,1) .and. ubnd == ubound( sval,1)) ASSERT(lbnd == lbound(qpred,2) .and. ubnd == ubound(qpred,2)) do ibin=lbnd,ubnd - call self%intjo(ibin,rval(ibin),sval(ibin),qpred(:,ibin),sbias) + call self%intjo(ibin,rval(ibin),sval(ibin),qpred(:,ibin),sbias) enddo end subroutine intjo_ @@ -344,7 +344,7 @@ subroutine stpjo_(self, dval,xval, pbcjo,sges,nstep, dbias,xbias) use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors implicit none - class(obOper ),intent(in):: self + class(oboper ),intent(in):: self type(gsi_bundle),dimension( :),intent(in ):: dval type(gsi_bundle),dimension( :),intent(in ):: xval real(r_quad ),dimension(:,:),intent(inout):: pbcjo ! (1:4,1:nbin) @@ -356,15 +356,15 @@ subroutine stpjo_(self, dval,xval, pbcjo,sges,nstep, dbias,xbias) integer(i_kind):: lbnd,ubnd,ibin - lbnd = lbound(self%obsLL,1) - ubnd = ubound(self%obsLL,1) + lbnd = lbound(self%obsll,1) + ubnd = ubound(self%obsll,1) ASSERT(lbnd == lbound( dval,1) .and. ubnd == ubound( dval,1)) ASSERT(lbnd == lbound( xval,1) .and. ubnd == ubound( xval,1)) ASSERT(lbnd == lbound(pbcjo,2) .and. ubnd == ubound(pbcjo,2)) do ibin=lbnd,ubnd - call self%stpjo(ibin,dval(ibin),xval(ibin),pbcjo(:,ibin),sges,nstep,dbias,xbias) + call self%stpjo(ibin,dval(ibin),xval(ibin),pbcjo(:,ibin),sges,nstep,dbias,xbias) enddo end subroutine stpjo_ -end module gsi_obOper +end module gsi_oboper !. diff --git a/src/gsi/gsi_obopertypemanager.f90 b/src/gsi/gsi_obopertypemanager.f90 new file mode 100644 index 0000000000..a4a79c61a6 --- /dev/null +++ b/src/gsi/gsi_obopertypemanager.f90 @@ -0,0 +1,606 @@ +module gsi_obopertypemanager +!$$$ subprogram documentation block +! . . . . +! subprogram: module gsi_obopertypemanager +! prgmmr: j guo +! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 +! date: 2018-07-12 +! +! abstract: GSI observation operator (oboper) type manager +! +! program history log: +! 2018-07-12 j guo - a type-manager for all oboper extensions. +! - an enum mapping of obsinput::dtype(:) to oboper type +! extensions. +! +! input argument list: see Fortran 90 style document below +! +! output argument list: see Fortran 90 style document below +! +! attributes: +! language: Fortran 90 and/or above +! machine: +! +!$$$ end subprogram documentation block + +! module interface: + + use gsi_oboper, only: oboper + + use gsi_aerooper , only: aerooper + use gsi_cldchoper , only: cldchoper + use gsi_colvkoper , only: colvkoper + use gsi_dwoper , only: dwoper + use gsi_gpsbendoper , only: gpsbendoper + use gsi_gpsrefoper , only: gpsrefoper + use gsi_gustoper , only: gustoper + use gsi_howvoper , only: howvoper + use gsi_lcbasoper , only: lcbasoper + use gsi_lwcpoper , only: lwcpoper + use gsi_mitmoper , only: mitmoper + use gsi_mxtmoper , only: mxtmoper + use gsi_o3loper , only: o3loper + use gsi_ozoper , only: ozoper + use gsi_pblhoper , only: pblhoper + use gsi_pcpoper , only: pcpoper + use gsi_pm10oper , only: pm10oper + use gsi_pm2_5oper , only: pm2_5oper + use gsi_pmsloper , only: pmsloper + use gsi_psoper , only: psoper + use gsi_pwoper , only: pwoper + use gsi_qoper , only: qoper + use gsi_radoper , only: radoper + use gsi_rwoper , only: rwoper + use gsi_spdoper , only: spdoper + use gsi_sstoper , only: sstoper + use gsi_swcpoper , only: swcpoper + use gsi_tcamtoper , only: tcamtoper + use gsi_tcpoper , only: tcpoper + use gsi_td2moper , only: td2moper + use gsi_toper , only: toper + use gsi_uwnd10moper , only: uwnd10moper + use gsi_visoper , only: visoper + use gsi_vwnd10moper , only: vwnd10moper + use gsi_woper , only: woper + use gsi_wspd10moper , only: wspd10moper + + use gsi_lightoper , only: lightoper + use gsi_dbzoper , only: dbzoper + use gsi_cldtotoper , only: cldtotoper + + use kinds , only: i_kind + use mpeu_util , only: perr,die + implicit none + private ! except + + public:: oboper_typeMold + public:: oboper_typeIndex + public:: oboper_typeInfo + interface oboper_typeMold; module procedure & + dtype2vmold_, & + index2vmold_ ; end interface + interface oboper_typeIndex; module procedure & + vmold2index_, & + dtype2index_ ; end interface + interface oboper_typeInfo; module procedure & + vmold2tinfo_, & + index2tinfo_ ; end interface + + !public:: oboper_config + ! interface oboper_config; module procedure config_; end interface + + public:: oboper_undef + public:: oboper_lbound + public:: oboper_ubound + !public:: oboper_size + public:: oboper_count + + public:: ioboper_kind + public:: ioboper_ps + public:: ioboper_t + public:: ioboper_w + public:: ioboper_q + public:: ioboper_spd + public:: ioboper_rw + public:: ioboper_dw + public:: ioboper_sst + public:: ioboper_pw + public:: ioboper_pcp + public:: ioboper_oz + public:: ioboper_o3l + public:: ioboper_gpsbend + public:: ioboper_gpsref + public:: ioboper_rad + public:: ioboper_tcp + !public:: ioboper_lag + public:: ioboper_colvk + public:: ioboper_aero + !public:: ioboper_aerol + public:: ioboper_pm2_5 + public:: ioboper_gust + public:: ioboper_vis + public:: ioboper_pblh + public:: ioboper_wspd10m + public:: ioboper_td2m + public:: ioboper_mxtm + public:: ioboper_mitm + public:: ioboper_pmsl + public:: ioboper_howv + public:: ioboper_tcamt + public:: ioboper_lcbas + public:: ioboper_pm10 + public:: ioboper_cldch + public:: ioboper_uwnd10m + public:: ioboper_vwnd10m + public:: ioboper_swcp + public:: ioboper_lwcp + public:: ioboper_light + public:: ioboper_dbz + public:: ioboper_cldtot + + enum, bind(c) + enumerator:: ioboper_zero_ = 0 + + enumerator:: ioboper_ps + enumerator:: ioboper_t + enumerator:: ioboper_w + enumerator:: ioboper_q + enumerator:: ioboper_spd + enumerator:: ioboper_rw + enumerator:: ioboper_dw + enumerator:: ioboper_sst + enumerator:: ioboper_pw + enumerator:: ioboper_pcp + enumerator:: ioboper_oz + enumerator:: ioboper_o3l + enumerator:: ioboper_gpsbend + enumerator:: ioboper_gpsref + enumerator:: ioboper_rad + enumerator:: ioboper_tcp + !enumerator:: ioboper_lag + enumerator:: ioboper_colvk + enumerator:: ioboper_aero + !enumerator:: ioboper_aerol + enumerator:: ioboper_pm2_5 + enumerator:: ioboper_gust + enumerator:: ioboper_vis + enumerator:: ioboper_pblh + enumerator:: ioboper_wspd10m + enumerator:: ioboper_td2m + enumerator:: ioboper_mxtm + enumerator:: ioboper_mitm + enumerator:: ioboper_pmsl + enumerator:: ioboper_howv + enumerator:: ioboper_tcamt + enumerator:: ioboper_lcbas + enumerator:: ioboper_pm10 + enumerator:: ioboper_cldch + enumerator:: ioboper_uwnd10m + enumerator:: ioboper_vwnd10m + enumerator:: ioboper_swcp + enumerator:: ioboper_lwcp + enumerator:: ioboper_light + enumerator:: ioboper_dbz + enumerator:: ioboper_cldtot + + enumerator:: ioboper_extra_ + end enum + + integer(i_kind),parameter:: enum_kind = kind(ioboper_zero_) + integer(i_kind),parameter:: ioboper_kind = enum_kind + + integer(enum_kind),parameter:: oboper_undef = -1_enum_kind + integer(enum_kind),parameter:: oboper_lbound = ioboper_zero_ +1 + integer(enum_kind),parameter:: oboper_ubound = ioboper_extra_-1 + integer(enum_kind),parameter:: oboper_size = oboper_ubound-oboper_lbound+1 + integer(enum_kind),parameter:: oboper_count = oboper_size + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + character(len=*),parameter :: myname='gsi_obopertypemanager' + logical,save:: oboper_configured_ = .false. + + character(len=20),dimension(oboper_lbound:oboper_ubound):: cobstype + logical,save:: cobstype_configured_=.false. + + type( psoper), target, save:: psoper_mold + type( toper), target, save:: toper_mold + type( woper), target, save:: woper_mold + type( qoper), target, save:: qoper_mold + type( spdoper), target, save:: spdoper_mold + type( rwoper), target, save:: rwoper_mold + type( dwoper), target, save:: dwoper_mold + type( sstoper), target, save:: sstoper_mold + type( pwoper), target, save:: pwoper_mold + type( pcpoper), target, save:: pcpoper_mold + type( ozoper), target, save:: ozoper_mold + type( o3loper), target, save:: o3loper_mold + type(gpsbendoper), target, save:: gpsbendoper_mold + type( gpsrefoper), target, save:: gpsrefoper_mold + type( radoper), target, save:: radoper_mold + type( tcpoper), target, save:: tcpoper_mold + !type( lagoper), target, save:: lagoper_mold + type( colvkoper), target, save:: colvkoper_mold + type( aerooper), target, save:: aerooper_mold + !type( aeroloper), target, save:: aeroloper_mold + type( pm2_5oper), target, save:: pm2_5oper_mold + type( gustoper), target, save:: gustoper_mold + type( visoper), target, save:: visoper_mold + type( pblhoper), target, save:: pblhoper_mold + type(wspd10moper), target, save:: wspd10moper_mold + type( td2moper), target, save:: td2moper_mold + type( mxtmoper), target, save:: mxtmoper_mold + type( mitmoper), target, save:: mitmoper_mold + type( pmsloper), target, save:: pmsloper_mold + type( howvoper), target, save:: howvoper_mold + type( tcamtoper), target, save:: tcamtoper_mold + type( lcbasoper), target, save:: lcbasoper_mold + type( pm10oper), target, save:: pm10oper_mold + type( cldchoper), target, save:: cldchoper_mold + type(uwnd10moper), target, save:: uwnd10moper_mold + type(vwnd10moper), target, save:: vwnd10moper_mold + type( swcpoper), target, save:: swcpoper_mold + type( lwcpoper), target, save:: lwcpoper_mold + type( lightoper), target, save:: lightoper_mold + type( dbzoper), target, save:: dbzoper_mold + type( cldtotoper), target, save:: cldtotoper_mold + +contains +function dtype2index_(dtype) result(index_) + use mpeu_util, only: lowercase + implicit none + integer(i_kind):: index_ + character(len=*),intent(in):: dtype + + select case(lowercase(dtype)) + case("ps" ,"[psoper]" ); index_= ioboper_ps + case("t" ,"[toper]" ); index_= ioboper_t + + case("w" ,"[woper]" ); index_= ioboper_w + case("uv" ); index_= ioboper_w + + case("q" ,"[qoper]" ); index_= ioboper_q + case("spd" ,"[spdoper]" ); index_= ioboper_spd + case("rw" ,"[rwoper]" ); index_= ioboper_rw + case("dw" ,"[dwoper]" ); index_= ioboper_dw + case("sst" ,"[sstoper]" ); index_= ioboper_sst + case("pw" ,"[pwoper]" ); index_= ioboper_pw + + case("pcp" ,"[pcpoper]" ); index_= ioboper_pcp + case("pcp_ssmi"); index_= ioboper_pcp + case("pcp_tmi" ); index_= ioboper_pcp + + case("oz" ,"[ozoper]" ); index_= ioboper_oz + case("sbuv2" ); index_= ioboper_oz + case("omi" ); index_= ioboper_oz + case("gome" ); index_= ioboper_oz + case("ompstc8"); index_= ioboper_oz + case("ompsnp" ); index_= ioboper_oz + case("ompsnm" ); index_= ioboper_oz + + case("o3l" ,"[o3loper]" ); index_= ioboper_o3l + case("o3lev" ); index_= ioboper_o3l + case("mls20" ); index_= ioboper_o3l + case("mls22" ); index_= ioboper_o3l + case("mls30" ); index_= ioboper_o3l + case("mls55" ); index_= ioboper_o3l + case("omieff" ); index_= ioboper_o3l + case("tomseff" ); index_= ioboper_o3l + case("ompslpuv" ); index_= ioboper_o3l + case("ompslpvis"); index_= ioboper_o3l + case("ompslp" ); index_= ioboper_o3l + + case("gpsbend","[gpsbendoper]"); index_= ioboper_gpsbend + case("gps_bnd"); index_= ioboper_gpsbend + + case("gpsref" ,"[gpsrefoper]" ); index_= ioboper_gpsref + case("gps_ref"); index_= ioboper_gpsref + + case("rad" ,"[radoper]" ); index_= ioboper_rad + ! + case("abi" ); index_= ioboper_rad + ! + case("amsua" ); index_= ioboper_rad + case("amsub" ); index_= ioboper_rad + case("msu" ); index_= ioboper_rad + case("mhs" ); index_= ioboper_rad + case("hirs2" ); index_= ioboper_rad + case("hirs3" ); index_= ioboper_rad + case("hirs4" ); index_= ioboper_rad + case("ssu" ); index_= ioboper_rad + ! + case("atms" ); index_= ioboper_rad + case("saphir" ); index_= ioboper_rad + ! + case("airs" ); index_= ioboper_rad + case("hsb" ); index_= ioboper_rad + ! + case("iasi" ); index_= ioboper_rad + case("cris" ); index_= ioboper_rad + case("cris-fsr" ); index_= ioboper_rad + ! + case("sndr" ); index_= ioboper_rad + case("sndrd1" ); index_= ioboper_rad + case("sndrd2" ); index_= ioboper_rad + case("sndrd3" ); index_= ioboper_rad + case("sndrd4" ); index_= ioboper_rad + ! + case("ssmi" ); index_= ioboper_rad + ! + case("amsre" ); index_= ioboper_rad + case("amsre_low"); index_= ioboper_rad + case("amsre_mid"); index_= ioboper_rad + case("amsre_hig"); index_= ioboper_rad + ! + case("ssmis" ); index_= ioboper_rad + case("ssmis_las"); index_= ioboper_rad + case("ssmis_uas"); index_= ioboper_rad + case("ssmis_img"); index_= ioboper_rad + case("ssmis_env"); index_= ioboper_rad + ! + case("amsr2" ); index_= ioboper_rad + case("goes_img"); index_= ioboper_rad + case("gmi" ); index_= ioboper_rad + case("seviri" ); index_= ioboper_rad + case("ahi" ); index_= ioboper_rad + ! + case("avhrr_navy"); index_= ioboper_rad + case("avhrr" ); index_= ioboper_rad + + case("tcp" ,"[tcpoper]" ); index_= ioboper_tcp + +! case("lag" ,"[lagoper]" ); index_= ioboper_lag + + case("colvk" ,"[colvkoper]" ); index_= ioboper_colvk + case("mopitt" ); index_= ioboper_colvk + + case("aero" ,"[aerooper]" ); index_= ioboper_aero + case("aod" ); index_= ioboper_aero + case("modis_aod"); index_= ioboper_aero + +! case("aerol" ,"[aeroloper]" ); index_= ioboper_aerol + + case("pm2_5" ,"[pm2_5oper]" ); index_= ioboper_pm2_5 + case("gust" ,"[gustoper]" ); index_= ioboper_gust + case("vis" ,"[visoper]" ); index_= ioboper_vis + case("pblh" ,"[pblhoper]" ); index_= ioboper_pblh + + case("wspd10m","[wspd10moper]"); index_= ioboper_wspd10m + case("uwnd10m","[uwnd10moper]"); index_= ioboper_uwnd10m + case("vwnd10m","[vwnd10moper]"); index_= ioboper_vwnd10m + + case("td2m" ,"[td2moper]" ); index_= ioboper_td2m + case("mxtm" ,"[mxtmoper]" ); index_= ioboper_mxtm + case("mitm" ,"[mitmoper]" ); index_= ioboper_mitm + case("pmsl" ,"[pmsloper]" ); index_= ioboper_pmsl + case("howv" ,"[howvoper]" ); index_= ioboper_howv + case("tcamt" ,"[tcamtoper]" ); index_= ioboper_tcamt + case("lcbas" ,"[lcbasoper]" ); index_= ioboper_lcbas + + case("pm10" ,"[pm10oper]" ); index_= ioboper_pm10 + case("cldch" ,"[cldchoper]" ); index_= ioboper_cldch + + case("swcp" ,"[swcpoper]" ); index_= ioboper_swcp + case("lwcp" ,"[lwcpoper]" ); index_= ioboper_lwcp + + case("light" ,"[lightoper]" ); index_= ioboper_light + case("goes_glm" ); index_= ioboper_light + + case("dbz" ,"[dbzoper]" ); index_= ioboper_dbz + + case("cldtot" ,"[cldtotoper]" ); index_= ioboper_cldtot + case("mta_cld" ); index_= ioboper_cldtot + + ! Known dtype values, but no known oboper type defined + case("gos_ctp"); index_= oboper_undef + case("rad_ref"); index_= oboper_undef + case("lghtn" ); index_= oboper_undef + case("larccld"); index_= oboper_undef + case("larcglb"); index_= oboper_undef + + ! A catch all case + case default ; index_= oboper_undef + end select +end function dtype2index_ + +function vmold2index_(mold) result(index_) + implicit none + integer(i_kind):: index_ + class(oboper),target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//"::vmold2index_" + class(oboper),pointer:: ptr_ + ptr_ => mold + if(.not.associated(ptr_)) call die(myname_,'not assoicated, argument mold') + nullify(ptr_) + + index_=dtype2index_(mold%mytype()) + + ! An alternative implementation to cache a managed ioboper value inside each + ! oboper class. This implementation requires two new tbps, %myinfo_get() and + ! %myinfo_set(). + ! + ! call mold%myinfo_get(ioboper=index_) + ! if(index_oboper_ubound) then + ! index_=dtype2index_(mold%mytype()) + ! call mold%myinfo_set(ioboper_=index_) + ! endif + +end function vmold2index_ + +function dtype2vmold_(dtype) result(vmold_) + implicit none + class(oboper),pointer:: vmold_ + character(len=*),intent(in):: dtype + + integer(i_kind):: ioboper_ + ioboper_ = dtype2index_(dtype) + vmold_ => index2vmold_(ioboper_) +end function dtype2vmold_ + +function index2vmold_(ioboper) result(vmold_) + implicit none + class(oboper),pointer:: vmold_ + integer(i_kind),intent(in):: ioboper + select case(ioboper) + + case(ioboper_ps ); vmold_ => psoper_mold + case(ioboper_t ); vmold_ => toper_mold + case(ioboper_w ); vmold_ => woper_mold + case(ioboper_q ); vmold_ => qoper_mold + case(ioboper_spd ); vmold_ => spdoper_mold + case(ioboper_rw ); vmold_ => rwoper_mold + case(ioboper_dw ); vmold_ => dwoper_mold + case(ioboper_sst ); vmold_ => sstoper_mold + case(ioboper_pw ); vmold_ => pwoper_mold + case(ioboper_pcp ); vmold_ => pcpoper_mold + case(ioboper_oz ); vmold_ => ozoper_mold + case(ioboper_o3l ); vmold_ => o3loper_mold + case(ioboper_gpsbend ); vmold_ => gpsbendoper_mold + case(ioboper_gpsref ); vmold_ => gpsrefoper_mold + case(ioboper_rad ); vmold_ => radoper_mold + case(ioboper_tcp ); vmold_ => tcpoper_mold + !case(ioboper_lag ); vmold_ => lagoper_mold + case(ioboper_colvk ); vmold_ => colvkoper_mold + case(ioboper_aero ); vmold_ => aerooper_mold + !case(ioboper_aerol ); vmold_ => aeroloper_mold + case(ioboper_pm2_5 ); vmold_ => pm2_5oper_mold + case(ioboper_gust ); vmold_ => gustoper_mold + case(ioboper_vis ); vmold_ => visoper_mold + case(ioboper_pblh ); vmold_ => pblhoper_mold + case(ioboper_wspd10m ); vmold_ => wspd10moper_mold + case(ioboper_td2m ); vmold_ => td2moper_mold + case(ioboper_mxtm ); vmold_ => mxtmoper_mold + case(ioboper_mitm ); vmold_ => mitmoper_mold + case(ioboper_pmsl ); vmold_ => pmsloper_mold + case(ioboper_howv ); vmold_ => howvoper_mold + case(ioboper_tcamt ); vmold_ => tcamtoper_mold + case(ioboper_lcbas ); vmold_ => lcbasoper_mold + case(ioboper_pm10 ); vmold_ => pm10oper_mold + case(ioboper_cldch ); vmold_ => cldchoper_mold + case(ioboper_uwnd10m ); vmold_ => uwnd10moper_mold + case(ioboper_vwnd10m ); vmold_ => vwnd10moper_mold + case(ioboper_swcp ); vmold_ => swcpoper_mold + case(ioboper_lwcp ); vmold_ => lwcpoper_mold + case(ioboper_light ); vmold_ => lightoper_mold + case(ioboper_dbz ); vmold_ => dbzoper_mold + case(ioboper_cldtot ); vmold_ => cldtotoper_mold + + case( oboper_undef ); vmold_ => null() + case default ; vmold_ => null() + end select +end function index2vmold_ + +function vmold2tinfo_(mold) result(info_) +!>> Simply mold%info(), but just in case one needs some indirection, with +!>> multiple oboper classes. + implicit none + character(len=:),allocatable:: info_ + class(oboper),target,intent(in):: mold + + character(len=*),parameter:: myname_=myname//"::vmold2tinfo_" + class(oboper),pointer:: vmold__ + vmold__ => mold + + if(.not.associated(vmold__)) call die(myname_,'not assoicated, argument mold') + nullify(vmold__) + + info_=index2tinfo_(vmold2index_(mold)) +end function vmold2tinfo_ + +function index2tinfo_(ioboper) result(info_) +!>> + implicit none + character(len=:),allocatable:: info_ + integer(i_kind),intent(in):: ioboper + + if(.not.cobstype_configured_) call cobstype_config_() + info_="" + if(ioboper>=oboper_lbound .and. & + ioboper<=oboper_ubound) info_=cobstype(ioboper) +end function index2tinfo_ + +subroutine config_() + implicit none + character(len=*),parameter:: myname_=myname//"::config_" + class(oboper),pointer:: vmold_ + integer(i_kind):: iset_,iget_ + logical:: good_ + + good_=.true. + do iset_ = oboper_lbound, oboper_ubound + vmold_ => index2vmold_(iset_) + if(.not.associated(vmold_)) then + call perr(myname_,'unexpected index, iset_ =',iset_) + call perr(myname_,' obOper_lbound =',oboper_lbound) + call perr(myname_,' obOper_ubound =',oboper_ubound) + call die(myname_) + endif + + iget_=iset_ ! for additional test. + !call vmold_%myinfo_set(ioboper=iset_) + !call vmold_%myinfo_get(ioboper=iget_) + if(iget_/=iset_) then + call perr(myname_,'unexpected return, %myinfo_get(iobOper) =',iget_) + call perr(myname_,' %myinfo_set(iobOper) =',iset_) + call perr(myname_,' %mytype() =',vmold_%mytype()) + good_=.false. + endif + + vmold_ => null() + enddo + if(.not.good_) call die(myname_) + + oboper_configured_ = .true. +end subroutine config_ + +subroutine cobstype_config_() +!>> Should this information be provided by individual oboper extensions, or +!>> be provided by this manager? There are pros and cons in either approach. + + implicit none + cobstype(ioboper_ps ) ="surface pressure " ! ps_ob_type + cobstype(ioboper_t ) ="temperature " ! t_ob_type + cobstype(ioboper_w ) ="wind " ! w_ob_type + cobstype(ioboper_q ) ="moisture " ! q_ob_type + cobstype(ioboper_spd ) ="wind speed " ! spd_ob_type + cobstype(ioboper_rw ) ="radial wind " ! rw_ob_type + cobstype(ioboper_dw ) ="doppler wind " ! dw_ob_type + cobstype(ioboper_sst ) ="sst " ! sst_ob_type + cobstype(ioboper_pw ) ="precipitable water " ! pw_ob_type + cobstype(ioboper_pcp ) ="precipitation " ! pcp_ob_type + cobstype(ioboper_oz ) ="ozone " ! oz_ob_type + cobstype(ioboper_o3l ) ="level ozone " ! o3l_ob_type + cobstype(ioboper_gpsbend ) ="gps bending angle " ! using gps_ob_type + cobstype(ioboper_gpsref ) ="gps refractivity " ! using gps_ob_type + cobstype(ioboper_rad ) ="radiance " ! rad_ob_type + cobstype(ioboper_tcp ) ="tcp (tropic cyclone)" ! tcp_ob_type + !cobstype(ioboper_lag ) ="lagrangian tracer " ! lag_ob_type + cobstype(ioboper_colvk ) ="carbon monoxide " ! colvk_ob_type + cobstype(ioboper_aero ) ="aerosol aod " ! aero_ob_type + !cobstype(ioboper_aerol ) ="level aero aod " ! aerol_ob_type + cobstype(ioboper_pm2_5 ) ="in-situ pm2_5 obs " ! pm2_5_ob_type + cobstype(ioboper_pm10 ) ="in-situ pm10 obs " ! pm10_ob_type + cobstype(ioboper_gust ) ="gust " ! gust_ob_type + cobstype(ioboper_vis ) ="vis " ! vis_ob_type + cobstype(ioboper_pblh ) ="pblh " ! pblh_ob_type + cobstype(ioboper_wspd10m ) ="wspd10m " ! wspd10m_ob_type + cobstype(ioboper_td2m ) ="td2m " ! td2m_ob_type + cobstype(ioboper_mxtm ) ="mxtm " ! mxtm_ob_type + cobstype(ioboper_mitm ) ="mitm " ! mitm_ob_type + cobstype(ioboper_pmsl ) ="pmsl " ! pmsl_ob_type + cobstype(ioboper_howv ) ="howv " ! howv_ob_type + cobstype(ioboper_tcamt ) ="tcamt " ! tcamt_ob_type + cobstype(ioboper_lcbas ) ="lcbas " ! lcbas_ob_type + cobstype(ioboper_cldch ) ="cldch " ! cldch_ob_type + cobstype(ioboper_uwnd10m ) ="uwnd10m " ! uwnd10m_ob_type + cobstype(ioboper_vwnd10m ) ="vwnd10m " ! vwnd10m_ob_type + cobstype(ioboper_swcp ) ="swcp " ! swcp_ob_type + cobstype(ioboper_lwcp ) ="lwcp " ! lwcp_ob_type + cobstype(ioboper_light ) ="light " ! light_ob_type + cobstype(ioboper_dbz ) ="dbz " ! dbz_ob_type + cobstype(ioboper_cldtot ) ="cldtot " ! using q_ob_type + + cobstype_configured_=.true. +end subroutine cobstype_config_ + +end module gsi_obopertypemanager diff --git a/src/gsi/gsi_ozOper.F90 b/src/gsi/gsi_ozoper.f90 similarity index 70% rename from src/gsi/gsi_ozOper.F90 rename to src/gsi/gsi_ozoper.f90 index 8bc21baf04..4948a96d9f 100644 --- a/src/gsi/gsi_ozOper.F90 +++ b/src/gsi/gsi_ozoper.f90 @@ -1,12 +1,12 @@ -module gsi_ozOper +module gsi_ozoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_ozOper +! subprogram: module gsi_ozoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for ozNode type +! abstract: an oboper extension for oznode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_ozOper ! module interface: - use gsi_obOper, only: obOper - use m_ozNode , only: ozNode + use gsi_oboper, only: oboper + use m_oznode , only: oznode implicit none - public:: ozOper ! data stracture + public:: ozoper ! data stracture - type,extends(obOper):: ozOper + type,extends(oboper):: ozoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type ozOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type ozoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_ozOper' - type(ozNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_ozoper' + type(oznode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[ozOper]" + mytype="[ozoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use oz_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: stats => rhs_stats_oz use obsmod, only: write_diag @@ -73,7 +73,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(ozOper ), intent(inout):: self + class(ozoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -96,7 +96,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_ozone - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave,init_pass) end subroutine setup_ @@ -105,11 +105,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intozmod, only: intjo => intozlay use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(ozOper ),intent(in ):: self + class(ozoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,11 +118,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -130,11 +130,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpozmod, only: stpjo => stpozlay use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(ozOper ),intent(in):: self + class(ozoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_ozOper +end module gsi_ozoper diff --git a/src/gsi/gsi_pblhOper.F90 b/src/gsi/gsi_pblhoper.f90 similarity index 70% rename from src/gsi/gsi_pblhOper.F90 rename to src/gsi/gsi_pblhoper.f90 index 390315b3b0..1d7f573118 100644 --- a/src/gsi/gsi_pblhOper.F90 +++ b/src/gsi/gsi_pblhoper.f90 @@ -1,12 +1,12 @@ -module gsi_pblhOper +module gsi_pblhoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pblhOper +! subprogram: module gsi_pblhoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pblhNode type +! abstract: an oboper extension for pblhnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pblhOper ! module interface: - use gsi_obOper, only: obOper - use m_pblhNode, only: pblhNode + use gsi_oboper, only: oboper + use m_pblhnode, only: pblhnode implicit none - public:: pblhOper ! data stracture + public:: pblhoper ! data stracture - type,extends(obOper):: pblhOper + type,extends(oboper):: pblhoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pblhOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pblhoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pblhOper' - type(pblhNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pblhoper' + type(pblhnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pblhOper]" + mytype="[pblhoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pblh_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pblhOper ), intent(inout):: self + class(pblhoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpblhmod, only: intjo => intpblh use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pblhOper ),intent(in ):: self + class(pblhoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppblhmod, only: stpjo => stppblh use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pblhOper ),intent(in):: self + class(pblhoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pblhOper +end module gsi_pblhoper diff --git a/src/gsi/gsi_pcpOper.F90 b/src/gsi/gsi_pcpoper.f90 similarity index 69% rename from src/gsi/gsi_pcpOper.F90 rename to src/gsi/gsi_pcpoper.f90 index b03462745d..54c851587b 100644 --- a/src/gsi/gsi_pcpOper.F90 +++ b/src/gsi/gsi_pcpoper.f90 @@ -1,12 +1,12 @@ -module gsi_pcpOper +module gsi_pcpoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pcpOper +! subprogram: module gsi_pcpoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pcpNode type +! abstract: an oboper extension for pcpnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pcpOper ! module interface: - use gsi_obOper, only: obOper - use m_pcpNode , only: pcpNode + use gsi_oboper, only: oboper + use m_pcpnode , only: pcpnode implicit none - public:: pcpOper ! data stracture + public:: pcpoper ! data stracture - type,extends(obOper):: pcpOper + type,extends(oboper):: pcpoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pcpOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pcpoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pcpOper' - type(pcpNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pcpoper' + type(pcpnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pcpOper]" + mytype="[pcpoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pcp_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs, only: aivals => rhs_aivals use obsmod, only: write_diag @@ -73,7 +73,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pcpOper ), intent(inout):: self + class(pcpoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -93,11 +93,11 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) read(lunin,iostat=ier) obstype,isis,nreal,nchanl if(ier/=0) call die(myname_,'read(obstype,...), iostat =',ier) - nele = nreal+nchanl + nele = nreal+nchanl diagsave = write_diag(jiter) .and. diag_pcp - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,aivals,nele,nobs,obstype,isis,is,diagsave,init_pass) end subroutine setup_ @@ -106,11 +106,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpcpmod, only: intjo => intpcp use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pcpOper ),intent(in ):: self + class(pcpoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -119,11 +119,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -131,11 +131,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppcpmod, only: stpjo => stppcp use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pcpOper ),intent(in):: self + class(pcpoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -148,11 +148,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pcpOper +end module gsi_pcpoper diff --git a/src/gsi/gsi_pm10Oper.F90 b/src/gsi/gsi_pm10oper.f90 similarity index 69% rename from src/gsi/gsi_pm10Oper.F90 rename to src/gsi/gsi_pm10oper.f90 index 8da67ce783..746c361340 100644 --- a/src/gsi/gsi_pm10Oper.F90 +++ b/src/gsi/gsi_pm10oper.f90 @@ -1,12 +1,12 @@ -module gsi_pm10Oper +module gsi_pm10oper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pm10Oper +! subprogram: module gsi_pm10oper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pm10Node type +! abstract: an oboper extension for pm10node type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pm10Oper ! module interface: - use gsi_obOper, only: obOper - use m_pm10Node, only: pm10Node + use gsi_oboper, only: oboper + use m_pm10node, only: pm10node implicit none - public:: pm10Oper ! data stracture + public:: pm10oper ! data stracture - type,extends(obOper):: pm10Oper + type,extends(oboper):: pm10oper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pm10Oper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pm10oper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pm10Oper' - type(pm10Node),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pm10oper' + type(pm10node),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pm10Oper]" + mytype="[pm10oper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pm10_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use obsmod , only: write_diag use convinfo, only: diag_conv @@ -72,7 +72,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pm10Oper ), intent(inout):: self + class(pm10oper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -96,7 +96,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,nele,nobs,isis,is,diagsave) end subroutine setup_ @@ -105,11 +105,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpm10mod, only: intjo => intpm10 use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pm10Oper ),intent(in ):: self + class(pm10oper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,11 +118,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -130,11 +130,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppm10mod, only: stpjo => stppm10 use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pm10Oper ),intent(in):: self + class(pm10oper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pm10Oper +end module gsi_pm10oper diff --git a/src/gsi/gsi_pm2_5Oper.F90 b/src/gsi/gsi_pm2_5oper.f90 similarity index 69% rename from src/gsi/gsi_pm2_5Oper.F90 rename to src/gsi/gsi_pm2_5oper.f90 index 221e997f53..e55471cb14 100644 --- a/src/gsi/gsi_pm2_5Oper.F90 +++ b/src/gsi/gsi_pm2_5oper.f90 @@ -1,12 +1,12 @@ -module gsi_pm2_5Oper +module gsi_pm2_5oper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pm2_5Oper +! subprogram: module gsi_pm2_5oper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pm2_5Node type +! abstract: an oboper extension for pm2_5node type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pm2_5Oper ! module interface: - use gsi_obOper , only: obOper - use m_pm2_5Node, only: pm2_5Node + use gsi_oboper , only: oboper + use m_pm2_5node, only: pm2_5node implicit none - public:: pm2_5Oper ! data stracture + public:: pm2_5oper ! data stracture - type,extends(obOper):: pm2_5Oper + type,extends(oboper):: pm2_5oper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pm2_5Oper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pm2_5oper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pm2_5Oper' - type(pm2_5Node),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pm2_5oper' + type(pm2_5node),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pm2_5Oper]" + mytype="[pm2_5oper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pm2_5_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use obsmod , only: write_diag use convinfo, only: diag_conv @@ -72,7 +72,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pm2_5Oper ), intent(inout):: self + class(pm2_5oper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -96,7 +96,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,nele,nobs,isis,is,diagsave) end subroutine setup_ @@ -105,11 +105,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpm2_5mod, only: intjo => intpm2_5 use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pm2_5Oper ),intent(in ):: self + class(pm2_5oper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -118,11 +118,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -130,11 +130,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppm2_5mod, only: stpjo => stppm2_5 use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pm2_5Oper ),intent(in):: self + class(pm2_5oper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pm2_5Oper +end module gsi_pm2_5oper diff --git a/src/gsi/gsi_pmslOper.F90 b/src/gsi/gsi_pmsloper.f90 similarity index 70% rename from src/gsi/gsi_pmslOper.F90 rename to src/gsi/gsi_pmsloper.f90 index 7007075623..610dfce4ba 100644 --- a/src/gsi/gsi_pmslOper.F90 +++ b/src/gsi/gsi_pmsloper.f90 @@ -1,12 +1,12 @@ -module gsi_pmslOper +module gsi_pmsloper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pmslOper +! subprogram: module gsi_pmsloper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pmslNode type +! abstract: an oboper extension for pmslnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pmslOper ! module interface: - use gsi_obOper, only: obOper - use m_pmslNode, only: pmslNode + use gsi_oboper, only: oboper + use m_pmslnode, only: pmslnode implicit none - public:: pmslOper ! data stracture + public:: pmsloper ! data stracture - type,extends(obOper):: pmslOper + type,extends(oboper):: pmsloper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pmslOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pmsloper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pmslOper' - type(pmslNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pmsloper' + type(pmslnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pmslOper]" + mytype="[pmsloper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pmsl_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pmslOper ), intent(inout):: self + class(pmsloper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpmslmod, only: intjo => intpmsl use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pmslOper ),intent(in ):: self + class(pmsloper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppmslmod, only: stpjo => stppmsl use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pmslOper ),intent(in):: self + class(pmsloper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pmslOper +end module gsi_pmsloper diff --git a/src/gsi/gsi_psOper.F90 b/src/gsi/gsi_psoper.f90 similarity index 70% rename from src/gsi/gsi_psOper.F90 rename to src/gsi/gsi_psoper.f90 index 87f1cd921d..27461c5d13 100644 --- a/src/gsi/gsi_psOper.F90 +++ b/src/gsi/gsi_psoper.f90 @@ -1,12 +1,12 @@ -module gsi_psOper +module gsi_psoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_psOper +! subprogram: module gsi_psoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for psNode type +! abstract: an oboper extension for psnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_psOper ! module interface: - use gsi_obOper, only: obOper - use m_psNode , only: psNode + use gsi_oboper, only: oboper + use m_psnode , only: psnode implicit none - public:: psOper ! data stracture + public:: psoper ! data stracture - type,extends(obOper):: psOper + type,extends(oboper):: psoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type psOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type psoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_psOper' - type(psNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_psoper' + type(psnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[psOper]" + mytype="[psoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use ps_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(psOper ), intent(inout):: self + class(psoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpsmod, only: intjo => intps use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(psOper ),intent(in ):: self + class(psoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppsmod, only: stpjo => stpps use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(psOper ),intent(in):: self + class(psoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_psOper +end module gsi_psoper diff --git a/src/gsi/gsi_pwOper.F90 b/src/gsi/gsi_pwoper.f90 similarity index 70% rename from src/gsi/gsi_pwOper.F90 rename to src/gsi/gsi_pwoper.f90 index d5193931d1..026bdd9c3c 100644 --- a/src/gsi/gsi_pwOper.F90 +++ b/src/gsi/gsi_pwoper.f90 @@ -1,12 +1,12 @@ -module gsi_pwOper +module gsi_pwoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_pwOper +! subprogram: module gsi_pwoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for pwNode type +! abstract: an oboper extension for pwnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_pwOper ! module interface: - use gsi_obOper, only: obOper - use m_pwNode , only: pwNode + use gsi_oboper, only: oboper + use m_pwnode , only: pwnode implicit none - public:: pwOper ! data stracture + public:: pwoper ! data stracture - type,extends(obOper):: pwOper + type,extends(oboper):: pwoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type pwOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type pwoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_pwOper' - type(pwNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_pwoper' + type(pwnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[pwOper]" + mytype="[pwoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use pw_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(pwOper ), intent(inout):: self + class(pwoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intpwmod, only: intjo => intpw use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(pwOper ),intent(in ):: self + class(pwoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stppwmod, only: stpjo => stppw use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(pwOper ),intent(in):: self + class(pwoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_pwOper +end module gsi_pwoper diff --git a/src/gsi/gsi_qOper.F90 b/src/gsi/gsi_qoper.f90 similarity index 70% rename from src/gsi/gsi_qOper.F90 rename to src/gsi/gsi_qoper.f90 index 75de802129..fa7b8d3786 100644 --- a/src/gsi/gsi_qOper.F90 +++ b/src/gsi/gsi_qoper.f90 @@ -1,12 +1,12 @@ -module gsi_qOper +module gsi_qoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_qOper +! subprogram: module gsi_qoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for qNode type +! abstract: an oboper extension for qnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_qOper ! module interface: - use gsi_obOper, only: obOper - use m_qNode , only: qNode + use gsi_oboper, only: oboper + use m_qnode , only: qnode implicit none - public:: qOper ! data stracture + public:: qoper ! data stracture - type,extends(obOper):: qOper + type,extends(oboper):: qoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type qOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type qoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_qOper' - type(qNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_qoper' + type(qnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[qOper]" + mytype="[qoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use q_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(qOper ), intent(inout):: self + class(qoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intqmod, only: intjo => intq use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(qOper ),intent(in ):: self + class(qoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpqmod, only: stpjo => stpq use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(qOper ),intent(in):: self + class(qoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_qOper +end module gsi_qoper diff --git a/src/gsi/gsi_radOper.F90 b/src/gsi/gsi_radoper.f90 similarity index 69% rename from src/gsi/gsi_radOper.F90 rename to src/gsi/gsi_radoper.f90 index 34c688e62d..43dd90808d 100644 --- a/src/gsi/gsi_radOper.F90 +++ b/src/gsi/gsi_radoper.f90 @@ -1,12 +1,12 @@ -module gsi_radOper +module gsi_radoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_radOper +! subprogram: module gsi_radoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for radNode type +! abstract: an oboper extension for radnode type ! ! program history log: ! 2018-08-10 j guo - added this document block for initial implementation @@ -23,48 +23,48 @@ module gsi_radOper ! module interface: - use gsi_obOper, only: obOper - use m_radNode , only: radNode + use gsi_oboper, only: oboper + use m_radnode , only: radnode implicit none - public:: radOper ! data stracture + public:: radoper ! data stracture - type,extends(obOper):: radOper + type,extends(oboper):: radoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type radOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type radoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_radOper' - type(radNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_radoper' + type(radnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[radOper]" + mytype="[radoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use rad_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: aivals => rhs_aivals use m_rhs , only: stats => rhs_stats @@ -75,7 +75,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(radOper ), intent(inout):: self + class(radoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -97,7 +97,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_rad - call setup(self%obsLL(:), self%odiagLL(:), lunin, mype, & + call setup(self%obsll(:), self%odiagll(:), lunin, mype, & aivals,stats,nchanl,nreal,nobs,obstype,isis,is,diagsave, & init_pass,last_pass) @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use bias_predictors, only: predictors_getdim - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(radOper ),intent(in ):: self + class(radoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,21 +122,21 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !!$omp ... ! do ib=1,nobs_bins - ! do it=1,nobs_type - ! iop => obOper_create(mold=obOper_typemold(it)) - ! call iop%intjo(ib, rval(ib),sval(ib), qpred(:,ib),sbias) - ! iop => null() - ! enddo + ! do it=1,nobs_type + ! iop => oboper_create(mold=oboper_typemold(it)) + ! call iop%intjo(ib, rval(ib),sval(ib), qpred(:,ib),sbias) + ! iop => null() + ! enddo ! enddo character(len=*),parameter:: myname_=myname//"::intjo1_" integer(i_kind):: i,l - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode call predictors_getdim(lbnd_s=i,ubnd_s=l) - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval, qpred(i:l),sbias%predr) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval, qpred(i:l),sbias%predr) + headnode => null() end subroutine intjo1_ @@ -147,10 +147,10 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors,predictors_getdim use radinfo, only: npred,jpch_rad - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode implicit none - class(radOper ),intent(in):: self + class(radoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -162,22 +162,22 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) type(predictors),target, intent(in):: xbias character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode real(r_kind),pointer,dimension(:,:):: dpred,xpred integer(i_kind):: n - headNode => obsLList_headNode(self%obsLL(ibin)) + headnode => obsllist_headnode(self%obsll(ibin)) call predictors_getdim(size_s=n) dpred(1:npred,1:jpch_rad) => dbias%predr(1:n) xpred(1:npred,1:jpch_rad) => xbias%predr(1:n) - call stpjo(headNode,dval,xval, dpred,xpred,pbcjo(:),sges,nstep) + call stpjo(headnode,dval,xval, dpred,xpred,pbcjo(:),sges,nstep) dpred => null() xpred => null() - headNode => null() + headnode => null() end subroutine stpjo1_ -end module gsi_radOper +end module gsi_radoper diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index c0366c9b3d..0bdf1a4e27 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -4,14 +4,14 @@ module gsi_rfv3io_mod ! module: gsi_rfv3io_mod ! prgmmr: ! -! abstract: IO routines for regional FV3 +! abstract: io routines for regional fv3 ! ! program history log: ! 2017-03-08 parrish - create new module gsi_rfv3io_mod, starting from ! gsi_nemsio_mod as a pattern. -! 2017-10-10 wu - setup A grid and interpolation coeff in generate_anl_grid +! 2017-10-10 wu - setup a grid and interpolation coeff in generate_anl_grid ! 2018-02-22 wu - add subroutines for read/write fv3_ncdf -! 2019 ting - modifications for use for ensemble IO and cold start files +! 2019 ting - modifications for use for ensemble io and cold start files ! subroutines included: ! sub gsi_rfv3io_get_grid_specs ! sub read_fv3_files @@ -42,14 +42,14 @@ module gsi_rfv3io_mod ! directory names (hardwired for now) type type_fv3regfilenameg - character(len=:),allocatable :: grid_spec !='fv3_grid_spec' - character(len=:),allocatable :: ak_bk !='fv3_akbk' - character(len=:),allocatable :: dynvars !='fv3_dynvars' - character(len=:),allocatable :: tracers !='fv3_tracer' - character(len=:),allocatable :: sfcdata !='fv3_sfcdata' - character(len=:),allocatable :: couplerres!='coupler.res' - contains - procedure , pass(this):: init=>fv3regfilename_init + character(len=:),allocatable :: grid_spec !='fv3_grid_spec' + character(len=:),allocatable :: ak_bk !='fv3_akbk' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: couplerres!='coupler.res' + contains + procedure , pass(this):: init=>fv3regfilename_init end type type_fv3regfilenameg integer(i_kind):: fv3sar_bg_opt=0 @@ -98,45 +98,45 @@ module gsi_rfv3io_mod contains subroutine fv3regfilename_init(this,grid_spec_input,ak_bk_input,dynvars_input, & tracers_input,sfcdata_input,couplerres_input) - implicit None + implicit none class(type_fv3regfilenameg),intent(inout):: this - character(*),optional :: grid_spec_input,ak_bk_input,dynvars_input, & + character(*),optional,intent(in) :: grid_spec_input,ak_bk_input,dynvars_input, & tracers_input,sfcdata_input,couplerres_input if(present(grid_spec_input))then - this%grid_spec=grid_spec_input + this%grid_spec=grid_spec_input else - this%grid_spec='fv3_grid_spec' + this%grid_spec='fv3_grid_spec' endif if(present(ak_bk_input))then - this%ak_bk=ak_bk_input + this%ak_bk=ak_bk_input else - this%ak_bk='fv3_ak_bk' + this%ak_bk='fv3_ak_bk' endif if(present(dynvars_input))then - this%dynvars=dynvars_input + this%dynvars=dynvars_input else - this%dynvars='fv3_dynvars' + this%dynvars='fv3_dynvars' endif if(present(tracers_input))then - this%tracers=tracers_input + this%tracers=tracers_input else - this%tracers='fv3_tracer' + this%tracers='fv3_tracer' endif if(present(sfcdata_input))then - this%sfcdata=sfcdata_input + this%sfcdata=sfcdata_input else - this%sfcdata='fv3_sfcdata' + this%sfcdata='fv3_sfcdata' endif if(present(couplerres_input))then - this%couplerres=couplerres_input + this%couplerres=couplerres_input else - this%couplerres='coupler.res' + this%couplerres='coupler.res' endif end subroutine fv3regfilename_init @@ -154,11 +154,11 @@ subroutine gsi_rfv3io_get_grid_specs(fv3filenamegin,ierr) ! ! program history log: ! 2017-04-03 parrish - initial documentation -! 2017-10-10 wu - setup A grid and interpolation coeff with generate_anl_grid +! 2017-10-10 wu - setup a grid and interpolation coeff with generate_anl_grid ! 2018-02-16 wu - read in time info from file coupler.res ! read in lat, lon at the center and corner of the grid cell ! from file fv3_grid_spec, and vertical grid infor from file fv3_akbk -! setup A grid and interpolation/rotation coeff +! setup a grid and interpolation/rotation coeff ! input argument list: ! grid_spec ! ak_bk @@ -186,7 +186,7 @@ subroutine gsi_rfv3io_get_grid_specs(fv3filenamegin,ierr) implicit none integer(i_kind) gfile_grid_spec - type (type_fv3regfilenameg) :: fv3filenamegin + type (type_fv3regfilenameg),intent(in) :: fv3filenamegin character(:),allocatable :: grid_spec character(:),allocatable :: ak_bk character(len=:),allocatable :: coupler_res_filenam @@ -197,130 +197,130 @@ subroutine gsi_rfv3io_get_grid_specs(fv3filenamegin,ierr) integer(i_kind) myear,mmonth,mday,mhour,mminute,msecond real(r_kind),allocatable:: abk_fv3(:) - coupler_res_filenam=fv3filenamegin%couplerres - grid_spec=fv3filenamegin%grid_spec - ak_bk=fv3filenamegin%ak_bk + coupler_res_filenam=fv3filenamegin%couplerres + grid_spec=fv3filenamegin%grid_spec + ak_bk=fv3filenamegin%ak_bk !!!!! set regional_time - open(24,file=trim(coupler_res_filenam),form='formatted') - read(24,*) - read(24,*) - read(24,*)myear,mmonth,mday,mhour,mminute,msecond - close(24) - if(mype==0) write(6,*)' myear,mmonth,mday,mhour,mminute,msecond=', myear,mmonth,mday,mhour,mminute,msecond - regional_time(1)=myear - regional_time(2)=mmonth - regional_time(3)=mday - regional_time(4)=mhour - regional_time(5)=mminute - regional_time(6)=msecond - regional_fhr=zero ! forecast hour set zero for now + open(24,file=trim(coupler_res_filenam),form='formatted') + read(24,*) + read(24,*) + read(24,*)myear,mmonth,mday,mhour,mminute,msecond + close(24) + if(mype==0) write(6,*)' myear,mmonth,mday,mhour,mminute,msecond=', myear,mmonth,mday,mhour,mminute,msecond + regional_time(1)=myear + regional_time(2)=mmonth + regional_time(3)=mday + regional_time(4)=mhour + regional_time(5)=mminute + regional_time(6)=msecond + regional_fhr=zero ! forecast hour set zero for now !!!!!!!!!! grid_spec !!!!!!!!!!!!!!! - ierr=0 - iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec) - if(iret/=nf90_noerr) then - write(6,*)' gsi_rfv3io_get_grid_specs: problem opening ',trim(grid_spec),', Status = ',iret - ierr=1 - return - endif + ierr=0 + iret=nf90_open(trim(grid_spec),nf90_nowrite,gfile_grid_spec) + if(iret/=nf90_noerr) then + write(6,*)' gsi_rfv3io_get_grid_specs: problem opening ',trim(grid_spec),', Status = ',iret + ierr=1 + return + endif - iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid) - gfile_loc=gfile_grid_spec - do k=1,ndimensions - iret=nf90_inquire_dimension(gfile_loc,k,name,len) - if(trim(name)=='grid_xt') nx=len - if(trim(name)=='grid_yt') ny=len - enddo - nlon_regional=nx - nlat_regional=ny - if(mype==0)write(6,*),'nx,ny=',nx,ny + iret=nf90_inquire(gfile_grid_spec,ndimensions,nvariables,nattributes,unlimiteddimid) + gfile_loc=gfile_grid_spec + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='grid_xt') nx=len + if(trim(name)=='grid_yt') ny=len + enddo + nlon_regional=nx + nlat_regional=ny + if(mype==0)write(6,*),'nx,ny=',nx,ny !!! get nx,ny,grid_lon,grid_lont,grid_lat,grid_latt,nz,ak,bk - allocate(grid_lat(nx+1,ny+1)) - allocate(grid_lon(nx+1,ny+1)) - allocate(grid_latt(nx,ny)) - allocate(grid_lont(nx,ny)) - - do k=ndimensions+1,nvariables - iret=nf90_inquire_variable(gfile_loc,k,name,len) - if(trim(name)=='grid_lat') then - iret=nf90_get_var(gfile_loc,k,grid_lat) - endif - if(trim(name)=='grid_lon') then - iret=nf90_get_var(gfile_loc,k,grid_lon) - endif - if(trim(name)=='grid_latt') then - iret=nf90_get_var(gfile_loc,k,grid_latt) - endif - if(trim(name)=='grid_lont') then - iret=nf90_get_var(gfile_loc,k,grid_lont) - endif - enddo - - iret=nf90_close(gfile_loc) - - iret=nf90_open(ak_bk,nf90_nowrite,gfile_loc) - if(iret/=nf90_noerr) then - write(6,*)'gsi_rfv3io_get_grid_specs: problem opening ',trim(ak_bk),', Status = ',iret - ierr=1 - return - endif - iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) - do k=1,ndimensions - iret=nf90_inquire_dimension(gfile_loc,k,name,len) - if(trim(name)=='xaxis_1') nz=len - enddo - if(mype==0)write(6,'(" nz=",i5)') nz + allocate(grid_lat(nx+1,ny+1)) + allocate(grid_lon(nx+1,ny+1)) + allocate(grid_latt(nx,ny)) + allocate(grid_lont(nx,ny)) + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='grid_lat') then + iret=nf90_get_var(gfile_loc,k,grid_lat) + endif + if(trim(name)=='grid_lon') then + iret=nf90_get_var(gfile_loc,k,grid_lon) + endif + if(trim(name)=='grid_latt') then + iret=nf90_get_var(gfile_loc,k,grid_latt) + endif + if(trim(name)=='grid_lont') then + iret=nf90_get_var(gfile_loc,k,grid_lont) + endif + enddo + + iret=nf90_close(gfile_loc) + + iret=nf90_open(ak_bk,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)'gsi_rfv3io_get_grid_specs: problem opening ',trim(ak_bk),', Status = ',iret + ierr=1 + return + endif + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + if(trim(name)=='xaxis_1') nz=len + enddo + if(mype==0)write(6,'(" nz=",i5)') nz - nsig=nz-1 + nsig=nz-1 !!! get ak,bk - allocate(aeta1_ll(nsig),aeta2_ll(nsig)) - allocate(eta1_ll(nsig+1),eta2_ll(nsig+1)) - allocate(ak(nz),bk(nz),abk_fv3(nz)) - - do k=ndimensions+1,nvariables - iret=nf90_inquire_variable(gfile_loc,k,name,len) - if(trim(name)=='ak'.or.trim(name)=='AK') then - iret=nf90_get_var(gfile_loc,k,abk_fv3) - do i=1,nz - ak(i)=abk_fv3(nz+1-i) - enddo - endif - if(trim(name)=='bk'.or.trim(name)=='BK') then - iret=nf90_get_var(gfile_loc,k,abk_fv3) - do i=1,nz - bk(i)=abk_fv3(nz+1-i) - enddo - endif - enddo - iret=nf90_close(gfile_loc) + allocate(aeta1_ll(nsig),aeta2_ll(nsig)) + allocate(eta1_ll(nsig+1),eta2_ll(nsig+1)) + allocate(ak(nz),bk(nz),abk_fv3(nz)) + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='ak'.or.trim(name)=='AK') then + iret=nf90_get_var(gfile_loc,k,abk_fv3) + do i=1,nz + ak(i)=abk_fv3(nz+1-i) + enddo + endif + if(trim(name)=='bk'.or.trim(name)=='BK') then + iret=nf90_get_var(gfile_loc,k,abk_fv3) + do i=1,nz + bk(i)=abk_fv3(nz+1-i) + enddo + endif + enddo + iret=nf90_close(gfile_loc) !!!!! change unit of ak - do i=1,nsig+1 - eta1_ll(i)=ak(i)*0.001_r_kind - eta2_ll(i)=bk(i) - enddo - do i=1,nsig - aeta1_ll(i)=half*(ak(i)+ak(i+1))*0.001_r_kind - aeta2_ll(i)=half*(bk(i)+bk(i+1)) - enddo - if(mype==0)then - do i=1,nz - write(6,'(" ak,bk(",i3,") = ",2f17.6)') i,ak(i),bk(i) - enddo - endif + do i=1,nsig+1 + eta1_ll(i)=ak(i)*0.001_r_kind + eta2_ll(i)=bk(i) + enddo + do i=1,nsig + aeta1_ll(i)=half*(ak(i)+ak(i+1))*0.001_r_kind + aeta2_ll(i)=half*(bk(i)+bk(i+1)) + enddo + if(mype==0)then + do i=1,nz + write(6,'(" ak,bk(",i3,") = ",2f17.6)') i,ak(i),bk(i) + enddo + endif -!!!!!!! setup A grid and interpolation/rotation coeff. - call generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) +!!!!!!! setup a grid and interpolation/rotation coeff. + call generate_anl_grid(nx,ny,grid_lon,grid_lont,grid_lat,grid_latt) - deallocate (grid_lon,grid_lat,grid_lont,grid_latt) - deallocate (ak,bk,abk_fv3) + deallocate (grid_lon,grid_lat,grid_lont,grid_latt) + deallocate (ak,bk,abk_fv3) - return + return end subroutine gsi_rfv3io_get_grid_specs subroutine read_fv3_files(mype) @@ -396,40 +396,40 @@ subroutine read_fv3_files(mype) ! Check for consistency of times from sigma guess files. in_unit=15 iwan=0 -!WWWWWW setup for one first guess file for now -! do i=0,9 !place holder for FGAT +! setup for one first guess file for now +! do i=0,9 !place holder for fgat i=3 -!wwww read in from the external file directly, no internal files sigfxx for FV3 - idate5(1)= regional_time(1) - idate5(2)= regional_time(2) - idate5(3)= regional_time(3) - idate5(4)= regional_time(4) - idate5(5)= regional_time(5) - isecond = regional_time(6) - hourg = zero ! forcast hour - - call w3fs21(idate5,nmings) - nming2=nmings+60*hourg - write(6,*)'READ_netcdf_fv3_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 - t4dv=real((nming2-iwinbgn),r_kind)*r60inv - if (l4dvar.or.l4densvar) then - if (t4dvwinlen) then - write(6,*)'ges file not in time range, t4dv=',t4dv -! cycle ! place holder for FGAT - endif - else - ndiff=nming2-nminanl -!for test with the 3 hr files with FGAT - if(abs(ndiff) > 60*nhr_half ) then - write(6,*)'ges file not in time range, ndiff=',ndiff -! cycle ! place holder for FGAT - endif +! read in from the external file directly, no internal files sigfxx for fv3 + idate5(1)= regional_time(1) + idate5(2)= regional_time(2) + idate5(3)= regional_time(3) + idate5(4)= regional_time(4) + idate5(5)= regional_time(5) + isecond = regional_time(6) + hourg = zero ! forcast hour + + call w3fs21(idate5,nmings) + nming2=nmings+60*hourg + write(6,*)'READ_netcdf_fv3_FILES: sigma guess file, nming2 ',hourg,idate5,nming2 + t4dv=real((nming2-iwinbgn),r_kind)*r60inv + if (l4dvar.or.l4densvar) then + if (t4dvwinlen) then + write(6,*)'ges file not in time range, t4dv=',t4dv +! cycle ! place holder for fgat + endif + else + ndiff=nming2-nminanl +!for test with the 3 hr files with fgat + if(abs(ndiff) > 60*nhr_half ) then + write(6,*)'ges file not in time range, ndiff=',ndiff +! cycle ! place holder for fgat endif - iwan=iwan+1 - time_ges(iwan,1) =real((nming2-iwinbgn),r_kind)*r60inv - time_ges(iwan+100,1)=i+r0_001 -! end do ! i !place holder for FGAT + endif + iwan=iwan+1 + time_ges(iwan,1) =real((nming2-iwinbgn),r_kind)*r60inv + time_ges(iwan+100,1)=i+r0_001 +! end do ! i !place holder for fgat time_ges(201,1)=one time_ges(202,1)=one if(iwan > 1)then @@ -467,7 +467,7 @@ subroutine read_fv3_files(mype) ndiff=nming2-nminanl if(abs(ndiff) > 60*nhr_half ) then write(6,*)'ges file not in time range, ndiff=',ndiff -! cycle ! place holder for FGAT +! cycle ! place holder for fgat endif iwan=iwan+1 time_ges(iwan,2) =real((nming2-iwinbgn),r_kind)*r60inv @@ -566,7 +566,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ! subprogram: read_fv3_netcdf_guess read fv3 interface file ! prgmmr: wu org: np22 date: 2017-07-06 ! -! abstract: read guess for FV3 regional model +! abstract: read guess for fv3 regional model ! program history log: ! attributes: ! language: f90 @@ -589,22 +589,22 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) character(len=24),parameter :: myname = 'read_fv3_netcdf_guess' integer(i_kind) k,i,j integer(i_kind) it,ier,istatus - real(r_kind),dimension(:,:),pointer::ges_ps=>NULL() - real(r_kind),dimension(:,:),pointer::ges_z=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_u=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_v=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_q=>NULL() -! real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_oz=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() + real(r_kind),dimension(:,:),pointer::ges_ps=>null() + real(r_kind),dimension(:,:),pointer::ges_z=>null() + real(r_kind),dimension(:,:,:),pointer::ges_u=>null() + real(r_kind),dimension(:,:,:),pointer::ges_v=>null() + real(r_kind),dimension(:,:,:),pointer::ges_q=>null() +! real(r_kind),dimension(:,:,:),pointer::ges_ql=>null() + real(r_kind),dimension(:,:,:),pointer::ges_oz=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>null() - character(len=:),allocatable :: dynvars !='fv3_dynvars' - character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' - dynvars= fv3filenamegin%dynvars - tracers= fv3filenamegin%tracers + dynvars= fv3filenamegin%dynvars + tracers= fv3filenamegin%tracers if(npe< 8) then call die('read_fv3_netcdf_guess','not enough PEs to read in fv3 fields' ) @@ -640,14 +640,14 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) ier=0 - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'z' , ges_z ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus -! call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'z' , ges_z ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_Bundle(it), 'u' , ges_u ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'v' , ges_v ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'tv' ,ges_tv ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'q' ,ges_q ,istatus );ier=ier+istatus +! call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'ql' ,ges_ql ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'oz' ,ges_oz ,istatus );ier=ier+istatus if (ier/=0) call die(trim(myname),'cannot get pointers for fv3 met-fields, ier =',ier) if( fv3sar_bg_opt == 0) then @@ -709,7 +709,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) ! prgmmr: wu w org: np22 date: 2017-10-17 ! ! abstract: read in 2d fields from fv3_sfcdata file in mype_2d -! Scatter the field to each PE +! Scatter the field to each pe ! program history log: ! input argument list: ! it - time index for 2d fields @@ -749,8 +749,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) integer(i_kind) iret,gfile_loc,i,k,len,ndim integer(i_kind) ndimensions,nvariables,nattributes,unlimiteddimid integer(i_kind) kk,n,ns,j,ii,jj,mm1 - character(len=:),allocatable :: sfcdata !='fv3_sfcdata' - character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: sfcdata !='fv3_sfcdata' + character(len=:),allocatable :: dynvars !='fv3_dynvars' sfcdata= fv3filenamegin%sfcdata dynvars= fv3filenamegin%dynvars @@ -760,52 +760,100 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) allocate(work(itotsub*n2d)) allocate( sfcn2d(lat2,lon2,n2d)) - if(mype==mype_2d ) then - iret=nf90_open(sfcdata,nf90_nowrite,gfile_loc) - if(iret/=nf90_noerr) then - write(6,*)' problem opening3 ',trim(sfcdata),', Status = ',iret - return - endif - iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) - allocate(dim(ndimensions)) - do k=1,ndimensions - iret=nf90_inquire_dimension(gfile_loc,k,name,len) - dim(k)=len - enddo + if(mype==mype_2d ) then + iret=nf90_open(sfcdata,nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening3 ',trim(sfcdata),', Status = ',iret + return + endif + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + allocate(dim(ndimensions)) + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo !!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!! - do i=ndimensions+1,nvariables - iret=nf90_inquire_variable(gfile_loc,i,name,len) - if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then - k=k_f10m - else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then - k=k_stype - else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then - k=k_vfrac - else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then - k=k_vtype - else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then - k=k_zorl - else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then - k=k_tsea - else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then - k=k_snwdph - else if( trim(name)=='stc'.or.trim(name)=='STC' ) then - k=k_stc - else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then - k=k_smc - else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then - k=k_slmsk - else - cycle + do i=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,i,name,len) + if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then + k=k_f10m + else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then + k=k_stype + else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then + k=k_vfrac + else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then + k=k_vtype + else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then + k=k_zorl + else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then + k=k_tsea + else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then + k=k_snwdph + else if( trim(name)=='stc'.or.trim(name)=='STC' ) then + k=k_stc + else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then + k=k_smc + else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then + k=k_slmsk + else + cycle + endif + iret=nf90_inquire_variable(gfile_loc,i,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id) + if(allocated(sfc )) deallocate(sfc ) + allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) + iret=nf90_get_var(gfile_loc,i,sfc) + call fv3_h_to_ll(sfc(:,:,1),a,nx,ny,nxa,nya) + + kk=0 + do n=1,npe + ns=displss2d(n)+(k-1)*ijn_s(n) + do j=1,ijn_s(n) + ns=ns+1 + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(ns)=a(ii,jj) + end do + end do + enddo ! i + iret=nf90_close(gfile_loc) + +!!!! read in orog from dynam !!!!!!!!!!!! + iret=nf90_open(trim(dynvars ),nf90_nowrite,gfile_loc) + if(iret/=nf90_noerr) then + write(6,*)' problem opening4 ',trim(dynvars ),gfile_loc,', Status = ',iret + return endif - iret=nf90_inquire_variable(gfile_loc,i,ndims=ndim) - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) - iret=nf90_inquire_variable(gfile_loc,i,dimids=dim_id) - if(allocated(sfc )) deallocate(sfc ) - allocate(sfc(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) - iret=nf90_get_var(gfile_loc,i,sfc) - call fv3_h_to_ll(sfc(:,:,1),a,nx,ny,nxa,nya) + + iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) + if(allocated(dim )) deallocate(dim ) + allocate(dim(ndimensions)) + + do k=1,ndimensions + iret=nf90_inquire_dimension(gfile_loc,k,name,len) + dim(k)=len + enddo + + + do k=ndimensions+1,nvariables + iret=nf90_inquire_variable(gfile_loc,k,name,len) + if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then + iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) + if(allocated(dim_id )) deallocate(dim_id ) + allocate(dim_id(ndim)) + iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) + allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) + iret=nf90_get_var(gfile_loc,k,sfc1) + exit + endif + enddo ! k + iret=nf90_close(gfile_loc) + + k=k_orog + call fv3_h_to_ll(sfc1,a,nx,ny,nxa,nya) kk=0 do n=1,npe @@ -818,57 +866,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z) work(ns)=a(ii,jj) end do end do - enddo ! i - iret=nf90_close(gfile_loc) -!!!! read in orog from dynam !!!!!!!!!!!! - iret=nf90_open(trim(dynvars ),nf90_nowrite,gfile_loc) - if(iret/=nf90_noerr) then - write(6,*)' problem opening4 ',trim(dynvars ),gfile_loc,', Status = ',iret - return - endif - - iret=nf90_inquire(gfile_loc,ndimensions,nvariables,nattributes,unlimiteddimid) - if(allocated(dim )) deallocate(dim ) - allocate(dim(ndimensions)) - - do k=1,ndimensions - iret=nf90_inquire_dimension(gfile_loc,k,name,len) - dim(k)=len - enddo - - - do k=ndimensions+1,nvariables - iret=nf90_inquire_variable(gfile_loc,k,name,len) - if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then - iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) - if(allocated(dim_id )) deallocate(dim_id ) - allocate(dim_id(ndim)) - iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) - allocate(sfc1(dim(dim_id(1)),dim(dim_id(2))) ) - iret=nf90_get_var(gfile_loc,k,sfc1) - exit - endif - enddo ! k - iret=nf90_close(gfile_loc) - - k=k_orog - call fv3_h_to_ll(sfc1,a,nx,ny,nxa,nya) - - kk=0 - do n=1,npe - ns=displss2d(n)+(k-1)*ijn_s(n) - do j=1,ijn_s(n) - ns=ns+1 - kk=kk+1 - ii=ltosi_s(kk) - jj=ltosj_s(kk) - work(ns)=a(ii,jj) - end do - end do - - deallocate (dim_id,sfc,sfc1,dim) - endif ! mype + deallocate (dim_id,sfc,sfc1,dim) + endif ! mype !!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -898,8 +898,8 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) ! prgmmr: T. Lei date: 2019-03-28 ! modified from gsi_fv3ncdf_read and gsi_fv3ncdf2d_read ! -! abstract: read in a 2d field from a netcdf FV3 file in mype_io -! then scatter the field to each PE +! abstract: read in a 2d field from a netcdf fv3 file in mype_io +! then scatter the field to each pe ! program history log: ! ! input argument list: @@ -960,10 +960,10 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) if(iret/=nf90_noerr) then - iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) - if(iret/=nf90_noerr) then - write(6,*)' wrong to get var_id ',var_id - endif + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) + if(iret/=nf90_noerr) then + write(6,*)' wrong to get var_id ',var_id + endif endif iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) @@ -973,16 +973,16 @@ subroutine gsi_fv3ncdf2d_read_v1(filenamein,varname,varname2,work_sub,mype_io) if(allocated(uu )) deallocate(uu ) allocate(uu(nx,ny,1)) iret=nf90_get_var(gfile_loc,var_id,uu) - call fv3_h_to_ll(uu(:,:,1),a,nx,ny,nlon,nlat) - kk=0 - do n=1,npe - do j=1,ijn_s(n) - kk=kk+1 - ii=ltosi_s(kk) - jj=ltosj_s(kk) - work(kk)=a(ii,jj) - end do + call fv3_h_to_ll(uu(:,:,1),a,nx,ny,nlon,nlat) + kk=0 + do n=1,npe + do j=1,ijn_s(n) + kk=kk+1 + ii=ltosi_s(kk) + jj=ltosj_s(kk) + work(kk)=a(ii,jj) end do + end do iret=nf90_close(gfile_loc) deallocate (uu,a,dim,dim_id) @@ -1002,8 +1002,8 @@ subroutine gsi_fv3ncdf_read(filenamein,varname,varname2,work_sub,mype_io) ! subprogram: gsi_fv3ncdf_read ! prgmmr: wu org: np22 date: 2017-10-10 ! -! abstract: read in a field from a netcdf FV3 file in mype_io -! then scatter the field to each PE +! abstract: read in a field from a netcdf fv3 file in mype_io +! then scatter the field to each pe ! program history log: ! ! input argument list: @@ -1119,8 +1119,8 @@ subroutine gsi_fv3ncdf_read_v1(filenamein,varname,varname2,work_sub,mype_io) ! Lei modified from gsi_fv3ncdf_read ! prgmmr: wu org: np22 date: 2017-10-10 ! -! abstract: read in a field from a netcdf FV3 file in mype_io -! then scatter the field to each PE +! abstract: read in a field from a netcdf fv3 file in mype_io +! then scatter the field to each pe ! program history log: ! ! input argument list: @@ -1186,15 +1186,15 @@ subroutine gsi_fv3ncdf_read_v1(filenamein,varname,varname2,work_sub,mype_io) dim(k)=len enddo - allocate(uu(nx,ny,nsig)) - allocate(temp0(nx,ny,nsig+1)) + allocate(uu(nx,ny,nsig)) + allocate(temp0(nx,ny,nsig+1)) iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) if(iret/=nf90_noerr) then - iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) - if(iret/=nf90_noerr) then - write(6,*)' wrong to get var_id ',var_id - endif + iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname2)),var_id) + if(iret/=nf90_noerr) then + write(6,*)' wrong to get var_id ',var_id + endif endif iret=nf90_get_var(gfile_loc,var_id,temp0) @@ -1237,8 +1237,8 @@ subroutine gsi_fv3ncdf_readuv(dynvarsfile,ges_u,ges_v) ! subprogram: gsi_fv3ncdf_readuv ! prgmmr: wu w org: np22 date: 2017-11-22 ! -! abstract: read in a field from a netcdf FV3 file in mype_u,mype_v -! then scatter the field to each PE +! abstract: read in a field from a netcdf fv3 file in mype_u,mype_v +! then scatter the field to each pe ! program history log: ! ! input argument list: @@ -1310,7 +1310,7 @@ subroutine gsi_fv3ncdf_readuv(dynvarsfile,ges_u,ges_v) if(allocated(dim_id )) deallocate(dim_id ) allocate(dim_id(ndim)) iret=nf90_inquire_variable(gfile_loc,k,dimids=dim_id) -! NOTE: dimension of variables on native fv3 grid. +! Note: dimension of variables on native fv3 grid. ! u and v have an extra row in one of the dimensions if(allocated(uu)) deallocate(uu) allocate(uu(dim(dim_id(1)),dim(dim_id(2)),dim(dim_id(3)))) @@ -1365,8 +1365,8 @@ subroutine gsi_fv3ncdf_readuv_v1(dynvarsfile,ges_u,ges_v) ! ! program history log: ! 2019-04 lei modified from gsi_fv3ncdf_readuv to deal with cold start files . . . -! abstract: read in a field from a "cold start" netcdf FV3 file in mype_u,mype_v -! then scatter the field to each PE +! abstract: read in a field from a "cold start" netcdf fv3 file in mype_u,mype_v +! then scatter the field to each pe ! program history log: ! ! input argument list: @@ -1427,28 +1427,28 @@ subroutine gsi_fv3ncdf_readuv_v1(dynvarsfile,ges_u,ges_v) enddo allocate(uorv(nx,ny)) if(mype == mype_u) then - allocate(uu(nx,ny+1,nsig)) + allocate(uu(nx,ny+1,nsig)) else ! for mype_v - allocate(uu(nx+1,ny,nsig)) + allocate(uu(nx+1,ny,nsig)) endif ! transfor to earth u/v, interpolate to analysis grid, reverse vertical order if(mype == mype_u) then - iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id) + iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id) - iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) - allocate(temp0(nx,ny+1,nsig+1)) - iret=nf90_get_var(gfile_loc,var_id,temp0) - uu(:,:,:)=temp0(:,:,2:nsig+1) - deallocate(temp0) + iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) + allocate(temp0(nx,ny+1,nsig+1)) + iret=nf90_get_var(gfile_loc,var_id,temp0) + uu(:,:,:)=temp0(:,:,2:nsig+1) + deallocate(temp0) endif if(mype == mype_v) then - allocate(temp0(nx+1,ny,nsig+1)) - iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id) - iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) - iret=nf90_get_var(gfile_loc,var_id,temp0) - uu(:,:,:)=(temp0(:,:,2:nsig+1)) - deallocate (temp0) + allocate(temp0(nx+1,ny,nsig+1)) + iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id) + iret=nf90_inquire_variable(gfile_loc,var_id,ndims=ndim) + iret=nf90_get_var(gfile_loc,var_id,temp0) + uu(:,:,:)=(temp0(:,:,2:nsig+1)) + deallocate (temp0) endif nztmp=nsig nzp1=nztmp+1 @@ -1456,13 +1456,13 @@ subroutine gsi_fv3ncdf_readuv_v1(dynvarsfile,ges_u,ges_v) ir=nzp1-i if(mype == mype_u)then do j=1,ny - uorv(:,j)=half*(uu(:,j,i)+uu(:,j+1,i)) + uorv(:,j)=half*(uu(:,j,i)+uu(:,j+1,i)) enddo call fv3_h_to_ll(uorv(:,:),a,nx,ny,nxa,nya) else do j=1,nx - uorv(j,:)=half*(uu(j,:,i)+uu(j+1,:,i)) + uorv(j,:)=half*(uu(j,:,i)+uu(j+1,:,i)) enddo call fv3_h_to_ll(uorv(:,:),a,nx,ny,nxa,nya) endif @@ -1494,10 +1494,10 @@ end subroutine gsi_fv3ncdf_readuv_v1 subroutine wrfv3_netcdf(fv3filenamegin) !$$$ subprogram documentation block ! . . . . -! subprogram: wrfv3_netcdf write out FV3 analysis increments +! subprogram: wrfv3_netcdf write out fv3 analysis increments ! prgmmr: wu org: np22 date: 2017-10-23 ! -! abstract: write FV3 analysis in netcdf format +! abstract: write fv3 analysis in netcdf format ! ! program history log: ! @@ -1520,38 +1520,38 @@ subroutine wrfv3_netcdf(fv3filenamegin) ! Declare local constants logical add_saved - character(len=:),allocatable :: dynvars !='fv3_dynvars' - character(len=:),allocatable :: tracers !='fv3_tracer' + character(len=:),allocatable :: dynvars !='fv3_dynvars' + character(len=:),allocatable :: tracers !='fv3_tracer' ! variables for cloud info integer(i_kind) ier,istatus,it - real(r_kind),pointer,dimension(:,: ):: ges_ps =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_u =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_v =>NULL() - real(r_kind),pointer,dimension(:,:,:):: ges_q =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_ps =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_u =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_v =>null() + real(r_kind),pointer,dimension(:,:,:):: ges_q =>null() dynvars=fv3filenamegin%dynvars tracers=fv3filenamegin%tracers it=ntguessig ier=0 - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus - call GSI_BundleGetPointer ( GSI_MetGuess_Bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'ps' ,ges_ps ,istatus );ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'u' , ges_u ,istatus);ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'v' , ges_v ,istatus);ier=ier+istatus + call gsi_bundlegetpointer ( gsi_metguess_bundle(it), 'q' ,ges_q ,istatus);ier=ier+istatus if (ier/=0) call die('get ges','cannot get pointers for fv3 met-fields, ier =',ier) add_saved=.true. ! write out if( fv3sar_bg_opt == 0) then - call gsi_fv3ncdf_write(dynvars,'T',ges_tsen(1,1,1,it),mype_t,add_saved) - call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) - call gsi_fv3ncdf_writeuv(dynvars,ges_u,ges_v,mype_v,add_saved) - call gsi_fv3ncdf_writeps(dynvars,'delp',ges_ps,mype_p,add_saved) + call gsi_fv3ncdf_write(dynvars,'T',ges_tsen(1,1,1,it),mype_t,add_saved) + call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) + call gsi_fv3ncdf_writeuv(dynvars,ges_u,ges_v,mype_v,add_saved) + call gsi_fv3ncdf_writeps(dynvars,'delp',ges_ps,mype_p,add_saved) else - call gsi_fv3ncdf_write(dynvars,'t',ges_tsen(1,1,1,it),mype_t,add_saved) - call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) - call gsi_fv3ncdf_writeuv_v1(dynvars,ges_u,ges_v,mype_v,add_saved) - call gsi_fv3ncdf_writeps_v1(dynvars,'ps',ges_ps,mype_p,add_saved) + call gsi_fv3ncdf_write(dynvars,'t',ges_tsen(1,1,1,it),mype_t,add_saved) + call gsi_fv3ncdf_write(tracers,'sphum',ges_q ,mype_q,add_saved) + call gsi_fv3ncdf_writeuv_v1(dynvars,ges_u,ges_v,mype_v,add_saved) + call gsi_fv3ncdf_writeps_v1(dynvars,'ps',ges_ps,mype_p,add_saved) endif @@ -1563,7 +1563,7 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) ! subprogram: gsi_nemsio_writeuv ! pgrmmr: wu ! -! abstract: gather u/v fields to mype_io, put u/v in FV3 model defined directions & orders +! abstract: gather u/v fields to mype_io, put u/v in fv3 model defined directions & orders ! then write out ! ! program history log: @@ -1601,7 +1601,7 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) integer(i_kind),intent(in ) :: mype_io logical ,intent(in ) :: add_saved - integer(i_kind) :: ugrd_VarId,gfile_loc,vgrd_VarId + integer(i_kind) :: ugrd_varid,gfile_loc,vgrd_varid integer(i_kind) i,j,mm1,n,k,ns,kr,m real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_au,work_av @@ -1612,7 +1612,7 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) mm1=mype+1 allocate( work(max(iglobal,itotsub)*nsig),work_sub(lat1,lon1,nsig)) -!!!!!! gather analysis u !! revers k !!!!!!!!!!! +!!!!!! gather analysis u !! reverse k !!!!!!!!!!! do k=1,nsig kr=nsig+1-k do i=1,lon1 @@ -1654,8 +1654,8 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) do m=1,npe do k=1,nsig do n=displs_g(m)+1,displs_g(m)+ijn(m) - ns=ns+1 - work_av(ltosi(n),ltosj(n),k)=work(ns) + ns=ns+1 + work_av(ltosi(n),ltosj(n),k)=work(ns) end do enddo enddo @@ -1665,16 +1665,16 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) allocate( work_bu(nlon_regional,nlat_regional+1,nsig)) allocate( work_bv(nlon_regional+1,nlat_regional,nsig)) call check( nf90_open(trim(dynvars ),nf90_write,gfile_loc) ) - call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'u',ugrd_varid) ) + call check( nf90_inq_varid(gfile_loc,'v',vgrd_varid) ) if(add_saved)then allocate( workau2(nlat,nlon),workav2(nlat,nlon)) allocate( workbu2(nlon_regional,nlat_regional+1)) allocate( workbv2(nlon_regional+1,nlat_regional)) !!!!!!!! readin work_b !!!!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu) ) - call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv) ) + call check( nf90_get_var(gfile_loc,ugrd_varid,work_bu) ) + call check( nf90_get_var(gfile_loc,vgrd_varid,work_bv) ) do k=1,nsig call fv3uv2earth(work_bu(1,1,k),work_bv(1,1,k),nlon_regional,nlat_regional,u,v) call fv3_h_to_ll(u,workau2,nlon_regional,nlat_regional,nlon,nlat) @@ -1700,8 +1700,8 @@ subroutine gsi_fv3ncdf_writeuv(dynvars,varu,varv,mype_io,add_saved) deallocate(work_au,work_av,u,v) print *,'write out u/v to ',trim(dynvars ) - call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu) ) - call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv) ) + call check( nf90_put_var(gfile_loc,ugrd_varid,work_bu) ) + call check( nf90_put_var(gfile_loc,vgrd_varid,work_bv) ) call check( nf90_close(gfile_loc) ) deallocate(work_bu,work_bv) end if !mype_io @@ -1751,7 +1751,7 @@ subroutine gsi_fv3ncdf_writeps(filename,varname,var,mype_io,add_saved) logical ,intent(in ) :: add_saved character(*) ,intent(in ) :: varname,filename - integer(i_kind) :: VarId,gfile_loc + integer(i_kind) :: varid,gfile_loc integer(i_kind) i,j,mm1,k,kr,kp real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:):: work_sub,work_a @@ -1777,13 +1777,13 @@ subroutine gsi_fv3ncdf_writeps(filename,varname,var,mype_io,add_saved) allocate( work_bi(nlon_regional,nlat_regional,nsig+1)) allocate( work_b(nlon_regional,nlat_regional,nsig)) call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) - call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),varid) ) if(add_saved)then allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlat,nlon)) !!!!!!!! read in guess delp !!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,VarId,work_b) ) + call check( nf90_get_var(gfile_loc,varid,work_b) ) work_bi(:,:,1)=eta1_ll(nsig+1) do i=2,nsig+1 work_bi(:,:,i)=work_b(:,:,i-1)*0.001_r_kind+work_bi(:,:,i-1) @@ -1801,7 +1801,7 @@ subroutine gsi_fv3ncdf_writeps(filename,varname,var,mype_io,add_saved) call fv3_ll_to_h(work_a,workb2,nlon,nlat,nlon_regional,nlat_regional,.true.) do k=1,nsig+1 kr=nsig+2-k -!!!!!!! Psfc_ges+hydrostatic analysis_inc !!!!!!!!!!!!!!!! +!!!!!!! psfc_ges+hydrostatic analysis_inc !!!!!!!!!!!!!!!! work_bi(:,:,k)=eta1_ll(kr)+eta2_ll(kr)*workb2(:,:) enddo endif @@ -1811,7 +1811,7 @@ subroutine gsi_fv3ncdf_writeps(filename,varname,var,mype_io,add_saved) work_b(:,:,k)=(work_bi(:,:,kp)-work_bi(:,:,k))*1000._r_kind enddo - call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_put_var(gfile_loc,varid,work_b) ) call check( nf90_close(gfile_loc) ) deallocate(worka2,workb2) deallocate(work_b,work_a,work_bi) @@ -1826,7 +1826,7 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) ! subprogram: gsi_nemsio_writeuv ! pgrmmr: wu ! -! abstract: gather u/v fields to mype_io, put u/v in FV3 model defined directions & orders +! abstract: gather u/v fields to mype_io, put u/v in fv3 model defined directions & orders ! then write out ! ! program history log: @@ -1867,8 +1867,8 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) logical ,intent(in ) :: add_saved integer(i_kind) :: gfile_loc - integer(i_kind) :: u_wgrd_VarId,v_wgrd_VarId - integer(i_kind) :: u_sgrd_VarId,v_sgrd_VarId + integer(i_kind) :: u_wgrd_varid,v_wgrd_varid + integer(i_kind) :: u_sgrd_varid,v_sgrd_varid integer(i_kind) i,j,mm1,n,k,ns,kr,m real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_au,work_av @@ -1881,7 +1881,7 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) mm1=mype+1 allocate( work(max(iglobal,itotsub)*nsig),work_sub(lat1,lon1,nsig)) -!!!!!! gather analysis u !! revers k !!!!!!!!!!! +!!!!!! gather analysis u !! reverse k !!!!!!!!!!! do k=1,nsig kr=nsig+1-k do i=1,lon1 @@ -1923,14 +1923,14 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) do m=1,npe do k=1,nsig do n=displs_g(m)+1,displs_g(m)+ijn(m) - ns=ns+1 - work_av(ltosi(n),ltosj(n),k)=work(ns) + ns=ns+1 + work_av(ltosi(n),ltosj(n),k)=work(ns) end do enddo enddo deallocate(work,work_sub) -!clt u and v would contain winds at either D-grid or A-grid -!clt do not diretly use them in between fv3uv2eath and fv3_h_to_ll unless paying +! u and v would contain winds at either d-grid or a-grid +! do not diretly use them in between fv3uv2eath and fv3_h_to_ll unless paying !attention to the actual storage layout call check( nf90_open(trim(dynvars ),nf90_write,gfile_loc) ) @@ -1944,10 +1944,10 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) - call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_varid) ) + call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_varid) ) + call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_varid) ) + call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_varid) ) if(add_saved)then allocate( workau2(nlat,nlon),workav2(nlat,nlon)) @@ -1956,10 +1956,10 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) allocate( workbu_s2(nlon_regional,nlat_regional+1)) allocate( workbv_s2(nlon_regional,nlat_regional+1)) !!!!!!!! readin work_b !!!!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s) ) - call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w) ) - call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s) ) - call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w) ) + call check( nf90_get_var(gfile_loc,u_sgrd_varid,work_bu_s) ) + call check( nf90_get_var(gfile_loc,u_wgrd_varid,work_bu_w) ) + call check( nf90_get_var(gfile_loc,v_sgrd_varid,work_bv_s) ) + call check( nf90_get_var(gfile_loc,v_wgrd_varid,work_bv_w) ) do k=1,nsig do j=1,nlat_regional u(:,j)=half * (work_bu_s(:,j,k)+ work_bu_s(:,j+1,k)) @@ -1976,8 +1976,8 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) !!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! do i=2,nlon_regional-1 - workbu_w2(i,:)=half*(u(i,:)+u(i+1,:)) - workbv_w2(i,:)=half*(v(i,:)+v(i+1,:)) + workbu_w2(i,:)=half*(u(i,:)+u(i+1,:)) + workbv_w2(i,:)=half*(v(i,:)+v(i+1,:)) enddo workbu_w2(1,:)=u(1,:) workbv_w2(1,:)=v(1,:) @@ -1985,8 +1985,8 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) workbv_w2(nlon_regional+1,:)=v(nlon_regional,:) do j=2,nlat_regional-1 - workbu_s2(:,j)=half*(u(:,j)+u(:,j+1)) - workbv_s2(:,j)=half*(v(:,j)+v(:,j+1)) + workbu_s2(:,j)=half*(u(:,j)+u(:,j+1)) + workbv_s2(:,j)=half*(v(:,j)+v(:,j+1)) enddo workbu_s2(:,1)=u(:,1) workbv_s2(:,1)=v(:,1) @@ -2009,8 +2009,8 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) call fv3_ll_to_h(work_av(:,:,k),v,nlon,nlat,nlon_regional,nlat_regional,.true.) do i=2,nlon_regional-1 - work_bu_w(i,:,k)=half*(u(i,:)+u(i+1,:)) - work_bv_w(i,:,k)=half*(v(i,:)+v(i+1,:)) + work_bu_w(i,:,k)=half*(u(i,:)+u(i+1,:)) + work_bv_w(i,:,k)=half*(v(i,:)+v(i+1,:)) enddo work_bu_w(1,:,k)=u(1,:) work_bv_w(1,:,k)=v(1,:) @@ -2018,8 +2018,8 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) work_bv_w(nlon_regional+1,:,k)=v(nlon_regional,:) do j=2,nlat_regional-1 - work_bu_s(:,j,k)=half*(u(:,j)+u(:,j+1)) - work_bv_s(:,j,k)=half*(v(:,j)+v(:,j+1)) + work_bu_s(:,j,k)=half*(u(:,j)+u(:,j+1)) + work_bv_s(:,j,k)=half*(v(:,j)+v(:,j+1)) enddo work_bu_s(:,1,k)=u(:,1) work_bv_s(:,1,k)=v(:,1) @@ -2032,10 +2032,10 @@ subroutine gsi_fv3ncdf_writeuv_v1(dynvars,varu,varv,mype_io,add_saved) deallocate(work_au,work_av,u,v) print *,'write out u/v to ',trim(dynvars ) - call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w) ) - call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s) ) - call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w) ) - call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s) ) + call check( nf90_put_var(gfile_loc,u_wgrd_varid,work_bu_w) ) + call check( nf90_put_var(gfile_loc,u_sgrd_varid,work_bu_s) ) + call check( nf90_put_var(gfile_loc,v_wgrd_varid,work_bv_w) ) + call check( nf90_put_var(gfile_loc,v_sgrd_varid,work_bv_s) ) call check( nf90_close(gfile_loc) ) deallocate(work_bu_w,work_bv_w) deallocate(work_bu_s,work_bv_s) @@ -2087,7 +2087,7 @@ subroutine gsi_fv3ncdf_writeps_v1(filename,varname,var,mype_io,add_saved) logical ,intent(in ) :: add_saved character(*) ,intent(in ) :: varname,filename - integer(i_kind) :: VarId,gfile_loc + integer(i_kind) :: varid,gfile_loc integer(i_kind) i,j,mm1 real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:):: work_sub,work_a @@ -2113,13 +2113,13 @@ subroutine gsi_fv3ncdf_writeps_v1(filename,varname,var,mype_io,add_saved) allocate( work_bi(nlon_regional,nlat_regional)) allocate( work_b(nlon_regional,nlat_regional)) call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) - call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),varid) ) work_a=work_a*1000.0_r_kind if(add_saved)then allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlat,nlon)) !!!!!!!! read in guess delp !!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,VarId,work_b) ) + call check( nf90_get_var(gfile_loc,varid,work_b) ) call fv3_h_to_ll(work_b,worka2,nlon_regional,nlat_regional,nlon,nlat) !!!!!!! analysis_inc Psfc: work_a work_a(:,:)=work_a(:,:)-worka2(:,:) @@ -2130,7 +2130,7 @@ subroutine gsi_fv3ncdf_writeps_v1(filename,varname,var,mype_io,add_saved) endif - call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_put_var(gfile_loc,varid,work_b) ) call check( nf90_close(gfile_loc) ) deallocate(worka2,workb2) deallocate(work_b,work_a,work_bi) @@ -2180,7 +2180,7 @@ subroutine gsi_fv3ncdf_write(filename,varname,var,mype_io,add_saved) logical ,intent(in ) :: add_saved character(*) ,intent(in ) :: varname,filename - integer(i_kind) :: VarId,gfile_loc + integer(i_kind) :: varid,gfile_loc integer(i_kind) i,j,mm1,k,kr,ns,n,m real(r_kind),allocatable,dimension(:):: work real(r_kind),allocatable,dimension(:,:,:):: work_sub,work_a @@ -2218,13 +2218,13 @@ subroutine gsi_fv3ncdf_write(filename,varname,var,mype_io,add_saved) allocate( work_b(nlon_regional,nlat_regional,nsig)) call check( nf90_open(trim(filename),nf90_write,gfile_loc) ) - call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_inq_varid(gfile_loc,trim(varname),varid) ) if(add_saved)then allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlat,nlon)) - call check( nf90_get_var(gfile_loc,VarId,work_b) ) + call check( nf90_get_var(gfile_loc,varid,work_b) ) do k=1,nsig call fv3_h_to_ll(work_b(:,:,k),worka2,nlon_regional,nlat_regional,nlon,nlat) @@ -2241,7 +2241,7 @@ subroutine gsi_fv3ncdf_write(filename,varname,var,mype_io,add_saved) endif print *,'write out ',trim(varname),' to ',trim(filename) - call check( nf90_put_var(gfile_loc,VarId,work_b) ) + call check( nf90_put_var(gfile_loc,varid,work_b) ) call check( nf90_close(gfile_loc) ) deallocate(work_b,work_a) end if !mype_io @@ -2252,6 +2252,7 @@ end subroutine gsi_fv3ncdf_write subroutine check(status) use kinds, only: i_kind use netcdf, only: nf90_noerr,nf90_strerror + implicit none integer(i_kind), intent ( in) :: status if(status /= nf90_noerr) then diff --git a/src/gsi/gsi_rwOper.F90 b/src/gsi/gsi_rwoper.f90 similarity index 70% rename from src/gsi/gsi_rwOper.F90 rename to src/gsi/gsi_rwoper.f90 index e5806afbad..757e61464e 100644 --- a/src/gsi/gsi_rwOper.F90 +++ b/src/gsi/gsi_rwoper.f90 @@ -1,12 +1,12 @@ -module gsi_rwOper +module gsi_rwoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_rwOper +! subprogram: module gsi_rwoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for rwNode type +! abstract: an oboper extension for rwnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_rwOper ! module interface: - use gsi_obOper, only: obOper - use m_rwNode , only: rwNode + use gsi_oboper, only: oboper + use m_rwnode , only: rwnode implicit none - public:: rwOper ! data stracture + public:: rwoper ! data stracture - type,extends(obOper):: rwOper + type,extends(oboper):: rwoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type rwOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type rwoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_rwOper' - type(rwNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_rwoper' + type(rwnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[rwOper]" + mytype="[rwoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use rw_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(rwOper ), intent(inout):: self + class(rwoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intrwmod, only: intjo => intrw use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(rwOper ),intent(in ):: self + class(rwoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stprwmod, only: stpjo => stprw use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(rwOper ),intent(in):: self + class(rwoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_rwOper +end module gsi_rwoper diff --git a/src/gsi/gsi_spdOper.F90 b/src/gsi/gsi_spdoper.f90 similarity index 70% rename from src/gsi/gsi_spdOper.F90 rename to src/gsi/gsi_spdoper.f90 index c121adc9df..9e5626d8cc 100644 --- a/src/gsi/gsi_spdOper.F90 +++ b/src/gsi/gsi_spdoper.f90 @@ -1,12 +1,12 @@ -module gsi_spdOper +module gsi_spdoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_spdOper +! subprogram: module gsi_spdoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for spdNode type +! abstract: an oboper extension for spdnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_spdOper ! module interface: - use gsi_obOper, only: obOper - use m_spdNode , only: spdNode + use gsi_oboper, only: oboper + use m_spdnode , only: spdnode implicit none - public:: spdOper ! data stracture + public:: spdoper ! data stracture - type,extends(obOper):: spdOper + type,extends(oboper):: spdoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type spdOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type spdoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_spdOper' - type(spdNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_spdoper' + type(spdnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[spdOper]" + mytype="[spdoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use spd_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(spdOper ), intent(inout):: self + class(spdoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intspdmod, only: intjo => intspd use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(spdOper ),intent(in ):: self + class(spdoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpspdmod, only: stpjo => stpspd use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(spdOper ),intent(in):: self + class(spdoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_spdOper +end module gsi_spdoper diff --git a/src/gsi/gsi_sstOper.F90 b/src/gsi/gsi_sstoper.f90 similarity index 70% rename from src/gsi/gsi_sstOper.F90 rename to src/gsi/gsi_sstoper.f90 index ef75786ae5..05e9d8de1f 100644 --- a/src/gsi/gsi_sstOper.F90 +++ b/src/gsi/gsi_sstoper.f90 @@ -1,12 +1,12 @@ -module gsi_sstOper +module gsi_sstoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_sstOper +! subprogram: module gsi_sstoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for sstNode type +! abstract: an oboper extension for sstnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_sstOper ! module interface: - use gsi_obOper, only: obOper - use m_sstNode , only: sstNode + use gsi_oboper, only: oboper + use m_sstnode , only: sstnode implicit none - public:: sstOper ! data stracture + public:: sstoper ! data stracture - type,extends(obOper):: sstOper + type,extends(oboper):: sstoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type sstOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type sstoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_sstOper' - type(sstNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_sstoper' + type(sstnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[sstOper]" + mytype="[sstoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use sst_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(sstOper ), intent(inout):: self + class(sstoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intsstmod, only: intjo => intsst use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(sstOper ),intent(in ):: self + class(sstoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpsstmod, only: stpjo => stpsst use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(sstOper ),intent(in):: self + class(sstoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_sstOper +end module gsi_sstoper diff --git a/src/gsi/gsi_swcpOper.F90 b/src/gsi/gsi_swcpoper.f90 similarity index 70% rename from src/gsi/gsi_swcpOper.F90 rename to src/gsi/gsi_swcpoper.f90 index 3c6dc1ea4e..b9602c015a 100644 --- a/src/gsi/gsi_swcpOper.F90 +++ b/src/gsi/gsi_swcpoper.f90 @@ -1,12 +1,12 @@ -module gsi_swcpOper +module gsi_swcpoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_swcpOper +! subprogram: module gsi_swcpoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for swcpNode type +! abstract: an oboper extension for swcpnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_swcpOper ! module interface: - use gsi_obOper, only: obOper - use m_swcpNode, only: swcpNode + use gsi_oboper, only: oboper + use m_swcpnode, only: swcpnode implicit none - public:: swcpOper ! data stracture + public:: swcpoper ! data stracture - type,extends(obOper):: swcpOper + type,extends(oboper):: swcpoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type swcpOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type swcpoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_swcpOper' - type(swcpNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_swcpoper' + type(swcpnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[swcpOper]" + mytype="[swcpoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use swcp_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(swcpOper ), intent(inout):: self + class(swcpoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intswcpmod, only: intjo => intswcp use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(swcpOper ),intent(in ):: self + class(swcpoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpswcpmod, only: stpjo => stpswcp use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(swcpOper ),intent(in):: self + class(swcpoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_swcpOper +end module gsi_swcpoper diff --git a/src/gsi/gsi_tcamtOper.F90 b/src/gsi/gsi_tcamtoper.f90 similarity index 70% rename from src/gsi/gsi_tcamtOper.F90 rename to src/gsi/gsi_tcamtoper.f90 index f12ac72a63..305a366d83 100644 --- a/src/gsi/gsi_tcamtOper.F90 +++ b/src/gsi/gsi_tcamtoper.f90 @@ -1,12 +1,12 @@ -module gsi_tcamtOper +module gsi_tcamtoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_tcamtOper +! subprogram: module gsi_tcamtoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for tcamtNode type +! abstract: an oboper extension for tcamtnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_tcamtOper ! module interface: - use gsi_obOper , only: obOper - use m_tcamtNode, only: tcamtNode + use gsi_oboper , only: oboper + use m_tcamtnode, only: tcamtnode implicit none - public:: tcamtOper ! data stracture + public:: tcamtoper ! data stracture - type,extends(obOper):: tcamtOper + type,extends(oboper):: tcamtoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type tcamtOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type tcamtoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_tcamtOper' - type(tcamtNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_tcamtoper' + type(tcamtnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[tcamtOper]" + mytype="[tcamtoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use tcamt_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(tcamtOper ), intent(inout):: self + class(tcamtoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use inttcamtmod, only: intjo => inttcamt use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(tcamtOper ),intent(in ):: self + class(tcamtoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stptcamtmod, only: stpjo => stptcamt use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(tcamtOper ),intent(in):: self + class(tcamtoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_tcamtOper +end module gsi_tcamtoper diff --git a/src/gsi/gsi_tcpOper.F90 b/src/gsi/gsi_tcpoper.f90 similarity index 70% rename from src/gsi/gsi_tcpOper.F90 rename to src/gsi/gsi_tcpoper.f90 index 706c24164d..97071aaf6c 100644 --- a/src/gsi/gsi_tcpOper.F90 +++ b/src/gsi/gsi_tcpoper.f90 @@ -1,12 +1,12 @@ -module gsi_tcpOper +module gsi_tcpoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_tcpOper +! subprogram: module gsi_tcpoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for tcpNode type +! abstract: an oboper extension for tcpnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_tcpOper ! module interface: - use gsi_obOper, only: obOper - use m_tcpNode , only: tcpNode + use gsi_oboper, only: oboper + use m_tcpnode , only: tcpnode implicit none - public:: tcpOper ! data stracture + public:: tcpoper ! data stracture - type,extends(obOper):: tcpOper + type,extends(oboper):: tcpoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type tcpOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type tcpoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_tcpOper' - type(tcpNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_tcpoper' + type(tcpnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[tcpOper]" + mytype="[tcpoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use tcp_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(tcpOper ), intent(inout):: self + class(tcpoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use inttcpmod, only: intjo => inttcp use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(tcpOper ),intent(in ):: self + class(tcpoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stptcpmod, only: stpjo => stptcp use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(tcpOper ),intent(in):: self + class(tcpoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_tcpOper +end module gsi_tcpoper diff --git a/src/gsi/gsi_td2mOper.F90 b/src/gsi/gsi_td2moper.f90 similarity index 70% rename from src/gsi/gsi_td2mOper.F90 rename to src/gsi/gsi_td2moper.f90 index 3a99169b92..fe387ef8c2 100644 --- a/src/gsi/gsi_td2mOper.F90 +++ b/src/gsi/gsi_td2moper.f90 @@ -1,12 +1,12 @@ -module gsi_td2mOper +module gsi_td2moper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_td2mOper +! subprogram: module gsi_td2moper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for td2mNode type +! abstract: an oboper extension for td2mnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_td2mOper ! module interface: - use gsi_obOper, only: obOper - use m_td2mNode, only: td2mNode + use gsi_oboper, only: oboper + use m_td2mnode, only: td2mnode implicit none - public:: td2mOper ! data stracture + public:: td2moper ! data stracture - type,extends(obOper):: td2mOper + type,extends(oboper):: td2moper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type td2mOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type td2moper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_td2mOper' - type(td2mNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_td2moper' + type(td2mnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[td2mOper]" + mytype="[td2moper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use td2m_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(td2mOper ), intent(inout):: self + class(td2moper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use inttd2mmod, only: intjo => inttd2m use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(td2mOper ),intent(in ):: self + class(td2moper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stptd2mmod, only: stpjo => stptd2m use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(td2mOper ),intent(in):: self + class(td2moper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_td2mOper +end module gsi_td2moper diff --git a/src/gsi/gsi_tOper.F90 b/src/gsi/gsi_toper.f90 similarity index 71% rename from src/gsi/gsi_tOper.F90 rename to src/gsi/gsi_toper.f90 index 47f3e4c608..f8a65afe18 100644 --- a/src/gsi/gsi_tOper.F90 +++ b/src/gsi/gsi_toper.f90 @@ -1,12 +1,12 @@ -module gsi_tOper +module gsi_toper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_tOper +! subprogram: module gsi_toper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for tNode type +! abstract: an oboper extension for tnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_tOper ! module interface: - use gsi_obOper, only: obOper - use m_tNode , only: tNode + use gsi_oboper, only: oboper + use m_tnode , only: tnode implicit none - public:: tOper ! data stracture + public:: toper ! data stracture - type,extends(obOper):: tOper + type,extends(oboper):: toper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type tOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type toper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_tOper' - type(tNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_toper' + type(tnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[tOper]" + mytype="[toper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use t_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(tOper ), intent(inout):: self + class(toper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -110,11 +110,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors use bias_predictors, only: predictors_getdim - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(tOper ),intent(in ):: self + class(toper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -124,7 +124,7 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" integer(i_kind):: i,l,n - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode ! Are the different calls to intt() with optional arguments realy needed? ! There is no checking of present(rpred) or present(spred) inside intt_() @@ -132,13 +132,13 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) ! spred(:). call predictors_getdim(lbnd_t=i,ubnd_t=l,size_t=n) - headNode => obsLList_headNode(self%obsLL(ibin)) + headnode => obsllist_headnode(self%obsll(ibin)) if(n>0) then - call intjo(headNode, rval,sval, qpred(i:l),sbias%predt) + call intjo(headnode, rval,sval, qpred(i:l),sbias%predt) else - call intjo(headNode, rval,sval) + call intjo(headnode, rval,sval) endif - headNode => null() + headnode => null() end subroutine intjo1_ @@ -147,11 +147,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors, predictors_getdim use aircraftinfo, only: npredt,ntail,aircraft_t_bc_pof,aircraft_t_bc - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(tOper ),intent(in):: self + class(toper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -164,7 +164,7 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode real(r_kind),pointer,dimension(:,:) :: dpred,xpred integer(i_kind):: n @@ -173,18 +173,18 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) ! anyway. Other logic is used to avoid accessing non-present rpred(:) and ! spred(:). - headNode => obsLList_headNode(self%obsLL(ibin)) + headnode => obsllist_headnode(self%obsll(ibin)) call predictors_getdim(size_t=n) if(n<=0 .or. .not. (aircraft_t_bc_pof .or. aircraft_t_bc)) then - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) else - dpred(1:npredt,1:ntail) => dbias%predt(1:n) - xpred(1:npredt,1:ntail) => xbias%predt(1:n) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep,dpred,xpred) - dpred => null() - xpred => null() + dpred(1:npredt,1:ntail) => dbias%predt(1:n) + xpred(1:npredt,1:ntail) => xbias%predt(1:n) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep,dpred,xpred) + dpred => null() + xpred => null() endif - headNode => null() + headnode => null() end subroutine stpjo1_ -end module gsi_tOper +end module gsi_toper diff --git a/src/gsi/gsi_unformatted.F90 b/src/gsi/gsi_unformatted.F90 index 1e5a4a5bff..8c22f50d26 100644 --- a/src/gsi/gsi_unformatted.F90 +++ b/src/gsi/gsi_unformatted.F90 @@ -38,7 +38,7 @@ module gsi_unformatted ! -- look up class in a fileinfo table, for a convert definition public :: fileinfo_reset ! ([fileinfo]) ! -- deallocate(fileinfo_xx) or set an alternate fileinfo filename. - public :: FILEINFO_LEN ! the internal lenth of fields class and convert. + public :: fileinfo_len ! the internal lenth of fields class and convert. interface unformatted_open; module procedure open_; end interface interface fileinfo_lookup ; module procedure lookup_; end interface @@ -53,18 +53,18 @@ module gsi_unformatted !!! Usage: !!! !!! ! lookup convert value for a user defined class '.bufr.' -!!! use gsi_unformatted, only: fileinfo_lookup, FILEINFO_LEN -!!! character(len=FILEINFO_LEN):: convert +!!! use gsi_unformatted, only: fileinfo_lookup, fileinfo_len +!!! character(len=fileinfo_len):: convert !!! convert='native' !!! call fileinfo_lookup('.bufr.',convert) !!! or !!! ! lookup convert value for a given filename -!!! use gsi_unformatted, only: fileinfo_lookup, FILEINFO_LEN -!!! character(len=FILEINFO_LEN):: convert +!!! use gsi_unformatted, only: fileinfo_lookup, fileinfo_len +!!! character(len=fileinfo_len):: convert !!! convert='' !!! call fileinfo_lookup(filename,convert) !!! or -!!! ! open an existed BUFR file for input +!!! ! open an existed bufr file for input !!! use gsi_unformatted, only: unformatted_open !!! call unformatted_open(unit,file,class='.bufr.',status='old',iostat=ier) !!! @@ -81,13 +81,13 @@ module gsi_unformatted !!# !!# Note: Reserved values in this implementation of this module. !!# class == ".default." -- for all files -!!# convert == "_NOT_SUPPORTED_" -- flag compilers not supporting "convert" -!!# convert == "_NOT_FOUND_" -- flag a failed lookup() call. +!!# convert == "_not_supported_" -- flag compilers not supporting "convert" +!!# convert == "_not_found_" -- flag a failed lookup() call. !!# !!# class/file convert !!#-------------------------------------- !! .default. "" # a class name reserved for all files -!! .bufr. little_endian # for all BUFR files +!! .bufr. little_endian # for all bufr files !! prepbufr native # an exception from .bufr. !! .berror. native # for files grouped under .berror. !! berror_stats big_endian # an exception from .berror. @@ -97,29 +97,29 @@ module gsi_unformatted !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ character(len=*),parameter :: myname='gsi_unformatted' - integer(i_kind),parameter:: FILEINFO_LEN=64 - integer(i_kind),parameter:: FILEINFO_INC=32 + integer(i_kind),parameter:: fileinfo_len=64 + integer(i_kind),parameter:: fileinfo_inc=32 - integer(i_kind),parameter:: FILEINFO_REC=256 - integer(i_kind),parameter:: FILEINFO_FNL=512 ! in case it has a very long pathname + integer(i_kind),parameter:: fileinfo_rec=256 + integer(i_kind),parameter:: fileinfo_fnl=512 ! in case it has a very long pathname #ifdef _DO_NOT_SUPPORT_OPEN_WITH_CONVERT_ - logical,parameter:: CONVERT_SUPPORTED_ = .false. + logical,parameter:: convert_supported_ = .false. #else - logical,parameter:: CONVERT_SUPPORTED_ = .true. + logical,parameter:: convert_supported_ = .true. #endif ! Declare a "_fileinfo_" data structure, defining a class-vs-convert table. - character(len=*),parameter:: DEFAULT_FILEINFO_NAME ='unformatted_fileinfo' + character(len=*),parameter:: default_fileinfo_name ='unformatted_fileinfo' logical,save:: fileinfo_initialized_ = .false. - character(len=FILEINFO_FNL),save:: fileinfo_name_=DEFAULT_FILEINFO_NAME - integer(i_kind),save:: fileinfo_msize_=FILEINFO_INC ! allocated size + character(len=fileinfo_fnl),save:: fileinfo_name_=default_fileinfo_name + integer(i_kind),save:: fileinfo_msize_=fileinfo_inc ! allocated size integer(i_kind),save:: fileinfo_lsize_=-1 ! actual size - character(len=FILEINFO_LEN),dimension(:),pointer,save:: fileinfo_class_ - character(len=FILEINFO_LEN),dimension(:),pointer,save:: fileinfo_cnvrt_ + character(len=fileinfo_len),dimension(:),pointer,save:: fileinfo_class_ + character(len=fileinfo_len),dimension(:),pointer,save:: fileinfo_cnvrt_ integer(i_kind) ,dimension(:),pointer,save:: fileinfo_index_ ! name/class convert @@ -139,11 +139,11 @@ subroutine open_(unit,file,class,newunit,action,position,status,iostat,silent) integer(i_kind):: iostat_ logical :: newunit_ - character(len=FILEINFO_LEN):: class_ - character(len=FILEINFO_LEN):: action_ - character(len=FILEINFO_LEN):: position_ - character(len=FILEINFO_LEN):: status_ - character(len=FILEINFO_LEN):: convert_ + character(len=fileinfo_len):: class_ + character(len=fileinfo_len):: action_ + character(len=fileinfo_len):: position_ + character(len=fileinfo_len):: status_ + character(len=fileinfo_len):: convert_ character(len=*),parameter:: myname_=myname//'::open_' class_ ='.default.'; if(present(class )) class_ =class @@ -155,7 +155,7 @@ subroutine open_(unit,file,class,newunit,action,position,status,iostat,silent) if(present(iostat)) iostat=0 #ifdef _DO_NOT_SUPPORT_OPEN_WITH_CONVERT_ - convert_="_NOT_SUPPORTED_" ! open(file with the compiler default convert + convert_="_not_supported_" ! open(file with the compiler default convert if(newunit_) then open(newunit=unit,file=file,access='sequential',form='unformatted', & action=action_,position=position_,status=status_,iostat=iostat_) @@ -165,30 +165,30 @@ subroutine open_(unit,file,class,newunit,action,position,status,iostat,silent) endif #else - convert_="_NOT_FOUND_" ! set a difault value + convert_="_not_found_" ! set a difault value call lookup_(class_,convert_,silent=silent) ! may override convert value, if an entry of class_ is found. call lookup_(file ,convert_,silent=silent) ! may override convert value, if an entry of file is found. select case(convert_) - case("","_NOT_FOUND_") ! open(file) with the compiler default convert - if(newunit_) then - open(newunit=unit,file=file,access='sequential',form='unformatted', & - action=action_,position=position_,status=status_,iostat=iostat_) - else - open( unit=unit,file=file,access='sequential',form='unformatted', & - action=action_,position=position_,status=status_,iostat=iostat_) - endif + case("","_not_found_") ! open(file) with the compiler default convert + if(newunit_) then + open(newunit=unit,file=file,access='sequential',form='unformatted', & + action=action_,position=position_,status=status_,iostat=iostat_) + else + open( unit=unit,file=file,access='sequential',form='unformatted', & + action=action_,position=position_,status=status_,iostat=iostat_) + endif - case default ! open(file) with user specified convert - if(newunit_) then - open(newunit=unit,file=file,access='sequential',form='unformatted', & - action=action_,position=position_,status=status_,iostat=iostat_, & - convert=convert_) - else - open( unit=unit,file=file,access='sequential',form='unformatted', & - action=action_,position=position_,status=status_,iostat=iostat_, & - convert=convert_) - endif + case default ! open(file) with user specified convert + if(newunit_) then + open(newunit=unit,file=file,access='sequential',form='unformatted', & + action=action_,position=position_,status=status_,iostat=iostat_, & + convert=convert_) + else + open( unit=unit,file=file,access='sequential',form='unformatted', & + action=action_,position=position_,status=status_,iostat=iostat_, & + convert=convert_) + endif end select #endif @@ -237,7 +237,7 @@ subroutine reset_(fileinfo) ! Reset fileinfo_name_, even if the fileinfo part has not been not ! initialized_. So one can lookup() from a different fileinfo. - fileinfo_name_= DEFAULT_FILEINFO_NAME + fileinfo_name_= default_fileinfo_name if(present(fileinfo)) fileinfo_name_= fileinfo ! Initialization (init_()) is defered to the time an actual lookup(). @@ -245,7 +245,7 @@ subroutine reset_(fileinfo) ! Reset to the pre-init_() state, except fileinfo_name_ fileinfo_initialized_ = .false. - fileinfo_msize_ = FILEINFO_INC + fileinfo_msize_ = fileinfo_inc fileinfo_lsize_ = -1 deallocate( fileinfo_class_, & fileinfo_cnvrt_, & @@ -258,35 +258,35 @@ subroutine init_(verbose) ! local variables integer(i_kind):: lu,ier,i,n - character(len=FILEINFO_LEN):: classi - character(len=FILEINFO_LEN):: cnvrti - character(len=FILEINFO_REC):: arec + character(len=fileinfo_len):: classi + character(len=fileinfo_len):: cnvrti + character(len=fileinfo_rec):: arec - character(len=FILEINFO_LEN),pointer,dimension(:):: p_class - character(len=FILEINFO_LEN),pointer,dimension(:):: p_cnvrt + character(len=fileinfo_len),pointer,dimension(:):: p_class + character(len=fileinfo_len),pointer,dimension(:):: p_cnvrt character(len=*),parameter:: myname_=myname//'::init_' fileinfo_initialized_=.true. - if(.not.CONVERT_SUPPORTED_.and.verbose) call warn(myname_,'Not supported, open(convert=..)') + if(.not.convert_supported_.and.verbose) call warn(myname_,'Not supported, open(convert=..)') ! read in the fileinfo table anyway lu=mpeu_luavail() open(lu,file=fileinfo_name_,status='old',form='formatted',iostat=ier) - if(ier/=0) then + if(ier/=0) then #ifndef _DO_NOT_SUPPORT_OPEN_WITH_CONVERT_ - if(verbose) then - call warn(myname_,'Can not open, file =',trim(fileinfo_name_)) - call warn(myname_,'Will use default convert values in code') - endif + if(verbose) then + call warn(myname_,'Can not open, file =',trim(fileinfo_name_)) + call warn(myname_,'Will use default convert values in code') + endif #endif - fileinfo_lsize_=0 - allocate( fileinfo_class_(0), & - fileinfo_cnvrt_(0), & - fileinfo_index_(0) ) - return - endif + fileinfo_lsize_=0 + allocate( fileinfo_class_(0), & + fileinfo_cnvrt_(0), & + fileinfo_index_(0) ) + return + endif n=fileinfo_msize_ allocate( fileinfo_class_(n), & @@ -296,13 +296,13 @@ subroutine init_(verbose) call mpeu_getarec(lu,arec,ier,commchar='#!') do while(ier==0) read(arec,*,iostat=ier) classi,cnvrti - if(ier/=0) cnvrti="" + if(ier/=0) cnvrti="" i=i+1 if(i>fileinfo_msize_) then ! realloc() p_class => fileinfo_class_ p_cnvrt => fileinfo_cnvrt_ - n=fileinfo_msize_+FILEINFO_INC + n=fileinfo_msize_+fileinfo_inc allocate( fileinfo_class_(n), & fileinfo_cnvrt_(n)) @@ -323,8 +323,8 @@ subroutine init_(verbose) close(lu) allocate(fileinfo_index_(fileinfo_lsize_)) - call indexSet (fileinfo_index_(1:fileinfo_lsize_)) - call indexSort(fileinfo_index_(1:fileinfo_lsize_), & + call indexset (fileinfo_index_(1:fileinfo_lsize_)) + call indexsort(fileinfo_index_(1:fileinfo_lsize_), & fileinfo_class_(1:fileinfo_lsize_), descend=.false.) end subroutine init_ diff --git a/src/gsi/gsi_uwnd10mOper.F90 b/src/gsi/gsi_uwnd10moper.f90 similarity index 69% rename from src/gsi/gsi_uwnd10mOper.F90 rename to src/gsi/gsi_uwnd10moper.f90 index 4d35a61c31..f063643429 100644 --- a/src/gsi/gsi_uwnd10mOper.F90 +++ b/src/gsi/gsi_uwnd10moper.f90 @@ -1,12 +1,12 @@ -module gsi_uwnd10mOper +module gsi_uwnd10moper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_uwnd10mOper +! subprogram: module gsi_uwnd10moper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for uwnd10mNode type +! abstract: an oboper extension for uwnd10mnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_uwnd10mOper ! module interface: - use gsi_obOper , only: obOper - use m_uwnd10mNode, only: uwnd10mNode + use gsi_oboper , only: oboper + use m_uwnd10mnode, only: uwnd10mnode implicit none - public:: uwnd10mOper ! data stracture + public:: uwnd10moper ! data stracture - type,extends(obOper):: uwnd10mOper + type,extends(oboper):: uwnd10moper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type uwnd10mOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type uwnd10moper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_uwnd10mOper' - type(uwnd10mNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_uwnd10moper' + type(uwnd10mnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[uwnd10mOper]" + mytype="[uwnd10moper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use uwnd10m_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(uwnd10mOper ), intent(inout):: self + class(uwnd10moper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intuwnd10mmod, only: intjo => intuwnd10m use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(uwnd10mOper ),intent(in ):: self + class(uwnd10moper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpuwnd10mmod, only: stpjo => stpuwnd10m use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(uwnd10mOper ),intent(in):: self + class(uwnd10moper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_uwnd10mOper +end module gsi_uwnd10moper diff --git a/src/gsi/gsi_visOper.F90 b/src/gsi/gsi_visoper.f90 similarity index 70% rename from src/gsi/gsi_visOper.F90 rename to src/gsi/gsi_visoper.f90 index d8cc41efd5..272959fc06 100644 --- a/src/gsi/gsi_visOper.F90 +++ b/src/gsi/gsi_visoper.f90 @@ -1,12 +1,12 @@ -module gsi_visOper +module gsi_visoper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_visOper +! subprogram: module gsi_visoper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for visNode type +! abstract: an oboper extension for visnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_visOper ! module interface: - use gsi_obOper, only: obOper - use m_visNode , only: visNode + use gsi_oboper, only: oboper + use m_visnode , only: visnode implicit none - public:: visOper ! data stracture + public:: visoper ! data stracture - type,extends(obOper):: visOper + type,extends(oboper):: visoper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type visOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type visoper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_visOper' - type(visNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_visoper' + type(visnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[visOper]" + mytype="[visoper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use vis_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(visOper ), intent(inout):: self + class(visoper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intvismod, only: intjo => intvis use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(visOper ),intent(in ):: self + class(visoper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpvismod, only: stpjo => stpvis use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(visOper ),intent(in):: self + class(visoper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_visOper +end module gsi_visoper diff --git a/src/gsi/gsi_vwnd10mOper.F90 b/src/gsi/gsi_vwnd10moper.f90 similarity index 69% rename from src/gsi/gsi_vwnd10mOper.F90 rename to src/gsi/gsi_vwnd10moper.f90 index 081d8c150d..f9d1a2e581 100644 --- a/src/gsi/gsi_vwnd10mOper.F90 +++ b/src/gsi/gsi_vwnd10moper.f90 @@ -1,12 +1,12 @@ -module gsi_vwnd10mOper +module gsi_vwnd10moper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_vwnd10mOper +! subprogram: module gsi_vwnd10moper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for vwnd10mNode type +! abstract: an oboper extension for vwnd10mnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_vwnd10mOper ! module interface: - use gsi_obOper , only: obOper - use m_vwnd10mNode, only: vwnd10mNode + use gsi_oboper , only: oboper + use m_vwnd10mnode, only: vwnd10mnode implicit none - public:: vwnd10mOper ! data stracture + public:: vwnd10moper ! data stracture - type,extends(obOper):: vwnd10mOper + type,extends(oboper):: vwnd10moper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type vwnd10mOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type vwnd10moper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_vwnd10mOper' - type(vwnd10mNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_vwnd10moper' + type(vwnd10mnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[vwnd10mOper]" + mytype="[vwnd10moper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use vwnd10m_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(vwnd10mOper ), intent(inout):: self + class(vwnd10moper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intvwnd10mmod, only: intjo => intvwnd10m use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(vwnd10mOper ),intent(in ):: self + class(vwnd10moper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpvwnd10mmod, only: stpjo => stpvwnd10m use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(vwnd10mOper ),intent(in):: self + class(vwnd10moper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_vwnd10mOper +end module gsi_vwnd10moper diff --git a/src/gsi/gsi_wOper.F90 b/src/gsi/gsi_woper.f90 similarity index 70% rename from src/gsi/gsi_wOper.F90 rename to src/gsi/gsi_woper.f90 index 0df699f828..e7187701a3 100644 --- a/src/gsi/gsi_wOper.F90 +++ b/src/gsi/gsi_woper.f90 @@ -1,12 +1,12 @@ -module gsi_wOper +module gsi_woper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_wOper +! subprogram: module gsi_woper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for wNode type +! abstract: an oboper extension for wnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_wOper ! module interface: - use gsi_obOper, only: obOper - use m_wNode , only: wNode + use gsi_oboper, only: oboper + use m_wnode , only: wnode implicit none - public:: wOper ! data stracture + public:: woper ! data stracture - type,extends(obOper):: wOper + type,extends(oboper):: woper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type wOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type woper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_wOper' - type(wNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_woper' + type(wnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[wOper]" + mytype="[woper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use w_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(wOper ), intent(inout):: self + class(woper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intwmod, only: intjo => intw use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(wOper ),intent(in ):: self + class(woper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpwmod, only: stpjo => stpw use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(wOper ),intent(in):: self + class(woper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_wOper +end module gsi_woper diff --git a/src/gsi/gsi_wspd10mOper.F90 b/src/gsi/gsi_wspd10moper.f90 similarity index 69% rename from src/gsi/gsi_wspd10mOper.F90 rename to src/gsi/gsi_wspd10moper.f90 index 0fbb19e5e2..d6d5156f8e 100644 --- a/src/gsi/gsi_wspd10mOper.F90 +++ b/src/gsi/gsi_wspd10moper.f90 @@ -1,12 +1,12 @@ -module gsi_wspd10mOper +module gsi_wspd10moper !$$$ subprogram documentation block ! . . . . -! subprogram: module gsi_wspd10mOper +! subprogram: module gsi_wspd10moper ! prgmmr: j guo ! org: NASA/GSFC, Global Modeling and Assimilation Office, 610.3 ! date: 2018-08-10 ! -! abstract: an obOper extension for wspd10mNode type +! abstract: an oboper extension for wspd10mnode type ! ! program history log: ! 2018-08-10 j guo - added this document block @@ -23,48 +23,48 @@ module gsi_wspd10mOper ! module interface: - use gsi_obOper , only: obOper - use m_wspd10mNode, only: wspd10mNode + use gsi_oboper , only: oboper + use m_wspd10mnode, only: wspd10mnode implicit none - public:: wspd10mOper ! data stracture + public:: wspd10moper ! data stracture - type,extends(obOper):: wspd10mOper + type,extends(oboper):: wspd10moper contains - procedure,nopass:: mytype - procedure,nopass:: nodeMold - procedure:: setup_ - procedure:: intjo1_ - procedure:: stpjo1_ - end type wspd10mOper + procedure,nopass:: mytype + procedure,nopass:: nodemold + procedure:: setup_ + procedure:: intjo1_ + procedure:: stpjo1_ + end type wspd10moper !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - character(len=*),parameter :: myname='gsi_wspd10mOper' - type(wspd10mNode),save,target:: myNodeMold_ + character(len=*),parameter :: myname='gsi_wspd10moper' + type(wspd10mnode),save,target:: mynodemold_ contains function mytype(nodetype) implicit none character(len=:),allocatable:: mytype logical,optional, intent(in):: nodetype - mytype="[wspd10mOper]" + mytype="[wspd10moper]" if(present(nodetype)) then - if(nodetype) mytype=myNodeMold_%mytype() + if(nodetype) mytype=mynodemold_%mytype() endif end function mytype - function nodeMold() - !> %nodeMold() returns a mold of its corresponding obsNode - use m_obsNode, only: obsNode + function nodemold() + !> %nodemold() returns a mold of its corresponding obsnode + use m_obsnode, only: obsnode implicit none - class(obsNode),pointer:: nodeMold - nodeMold => myNodeMold_ - end function nodeMold + class(obsnode),pointer:: nodemold + nodemold => mynodemold_ + end function nodemold subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use wspd10m_setup, only: setup use kinds, only: i_kind - use gsi_obOper, only: len_obstype - use gsi_obOper, only: len_isis + use gsi_oboper, only: len_obstype + use gsi_oboper, only: len_isis use m_rhs , only: awork => rhs_awork use m_rhs , only: bwork => rhs_bwork @@ -76,7 +76,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) use mpeu_util, only: die implicit none - class(wspd10mOper ), intent(inout):: self + class(wspd10moper ), intent(inout):: self integer(i_kind), intent(in):: lunin integer(i_kind), intent(in):: mype integer(i_kind), intent(in):: is @@ -100,7 +100,7 @@ subroutine setup_(self, lunin, mype, is, nobs, init_pass,last_pass) diagsave = write_diag(jiter) .and. diag_conv - call setup(self%obsLL(:), self%odiagLL(:), & + call setup(self%obsll(:), self%odiagll(:), & lunin,mype,bwork,awork(:,iwork),nele,nobs,is,diagsave) end subroutine setup_ @@ -109,11 +109,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) use intwspd10mmod, only: intjo => intwspd10m use gsi_bundlemod , only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds , only: i_kind, r_quad implicit none - class(wspd10mOper ),intent(in ):: self + class(wspd10moper ),intent(in ):: self integer(i_kind ),intent(in ):: ibin type(gsi_bundle),intent(inout):: rval ! (ibin) type(gsi_bundle),intent(in ):: sval ! (ibin) @@ -122,11 +122,11 @@ subroutine intjo1_(self, ibin, rval,sval, qpred,sbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::intjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call intjo(headNode, rval,sval) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call intjo(headnode, rval,sval) + headnode => null() end subroutine intjo1_ @@ -134,11 +134,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) use stpwspd10mmod, only: stpjo => stpwspd10m use gsi_bundlemod, only: gsi_bundle use bias_predictors, only: predictors - use m_obsNode , only: obsNode - use m_obsLList, only: obsLList_headNode + use m_obsnode , only: obsnode + use m_obsllist, only: obsllist_headnode use kinds, only: r_quad,r_kind,i_kind implicit none - class(wspd10mOper ),intent(in):: self + class(wspd10moper ),intent(in):: self integer(i_kind ),intent(in):: ibin type(gsi_bundle),intent(in):: dval type(gsi_bundle),intent(in):: xval @@ -151,11 +151,11 @@ subroutine stpjo1_(self, ibin, dval,xval,pbcjo,sges,nstep,dbias,xbias) !---------------------------------------- character(len=*),parameter:: myname_=myname//"::stpjo1_" - class(obsNode),pointer:: headNode + class(obsnode),pointer:: headnode - headNode => obsLList_headNode(self%obsLL(ibin)) - call stpjo(headNode,dval,xval,pbcjo(:),sges,nstep) - headNode => null() + headnode => obsllist_headnode(self%obsll(ibin)) + call stpjo(headnode,dval,xval,pbcjo(:),sges,nstep) + headnode => null() end subroutine stpjo1_ -end module gsi_wspd10mOper +end module gsi_wspd10moper diff --git a/src/gsi/gsimain.f90 b/src/gsi/gsimain.f90 index 5eaa38286a..08ef39dfa4 100644 --- a/src/gsi/gsimain.f90 +++ b/src/gsi/gsimain.f90 @@ -3,7 +3,7 @@ !------------------------------------------------------------------------- !BOP -! ! IPROGRAM: gsimain -- runs NCEP gsi +! ! PROGRAM: gsimain -- runs ncep gsi ! ! INTERFACE: @@ -22,16 +22,16 @@ program gsi !$$$ main program documentation block ! . . . . -! main program: GSI_ANL -! PRGMMR: DERBER ORG: NP23 DATE: 1999-08-20 +! main program: gsi_anl +! prgmmr: derber org: NP23 date: 1999-08-20 ! -! abstract: The gridpoint statistical interpolation (GSI) analysis code +! abstract: The gridpoint statistical interpolation (gsi) analysis code ! performs an atmospheric analysis over a specified domain (global ! or regional) in which guess fields from a forecast model are combined -! with available observations using a 3D-VAR approach. +! with available observations using a 3d-var approach. ! ! program history log: -! 1991-xx-xx parrish/derber initial SSI code +! 1991-xx-xx parrish/derber initial ssi code ! 1991-12-10 parrish/derber fixed coding error in near sfc anal ! 1992-09-14 derber improved version of global ssi analysis ! 1998-05-15 weiyu yang mpp version of global ssi @@ -48,7 +48,7 @@ program gsi ! 2004-11-10 treadon - add comments for error codes; initialize variables ! wrf_anl_filename and wrf_ges_filename ! 2004-11-29 parrish - remove code to handle regional binary update -! 2004-12-08 xu li - add logical variable retrieval for SST physical retrieval +! 2004-12-08 xu li - add logical variable retrieval for sst physical retrieval ! algorithm ! 2004-12-15 treadon - update documentation; simplify regional ges & anl i/o ! 2004-12-22 treadon - rename diagnostic output logical flags; add logical @@ -63,7 +63,7 @@ program gsi ! 2005-03-07 dee - add logical gmao_intfc for gmao model interface! ! 2005-04-08 treadon - add call set_nlnqc_flags ! 2005-05-24 pondeca - add 2dvar only surface analysis option -! 2005-05-27 yanqiu - added obs_sen to control GSI's TLM +! 2005-05-27 yanqiu - added obs_sen to control gsi's tlm ! 2005-05-27 kleist/derber - add option to read in new ob error table ! 2005-05-27 kleist/parrish - add option to use new patch interpolation ! if (norsp==0) will default to polar cascade @@ -71,7 +71,7 @@ program gsi ! 2005-06-06 wu - add namelist variable fstat, logical to seperate f ! from balance projection ! 2005-07-06 parrish - add/initialize logical variable update_pint -! 2005-07-10 kleist - add options for Jc term +! 2005-07-10 kleist - add options for jc term ! 2005-08-01 parrish,lee - add changes to include new surface temperature ! forward model ! 2005-08-03 derber - remove gross and variational qc conventional @@ -79,13 +79,13 @@ program gsi ! 2005-03-24 derber - remove call set_nlnqc_flags ! 2005-09-08 derber - modify to use input group time window clean up unused variables ! 2005-09-28 parrish - modify namelist parameters for radar wind superobs -! 2005-09-29 kleist - expanded namelist for Jc option +! 2005-09-29 kleist - expanded namelist for jc option ! 2005-10-17 parrish - add ctph0,stph0,tlm0 to call convert_regional_guess -! 2005-10-18 treadon - remove dload from OBS_INPUT namelist +! 2005-10-18 treadon - remove dload from obs_input namelist ! 2005-11-09 wu - turn off limq when using qoption=2 ! 2005-11-21 kleist - use tendency module, force flags to true if necessary -! 2005-11-22 wu - add perturb_conv and pfact to SETUP namelist -! 2005-12-01 cucurull - update information to include GPS bending angle code +! 2005-11-22 wu - add perturb_conv and pfact to setup namelist +! 2005-12-01 cucurull - update information to include gps bending angle code ! 2005-12-20 parrish - add parameter sfcmodel for option to select boundary layer ! forward model for surface temperature observations ! 2006-01-10 treadon - move deallocate array calls from gsisub to gsimain @@ -95,20 +95,20 @@ program gsi ! 2006-03-21 treadon - modify optional perturbation to observation ! 2006-04-06 middlecoff - added three exit states ! 2006-04-19 treadon - add logical switch dtbduv_on to namelist setup -! 2006-04-20 wu - check OBS_INPUT time_window against obsmod default +! 2006-04-20 wu - check obs_input time_window against obsmod default ! 2006-04-20 kistler - added init_conv for conv ob bias correction ! 2006-04-21 parrish - modifications for new treatment of level 2 radar winds -! 2006-04-21 kleist - Jc namelist generalized +! 2006-04-21 kleist - jc namelist generalized ! 2006-05-22 su - add noiqc flag ! 2006-07-28 derber - add dfact1 namelist parameter, remove jppf -! 2006-08-15 parrish - add namelist STRONGOPTS for new strong constraint option +! 2006-08-15 parrish - add namelist strongopts for new strong constraint option ! 2006-08-30 zhang,b - add diurnal cycle bias correction capability ! 2006-09-29 treadon - add ifact10 logic, allow limq with qoption=2 ! 2006-10-12 treadon - set tendsflag and switch_on_derivatives for pcp data ! 2006-10-25 sienkiewicz - add blacklist flag to namelist ! 2006-11-30 todling - add fpsproj parameter to bkgerr namelist ! 2007-03-12 su - add perturb_obs,perturb_fact,c_varqc -! 2007-04-10 todling - split following C.Cruz and da Silva's modification to ESMF +! 2007-04-10 todling - split following c.cruz and da silva's modification to esmf ! 2007-04-13 tremolet - add error code 100 ! 2007-06-08 kleist/treadon - add init_directories ! 2007-06-20 rancic/derber - add pbl option @@ -117,7 +117,7 @@ program gsi ! 2007-10-24 parrish - add l2superob_only option ! 2008-03-24 wu - add oberror tuning option ! 2008-05-20 Guo, J. - removed obsolete gmao_rtm control -! - removed diurnal bias correction implmented by Zhang, B. +! - removed diurnal bias correction implmented by zhang, b. ! 2010-03-18 treadon - add comment for return code 330 ! 2010-04-26 kistler - add comment for return code 331 ! 2010-05-27 todling - error codes 127-130 no longer apply (slots emptied) @@ -128,8 +128,8 @@ program gsi ! 2013-07-02 parrish - remove error message 328 - tlnmc_type > 2 not allowed ! 2018-02-15 wu - add fv3_regional ! 2017-11-29 apodaca - add information, source codes, and exit states -! related to the GOES/GLM lightnig assimilation -! 2019-07-09 todling - add initialization of abstract layer defining use of GFS ensemble +! related to the goes/glm lightnig assimilation +! 2019-07-09 todling - add initialization of abstract layer defining use of gfs ensemble ! 2019-08-04 guo - moved ensemble object configuration into module gsi_fixture. ! ! usage: @@ -138,7 +138,7 @@ program gsi ! input observation data file names are specified in namelist obs_input ! ************************** ! berror_stats - background error statistics -! emissivity_coefficients - IR surface emissivity coefficient file +! emissivity_coefficients - ir surface emissivity coefficient file ! ozinfo - ozone observation information file ! pcpinfo - precipitation rate observation info file ! satbias_angle - satellite angle dependent file @@ -208,30 +208,30 @@ program gsi ! wrf_netcdf_interface, write_all, wrsfca, wrsiga, wrwrfmassa, wrwrfnmma, ! ! modules: -! From GSI: +! from gsi: ! berror, constants, gridmod, guess_grids, jfunc, kinds, mpimod, obsmod, ! oneobmod, ozinfo, pcpinfo, qcmod, radinfo, satthin, specmod ! -! From Community Radiative Transfer Model (CRTM)): +! from community radiative transfer model (crtm)): ! error_handler, initialize, k_matrix_model, spectral_coefficients ! -! From InfraRed Sea-Surface Emissivity (IRSSE) model: +! From infrared sea-surface emissivity (irsse) model: ! irsse_model ! ! ! -! libraries (for NCEP ibm): -! w3_d - NCEP W3 library -! bufr_d_64 - 64 bit NCEP BUFR library -! sp_d - NCEP spectral-grid transform library -! bacio_4 - byte addressable I/O library -! sigio - NCEP GFS sigma file I/O library -! sfcio - NCEP GFS surface file I/O library -! CRTM - Community Radiative Transfer Model -! ESSL - fast scientific calculation subroutines -! MASS - fast intrinsic function replacements -! NETCDF - the netcdf library -! WRF - the WRF library +! libraries (for ncep ibm): +! w3_d - ncep w3 library +! bufr_d_64 - 64 bit ncep bufr library +! sp_d - ncep spectral-grid transform library +! bacio_4 - byte addressable i/o library +! sigio - ncep gfs sigma file i/o library +! sfcio - ncep gfs surface file i/o library +! crtm - community radiative transfer model +! essl - fast scientific calculation subroutines +! mass - fast intrinsic function replacements +! netcdf - the netcdf library +! wrf - the wrf library ! ! exit states: ! cond = 0 - successful run @@ -239,27 +239,27 @@ program gsi ! = 31 - extrapolation error (interp_a2e) ! = 32 - failure in sort routine (indexx, in satthin) ! = 33 - error in coarse --> fine grid interolation operator (get_3ops) -! = 35 - model top pressure above RTM top pressure (add_layers_rtm) -! = 36 - total number of model layers > RTM layers +! = 35 - model top pressure above rtm top pressure (add_layers_rtm) +! = 36 - total number of model layers > rtm layers ! = 41 - illegal min,max horizontal scale (prewgt) ! = 44 - illegal surface emissivity type(emiss) -! = 45 - IR surface emissivity failure (emiss) +! = 45 - ir surface emissivity failure (emiss) ! = 48 - allocation or i/o error (convinfo) ! = 49 - error in call rdmemm (read_prepbufr) ! = 50 - ndata > maxobs (read_prepbufr) ! = 51 - invalid pflag (convthin:make3grids) ! = 54 - data handling mix up(setuprhsall) -! = 55 - NOBS > NSDATA (setuprhsall-tran) +! = 55 - nobs > nsdata (setuprhsall-tran) ! = 56 - iobs > maxobs (read_amsr2) ! = 59 - problems reading sst analysis (rdgrbsst) ! = 60 - inconsistent dimensions (rdgrbsst) ! = 61 - odd number of longitudes (inisph) ! = 62 - latitude not between +/- pi (inisph) -! = 63 - error in LUD matrix dcomposition (inisph) +! = 63 - error in lud matrix dcomposition (inisph) ! = 64 - singular matrix (inisph) -! = 65 - vanishing row in L-D-U decomposition (ldum) -! = 66 - singular matrix in L-D-U decomposition (ldum) -! = 67 - matrix too large in L-D-U decomposition (ldum) +! = 65 - vanishing row in l-d-u decomposition (ldum) +! = 66 - singular matrix in l-d-u decomposition (ldum) +! = 67 - matrix too large in l-d-u decomposition (ldum) ! = 68 - raflib error (raflib, raflib_8) ! = 69 - imaginary root to large (rfdpar1) ! = 70 - error setting up assimilation time window @@ -292,9 +292,9 @@ program gsi ! = 101 - prebal: inconsistent msig,nsig ! = 102 - allocate_preds: vector already allocated ! = 103 - allocate_preds: error length -! = 104 - control2model: assumes sqrt(B) but not specified +! = 104 - control2model: assumes sqrt(b) but not specified ! = 105 - control2model: error 3dvar -! = 106 - control2state: not used for sqrt(B), but called +! = 106 - control2state: not used for sqrt(b), but called ! = 107 - control2state: error 3dvar ! = 108 - allocate_cv: vector already allocated ! = 109 - allocate_mods: error length @@ -305,7 +305,7 @@ program gsi ! = 114 - qdot_prod_cv: error length ! = 115 - axpy: error length ! = 116 - read_cv: wrong length -! = 117 - maxval_cv: MPI error +! = 117 - maxval_cv: mpi error ! = 118 - qdot_product: inconsistent dims. ! = 119 - set_cvsection: kbgn out of range ! = 120 - set_cvsection: kend out of range @@ -320,8 +320,8 @@ program gsi ! = 129 - ! = 130 - ! = 131 - grtest: pdx too small -! = 132 - gsi_4dvar: Error in observation binning -! = 133 - gsi_4dvar: Error in sub-windows definition +! = 132 - gsi_4dvar: error in observation binning +! = 133 - gsi_4dvar: error in sub-windows definition ! = 134 - setup_4dvar: unable to fullfil request for increment output ! = 135 - setup_4dvar: iwrtinc or lwrite4danl inconsistent ! = 136 - time_4dvar: minutes should be 0 @@ -331,9 +331,9 @@ program gsi ! = 140 - setup_precond: no vectors for preconditioner ! = 141 - read_lanczos: kamxit>maxiter ! = 142 - read_lanczos: kiter>maxiter -! = 143 - m_stats: MPI_allreduce(dot-sum) -! = 144 - m_stats: MPI_allreduce(min-max) -! = 145 - m_stats: MPI_allreduce(dim) +! = 143 - m_stats: mpi_allreduce(dot-sum) +! = 144 - m_stats: mpi_allreduce(min-max) +! = 145 - m_stats: mpi_allreduce(dim) ! = 146 - control2model_ad: assumes lsqrtb ! = 147 - model_tl: error nstep ! = 148 - model_tl: error nfrctl @@ -342,12 +342,12 @@ program gsi ! = 151 - model_tl: error xini ! = 152 - model_tl: error xobs ! = 153 - mpl_allgatherq: troubled jdim/npe -! = 154 - mpl_bcast: MPI error +! = 154 - mpl_bcast: mpi error ! = 155 - init_fc_sens: unknown method ! = 156 - save_fc_sens: obscounts not allocated ! = 157 - observer: observer should only be called in 4dvar ! = 158 - lbfgs: maxvecs is not positive. -! = 159 - lbfgs: GTOL is smaller than 1.0e-4 +! = 159 - lbfgs: gtol is smaller than 1.0e-4 ! = 160 - lbfgs: line search failed ! = 161 - mcsrch: error input ! = 162 - mcsrch: the search direction is not a descent direction @@ -505,14 +505,14 @@ program gsi ! = 317 - bkerror: not for use with lsqrtb ! = 318 - init_jcdfi: Sum of weights is not 1 ! = 319 - steqr: r_kind is neither default real nor double precision -! = 320 - steqr: SSTEQR/DSTEQR returned non-zero info +! = 320 - steqr: ssteqr/dsteqr returned non-zero info ! = 321 - ptsv: r_kind is neither default real nor double precision -! = 322 - ptsv: SPTSV/DPTSV returned non-zero info +! = 322 - ptsv: sptsv/dptsv returned non-zero info ! = 323 - save_precond: r_kind is neither default real nor double precision -! = 324 - save_precond: error computing Cholesky decomposition +! = 324 - save_precond: error computing cholesky decomposition ! = 325 - setup_precond: r_kind is neither default real nor double precision -! = 326 - setup_precond: SSYEV/DSYEV returned non-zero return code -! = 327 - PRECOND: invalid value for kmat +! = 326 - setup_precond: ssyev/dsyev returned non-zero return code +! = 327 - precond: invalid value for kmat ! = 328 - ! = 329 - problem with logicals or collective obs selection info file ! = 330 - grid --> spectral transform not safe for sptranf_s,v_b @@ -523,8 +523,8 @@ program gsi ! = 335 - error reading radiance diagnostic file ! = 336 - invalid namlist setting for nhsrf ! = 337 - inconsitent tlnmc namelist settings -! = 338 - error reading MLS vertical levels from MLS bufr -! = 339 - error:more than one MLS data type not allowed +! = 338 - error reading mls vertical levels from mls bufr +! = 339 - error:more than one mls data type not allowed ! = 340 - error reading aircraft temperature bias file ! = 341 - aircraft tail number exceeds maximum ! = 342 - setuplight: failure to allocate obsdiags @@ -542,11 +542,11 @@ program gsi ! !$$$ -! NOTE: PARAMETERS RELATED TO GLOBAL/REGIONAL ANALYSIS: +! Note: parameters related to global/regional analysis: ! This program has been adapted for use for global or regional analysis. -! Originally, only one regional model was allowed for, the WRF version of -! the NCEP non-hydrostatic mesoscale model (WRF NMM). This model uses a +! Originally, only one regional model was allowed for, the wrf version of +! the ncep non-hydrostatic mesoscale model (wrf nmm). This model uses a ! rotated lat-lon coordinate so it was relatively easy to adapt the global ! code to this rotated grid. However, to run with other regional models ! with different map definitions, it would be necessary to make special @@ -562,8 +562,8 @@ program gsi ! ! The analysis does not currently work with staggered grids, so some ! interpolation in the horizontal is required for regional models with -! grid staggering. The WRF NMM uses an E-grid, and there are 2 interpolation -! options, one which fills the holes in the E-grid for more accurate, but +! grid staggering. The wrf nmm uses an e-grid, and there are 2 interpolation +! options, one which fills the holes in the e-grid for more accurate, but ! much more expensive option, and the other which takes every other row of ! the E grid, which has no interpolation for mass variables, but winds must ! be interpolated. To minimize the impact of interpolation errors, only @@ -574,37 +574,37 @@ program gsi ! ! There are currently two regional models accepted by the analysis: -! wrf_nmm_regional = .true. input is from WRF NMM (NCEP model) -! wrf_mass_regional = .true. input is from WRF MASS-CORE (NCAR model) +! wrf_nmm_regional = .true. input is from wrf nmm (ncep model) +! wrf_mass_regional = .true. input is from wrf mass-core (ncar model) ! ! new regional model added: ! -! nems_nmmb_regional = .true. input is from NEMS NMMB model +! nems_nmmb_regional = .true. input is from nems nmmb model ! fv3_regional = .true. input is from fv3 model -! cmaq_regional = .true. input is from CMAQ model +! cmaq_regional = .true. input is from cmaq model ! ! For a regional run, several additional namelist parameters must be specified: ! ! diagnostic_reg -- if .true., then run diagnostic tests for debugging ! update_regsfc -- if .true., then write updated surface fields to analysis file -! nhr_assimilation -- assimilation interval in hours, =3 for current NMM assimilation +! nhr_assimilation -- assimilation interval in hours, =3 for current nmm assimilation ! nhr_offset -- time of analysis in assimilation window (hours) ! (following only needed for wrf_nmm_regional =.true. -! filled_grid -- if .true. fill in points on WRF NMM E-grid (expensive, but most accurate) -! half_grid -- if .true. use every other row of WRF NMM E-grid +! filled_grid -- if .true. fill in points on wrf nmm e-grid (expensive, but most accurate) +! half_grid -- if .true. use every other row of wrf nmm e-grid ! ! Additional notes: ! ! ! 1. For regional runs, there are specialized routines at the beginning and end of the -! analysis for I/O. Currently the options are for the WRF NMM and the WRF mass core. +! analysis for i/o. Currently the options are for the wrf nmm and the wrf mass core. ! -! 2. WRF restart files can now be directly read into GSI. There are currently 4 options, -! a) WRF NMM binary format -! b) WRF NMM netcdf format -! c) WRF MC binary format -! d) WRF MC netcdf format -! To simplify the initial introduction of direct connection to WRF files, interface +! 2. wrf restart files can now be directly read into gsi. There are currently 4 options, +! a) wrf nmm binary format +! b) wrf nmm netcdf format +! c) wrf mc binary format +! d) wrf mc netcdf format +! To simplify the initial introduction of direct connection to wrf files, interface ! routines are called at the beginning and end of gsimain, creating an intermediate ! binary file which the code currently expects. However this is now invisible ! to the user. @@ -620,9 +620,9 @@ program gsi call my_fixture_config() ! Choose configurable extensions for a ! particular system fixture. Note a user ! defined gsi_fixture implementation is uniquely - ! selected in CMakeLists.txt at build-time. + ! selected in cmakelists.txt at build-time. -! Initialize atmospheric AD and TL model trajectory +! Initialize atmospheric ad and tl model trajectory ! if(l4dvar) then ! call gsi_4dcoupler_init_traj(idmodel,rc=ier) ! if(ier/=0) call die(myname,'gsi_4dcoupler_init_traj(), rc =',ier) @@ -630,7 +630,7 @@ program gsi call gsimain_run(init_pass=.true.,last_pass=.true.) -! Finalize atmospheric AD and TL model trajectory +! Finalize atmospheric ad and tl model trajectory if(l4dvar) then call gsi_4dcoupler_final_traj(rc=ier) if(ier/=0) call die(myname,'gsi_4dcoupler_final_traj(), rc =',ier) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index d13c2e733c..76dc1f1586 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -20,7 +20,7 @@ module gsimod blacklst,init_obsmod_vars,lobsdiagsave,lobskeep,lobserver,hilbert_curve,& lread_obs_save,lread_obs_skip,time_window_rad, & neutral_stability_windfact_2dvar,use_similarity_2dvar - use gsi_dbzOper, only: diag_radardbz + use gsi_dbzoper, only: diag_radardbz use obsmod, only: doradaroneob,oneoblat,oneoblon,oneobheight,oneobvalue,oneobddiff,oneobradid,& radar_no_thinning,ens_hx_dbz_cut,static_gsi_nopcp_dbz,rmesh_dbz,& @@ -39,11 +39,10 @@ module gsimod ! The following variables are the coefficients that describe ! the linear regression fits that are used to define the - ! dynamic observation error (DOE) specifications for all + ! dynamic observation error (doe) specifications for all ! reconnissance observations collected within ! hurricanes/tropical cyclones; these apply only to the - ! regional forecast models (e.g., HWRF); Henry R. Winterbottom - ! (henry.winterbottom@noaa.gov). + ! regional forecast models (e.g., hwrf) q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & @@ -59,9 +58,9 @@ module gsimod l4dvar,nhr_obsbin,nhr_subwin,nwrvecs,iorthomax,& lbicg,lsqrtb,lcongrad,lbfgsmin,ltlint,ladtest,ladtest_obs, lgrtest,& idmodel,clean_4dvar,iwrtinc,lanczosave,jsiga,ltcost,liauon, & - l4densvar,ens_nstarthr,lnested_loops,lwrite4danl,nhr_anal,thin4d,tau_fcst,efsoi_order - use gsi_4dvar, only: mPEs_observer - use m_obsdiags, only: alwaysLocal => obsdiags_alwaysLocal + l4densvar,ens_nstarthr,lnested_loops,lwrite4danl,nhr_anal,thin4d,tau_fcst,efsoi_order + use gsi_4dvar, only: mpes_observer + use m_obsdiags, only: alwayslocal => obsdiags_alwayslocal use obs_ferrscale, only: lferrscale use mpimod, only: npe,mpi_comm_world,ierror,mype use radinfo, only: retrieval,diag_rad,init_rad,init_rad_vars,adp_anglebc,angord,upd_pred,& @@ -94,7 +93,7 @@ module gsimod use jfunc, only: iout_iter,iguess,miter,factqmin,factqmax, & factql,factqi,factqr,factqs,factqg, & factv,factl,factp,factg,factw10m,facthowv,factcldch,niter,niter_no_qc,biascor,& - init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,R_option,& + init_jfunc,qoption,cwoption,switch_on_derivatives,tendsflag,jiterstart,jiterend,r_option,& bcoption,diurnalbc,print_diag_pcg,tsensible,lgschmidt,diag_precon,step_start,pseudo_q2,& clip_supersaturation,cnvw_option use state_vectors, only: init_anasv,final_anasv @@ -134,7 +133,7 @@ module gsimod range_max,elev_angle_max,initialize_superob_radar,l2superob_only use m_berror_stats,only : berror_stats ! filename if other than "berror_stats" use lag_fields,only : infile_lag,lag_nmax_bal,& - &lag_vorcore_stderr_a,lag_vorcore_stderr_b,lag_modini + lag_vorcore_stderr_a,lag_vorcore_stderr_b,lag_modini use lag_interp,only : lag_accur use lag_traj,only : lag_stepduration use hybrid_ensemble_parameters,only : l_hyb_ens,uv_hyb_ens,aniso_a_en,generate_ens,& @@ -144,7 +143,7 @@ module gsimod beta_s0,s_ens_h,s_ens_v,init_hybrid_ensemble_parameters,& readin_localization,write_ens_sprd,eqspace_ensgrid,grid_ratio_ens,& readin_beta,use_localization_grid,use_gfs_ens,q_hyb_ens,i_en_perts_io, & - l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB + l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticb use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& metar_impact_radius_lowcloud,l_gsd_terrain_match_surftobs, & @@ -156,12 +155,12 @@ module gsimod i_conserve_thetav_iternum,l_gsd_soiltq_nudge,l_cld_bld, cld_bld_hgt, & build_cloud_frac_p, clear_cloud_frac_p, & l_hydrometeor_bkio,nesdis_npts_rad, & - iclean_hydro_withRef,iclean_hydro_withRef_allcol, & + iclean_hydro_withref,iclean_hydro_withref_allcol, & i_use_2mq4b,i_use_2mt4b,i_gsdcldanal_type,i_gsdsfc_uselist, & i_lightpcp,i_sfct_gross,l_use_hydroretrieval_all,l_numconc,l_closeobs,& i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& cld_bld_coverage,cld_clr_coverage,& - i_cloud_q_innovation,i_ens_mean,DTsTmax + i_cloud_q_innovation,i_ens_mean,dtstmax use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax @@ -194,25 +193,25 @@ module gsimod public gsimain_finalize ! -! !DESCRIPTION: This module contains code originally in the GSI main program. +! !DESCRIPTION: This module contains code originally in the gsi main program. ! The main ! program has been split in initialize/run/finalize segments, and ! subroutines ! created for these steps: gsimain_initialize(), gsimain_run() and ! gsimain_finalize(). -! In non-ESMF mode (see below) a main program is assembled by calling these 3 +! In non-esmf mode (see below) a main program is assembled by calling these 3 ! routines in ! sequence. -! This file can be compiled in 2 different modes: an ESMF and a non-ESMF mode. +! This file can be compiled in 2 different modes: an esmf and a non-esmf mode. ! When HAVE_ESMF -! is defined (ESMF mode), a few I/O related statements are skipped during +! is defined (esmf mode), a few i/o related statements are skipped during ! initialize() and -! a main program is not provided. These is no dependency on the ESMF in this +! a main program is not provided. These is no dependency on the esmf in this ! file and in the -! routines called from here. The ESMF interface is implemented in -! GSI_GridCompMod which in +! routines called from here. The esmf interface is implemented in +! gsi_gridcompmod which in ! turn calls the initialize/run/finalize routines defined here. ! ! !REVISION HISTORY: @@ -222,13 +221,13 @@ module gsimod ! 10Apr2007 Todling Created from gsimain ! 13Jan2007 Tremolet Updated interface to setup_4dvar ! 03Oct2007 Todling Add lobserver -! 03Oct2007 Tremolet Add DFI and lanczos-save +! 03Oct2007 Tremolet Add dfi and lanczos-save ! 04Jan2008 Tremolet Add forecast sensitivity to observations options -! 10Sep2008 Guo Add CRTM files directory path -! 02Dec2008 Todling Remove reference to old TLM of analysis -! 20Nov2008 Todling Add lferrscale to scale OMF w/ Rinv (actual fcst not guess) +! 10Sep2008 Guo Add crtm files directory path +! 02Dec2008 Todling Remove reference to old tlm of analysis +! 20Nov2008 Todling Add lferrscale to scale omf w/ rinv (actual fcst not guess) ! 08Dec2008 Todling Placed switch_on_derivatives,tendsflag in jcopts namelist -! 28Jan2009 Todling Remove original GMAO interface +! 28Jan2009 Todling Remove original gmao interface ! 06Mar2009 Meunier Add initialisation for lagrangian data ! 04-21-2009 Derber Ensure that ithin is positive if neg. set to zero ! 07-08-2009 Sato Update for anisotropic mode (global/ensemble based) @@ -243,15 +242,15 @@ module gsimod ! ensemble compared to analysis for case when ensemble and analysis resolution are ! the same. used for preliminary testing of dual resolution hybrid ensemble option. ! 02-25-2010 Zhu Remove berror_nvars -! 03-06-2010 Parrish add flag use_gfs_ozone to namelist SETUP--allows read of gfs ozone for regional runs -! 03-09-2010 Parrish add flag check_gfs_ozone_date to namelist SETUP--if true, date check gfs ozone -! 03-15-2010 Parrish add flag regional_ozone to namelist SETUP--if true, then turn on ozone in +! 03-06-2010 Parrish add flag use_gfs_ozone to namelist setup--allows read of gfs ozone for regional runs +! 03-09-2010 Parrish add flag check_gfs_ozone_date to namelist setup--if true, date check gfs ozone +! 03-15-2010 Parrish add flag regional_ozone to namelist setup--if true, then turn on ozone in ! regional analysis ! 03-17-2010 todling add knob for analysis error estimate (jsiga) ! 03-17-2010 Zhu Add nc3d and nvars in init_grid_vars interface ! 03-29-2010 hu add namelist variables for controling rapid refesh options ! including cloud analysis and surface enhancement -! add and read namelist for RR +! add and read namelist for rr ! 03-31-2010 Treadon replace init_spec, init_spec_vars, destroy_spec_vars with general_* routines ! 04-07-2010 Treadon write rapidrefresh_cldsurf settings to stdout ! 04-10-2010 Parrish add vlevs from gridmod, so can pass as argument to init_mpi_vars, which must @@ -270,20 +269,20 @@ module gsimod ! 08-10-2010 Wu add nvege_type to gridopts namelist ! 08-24-2010 hcHuang add diag_aero and init_aero for aerosol observations ! 08-26-2010 Cucurull add use_compress to setup namelist, add a call to gps_constants -! 09-06-2010 Todling add Errico-Ehrendorfer parameter for E-norm used in DFI -! 09-03-2010 Todling add opt to output true J-cost from within Lanczos (beware: expensive) +! 09-06-2010 Todling add errico-ehrendorfer parameter for e-norm used in dfi +! 09-03-2010 Todling add opt to output true j-cost from within lanczos (beware: expensive) ! 10-05-2010 Todling add lbicg option ! 09-02-2010 Zhu Add option use_edges for the usage of radiance data on scan edges -! 10-18-2010 hcHuang Add option use_gfs_nemsio to read global model NEMS/GFS first guess +! 10-18-2010 hcHuang Add option use_gfs_nemsio to read global model nems/gfs first guess ! 11-17-2010 Pagowski add chemical species and related namelist ! 12-20-2010 Cucurull add nsig_ext to setup namelist for the usage of gpsro bending angle ! 01-05-2011 Cucurull add gpstop to setup namelist for the usage of gpsro data assimilation ! 04-08-2011 Li (1) add integer variable nst_gsi and nstinfo for the use of oceanic first guess -! (2) add integer variable fac_dtl & fac_tsl to control the use of NST model -! (3) add integer variable tzr_qc to control the Tzr QC -! (4) add integer tzr_bufrsave to control if save Tz retrieval or not +! (2) add integer variable fac_dtl & fac_tsl to control the use of nst model +! (3) add integer variable tzr_qc to control the tzr qc +! (4) add integer tzr_bufrsave to control if save tz retrieval or not ! 04-07-2011 todling move newpc4pred to radinfo -! 04-19-2011 El Akkraoui add iorthomax to control numb of vecs in orthogonalization for CG opts +! 04-19-2011 El Akkraoui add iorthomax to control numb of vecs in orthogonalization for cg opts ! 05-05-2011 mccarty removed references to repe_dw ! 05-21-2011 todling add call to setservice ! 06-01-2011 guo/zhang add liauon @@ -296,23 +295,23 @@ module gsimod ! 01-16-2012 m. tong add parameter pseudo_hybens to turn on pseudo ensemble hybrid ! 01-17-2012 wu add switches: gefs_in_regional,full_ensemble,pwgtflg ! 01-18-2012 parrish add integer parameter regional_ensemble_option to select ensemble source. -! =1: use GEFS internally interpolated to ensemble grid. -! =2: ensembles are WRF NMM format. -! =3: ensembles are ARW netcdf format. -! =4: ensembles are NEMS NMMB format. +! =1: use gefs internally interpolated to ensemble grid. +! =2: ensembles are wrf nmm format. +! =3: ensembles are arw netcdf format. +! =4: ensembles are nems nmmb format. ! 02-07-2012 tong remove parameter gefs_in_regional and reduce regional_ensemble_option to ! 4 options ! 02-08-2012 kleist add parameters to control new 4d-ensemble-var features. ! 02-17-2012 tong add parameter merge_two_grid_ensperts to merge ensemble perturbations ! from two forecast domains to analysis domain -! 05-25-2012 li/wang add TDR fore/aft sweep separation for thinning,xuguang.wang@ou.edu +! 05-25-2012 li/wang add tdr fore/aft sweep separation for thinning ! 06-12-2012 parrish remove calls to subroutines init_mpi_vars, destroy_mpi_vars. ! add calls to init_general_commvars, destroy_general_commvars. ! 10-11-2012 eliu add wrf_nmm_regional in determining logic for use_gfs_stratosphere ! 05-14-2012 wargan add adjustozvar to adjust ozone in stratosphere ! 05-14-2012 todling defense to set nstinfo only when nst_gsi>0 ! 05-23-2012 todling add lnested_loops option -! 09-10-2012 Gu add fut2ps to project unbalanced temp to surface pressure in static B modeling +! 09-10-2012 Gu add fut2ps to project unbalanced temp to surface pressure in static b modeling ! 12-05-2012 el akkraoui hybrid beta parameters now vertically varying ! 07-10-2012 sienkiewicz add ssmis_method control for noise reduction ! 02-19-2013 sienkiewicz add ssmis_precond for SSMIS bias coeff weighting @@ -339,10 +338,10 @@ module gsimod ! grid than mass background grid ! 12-10-2013 zhu add cwoption ! 02-05-2014 todling add parameter cwcoveqqcov (cw_cov=q_cov) -! 02-24-2014 sienkiewicz added aircraft_t_bc_ext for GMAO external aircraft temperature bias correction +! 02-24-2014 sienkiewicz added aircraft_t_bc_ext for gmao external aircraft temperature bias correction ! 05-29-2014 Thomas add lsingleradob logical for single radiance ob test ! (originally of mccarty) -! 06-19-2014 carley/zhu add factl and R_option for twodvar_regional lcbas/ceiling analysis +! 06-19-2014 carley/zhu add factl and r_option for twodvar_regional lcbas/ceiling analysis ! 08-05-2014 carley add safeguard so that oneobtest disables hilbert_curve if user accidentally sets hilbert_curve=.true. ! 10-04-2014 todling revised meanning of parameter bcoption ! 08-18-2014 tong add jcap_gfs to allow spectral transform to a coarser resolution grid, @@ -354,11 +353,11 @@ module gsimod ! 01-15-2015 Hu added options i_use_2mq4b,i_use_2mt4b, i_gsdcldanal_type ! i_gsdsfc_uselist,i_lightpcp,i_sfct_gross under ! rapidrefresh_cldsurf -! 02-09-2015 Sienkiewicz id_drifter flag - modify KX values for drifting buoys if set +! 02-09-2015 Sienkiewicz id_drifter flag - modify kx values for drifting buoys if set ! 02-29-2015 S.Liu added option l_use_hydroretrieval_all -! 03-01-2015 Li add zsea1 & zsea2 to namelist for vertical mean temperature based on NSST T-Profile +! 03-01-2015 Li add zsea1 & zsea2 to namelist for vertical mean temperature based on nsst t-Profile ! 05-02-2015 Parrish add option rtma_bkerr_sub2slab to allow dual resolution for application of -! anisotropic recursive filter (RTMA application only for now). +! anisotropic recursive filter (rtma application only for now). ! 05-13-2015 wu remove check to turn off regional 4densvar ! 01-13-2015 Ladwig added option l_numconc ! 09-01-2015 Hu added option l_closeobs @@ -370,75 +369,75 @@ module gsimod ! 03-10-2016 ejones add control for gmi noise reduction ! 03-25-2016 ejones add control for amsr2 noise reduction ! 04-18-2016 Yang add closest_obs for selecting obs. from multi-report at a surface observation. -! 06-24-2016 j. guo added alwaysLocal => m_obsdiags::obsdiags_alwaysLocal to -! namelist /SETUP/. +! 06-24-2016 j. guo added alwayslocal => m_obsdiags::obsdiags_alwayslocal to +! namelist /setup/. ! 08-12-2016 lippi added namelist parameters for single radial wind ! experiment (anaz_rw,anel_rw,range_rw,sstn,lsingleradar, ! singleradar,learthrel_rw). added a radar station look-up ! table. -! 08-12-2016 Mahajan NST stuff belongs in NST module, Adding a NST namelist +! 08-12-2016 Mahajan NST stuff belongs in nst module, Adding a nst namelist ! option ! 08-24-2016 lippi added nml option lnobalance to zero out all balance correlation ! matricies for univariate analysis. ! 08-28-2016 li - tic591: add use_readin_anl_sfcmask for consistent sfcmask ! between analysis grids and others ! 11-29-2016 shlyaeva add lobsdiag_forenkf option for writing out linearized -! H(x) for EnKF +! h(x) for enkf ! 12-14-2016 lippi added nml variable learthrel_rw for single radial -! wind observation test, and nml option for VAD QC +! wind observation test, and nml option for vad qc ! vadwnd_l2rw_qc of level 2 winds. ! 02-02-2017 Hu added option i_coastline to turn on the observation ! operator for surface observations along the coastline area ! 04-01-2017 Hu added option i_gsdqc to turn on special observation qc -! from GSD (for RAP/HRRR application) +! from gsd (for rap/hrrr application) ! 02-15-2016 Y. Wang, Johnson, X. Wang - added additional options if_vterminal, if_model_dbz, -! for radar DA, POC: xuguang.wang@ou.edu +! for radar da ! 08-31-2017 Li add sfcnst_comb for option to read sfc & nst combined file -! 10-10-2017 Wu,W added option fv3_regional and rid_ratio_fv3_regional, setup FV3, earthuv +! 10-10-2017 Wu,W added option fv3_regional and rid_ratio_fv3_regional, setup fv3, earthuv ! 01-11-2018 Yang add namelist variables required by the nonlinear transform to vis and cldch -! (Jim Purser 2018). Add estvisoe and estcldchoe to replace the hardwired +! (jim purser 2018). Add estvisoe and estcldchoe to replace the hardwired ! prescribed vis/cldch obs. errort in read_prepbufr. (tentatively?) ! 03-22-2018 Yang remove "logical closest_obs", previously applied to the analysis of vis and cldch. ! The option to use only the closest ob to the analysis time is now handled ! by Ming Hu's "logical l_closeobs" for all variables. -! 01-04-2018 Apodaca add diag_light and lightinfo for GOES/GLM lightning +! 01-04-2018 Apodaca add diag_light and lightinfo for goes/glm lightning ! data assimilation -! 08-16-2018 akella id_ship flag - modify KX values for ships if set +! 08-16-2018 akella id_ship flag - modify kx values for ships if set ! 08-25-2018 Collard Introduce bias_zero_start -! 03-29-2019 lei add integer parameter fv3sar_ensemble_opt to select the format of the FV3SAR ensembles +! 03-29-2019 lei add integer parameter fv3sar_ensemble_opt to select the format of the fv3sar ensembles ! =0; restart files -! =1; cold start IC files from CHGRES +! =1; cold start ic files from chgres ! 09-12-2018 Ladwig added option l_precip_clear_only ! 03-28-2019 Ladwig merging additional options for cloud product assimilation -! 03-11-2019 Collard Introduce ec_amv_qc as temporary control of GOES-16/17 AMVS +! 03-11-2019 Collard Introduce ec_amv_qc as temporary control of goes-16/17 amvs ! 03-14-2019 eliu add logic to turn on using full set of hydrometeors in ! obs operator and analysis ! 03-14-2019 eliu add precipitation component ! 05-09-2019 mtong move initializing derivative vector here ! 06-19-2019 Hu Add option reset_bad_radbc for reseting radiance bias correction when it is bad -! 06-25-2019 Hu Add option print_obs_para to turn on OBS_PARA list +! 06-25-2019 Hu Add option print_obs_para to turn on obs_para list ! 07-09-2019 Todling Introduce cld_det_dec2bin and diag_version -! 07-11-2019 Todling move vars imp_physics,lupp from CV to init_nems +! 07-11-2019 Todling move vars imp_physics,lupp from cv to init_nems ! 07-29-2019 pondeca add logical variable "neutral_stability_windfact_2dvar" that provides option to use a simple, ! similarity theory-based approach to compute the 10-m wind factor for ! near-surface observations -! 08-14-2019 W. Gu add lupdqc to replace the obs errors from satinfo with diag of est(R) -! 08-14-2019 W. Gu add lqcoef to combine the inflation coefficients generated by qc with est(R) +! 08-14-2019 W. Gu add lupdqc to replace the obs errors from satinfo with diag of est(r) +! 08-14-2019 W. Gu add lqcoef to combine the inflation coefficients generated by qc with est(r) ! 08-23-2019 pondeca add logical variable "use_similarity_2dvar" that provides option to use ! similarity theory from the mm5 sfc model to compute the 10-m wind factor for ! near-surface observations -! 09-04-2019 Martin Add option write_fv3_incr to write netCDF increment rather than NEMSIO analysis -! 09-13-2019 Martin Add option incvars_to_zero(nvars) to zero out netCDF increment fields -! 09-20-2019 Su add new variational QC and hub norm option -! 09-23-2019 Martin Add option use_gfs_ncio to read in first-guess netCDF file -! 10-15-2019 Wei/Martin added option lread_ext_aerosol to read in aerfXX file for NEMS aerosols; -! added option use_fv3_aero to choose between NGAC and FV3GFS-GSDChem +! 09-04-2019 Martin Add option write_fv3_incr to write netcdf increment rather than nemsion analysis +! 09-13-2019 Martin Add option incvars_to_zero(nvars) to zero out netcdf increment fields +! 09-20-2019 Su add new variational qc and hub norm option +! 09-23-2019 Martin Add option use_gfs_ncio to read in first-guess netcdf file +! 10-15-2019 Wei/Martin added option lread_ext_aerosol to read in aerfxx file for nems aerosols; +! added option use_fv3_aero to choose between ngac and fv3gfs-gsdchem ! 10-28-2019 Martin Add option incvars_zero_strat(nvars) to zero out increments above tropopause -! added option use_fv3_aero to choose between NGAC and FV3GFS-GSDChem +! added option use_fv3_aero to choose between ngac and fv3gfs-gsdchem ! 01-27-2020 Winterbottom Moved regression coeffcients for regional -! model (e.g., HWRF) aircraft recon dynamic -! observation error (DOE) specification to -! GSI namelist level (beneath obsmod.F90). +! model (e.g., hwrf) aircraft recon dynamic +! observation error (doe) specification to +! gsi namelist level (beneath obsmod.F90). ! !EOP !------------------------------------------------------------------------- @@ -453,7 +452,7 @@ module gsimod ! Namelists: setup,gridopts,jcopts,bkgerr,anbkgerr,obsqc,obs_input, ! singleob_test,superob_radar,emissjac,chem,nst ! -! SETUP (general control namelist) : +! setup (general control namelist) : ! ! gencode - source generation code ! factqmin - weighting factor for negative moisture constraint @@ -467,24 +466,24 @@ module gsimod ! niter() - number of inner interations for each outer iteration ! niter_no_qc() - number of inner interations without nonlinear qc for each outer iteration ! miter - number of outer iterations -! qoption - option of analysis variable; 1:q/qsatg-bkg 2:norm RH +! qoption - option of analysis variable; 1:q/qsatg-bkg 2:norm rh ! pseudo_q2- breed between q1/q2 options, that is, (q1/sig(q)) ! fstat - logical to seperate f from balance projection ! nhr_assimilation - assimilation time interval (currently 6hrs for global, 3hrs for reg) ! min_offset - time in minutes of analysis in assimilation window (default 3 hours) -! l4dvar - turn 4D-Var on/off (default=off=3D-Var) -! liauon - treat 4dvar CV as tendency perturbation (default=false) +! l4dvar - turn 4d-var on/off (default=off=3d-var) +! liauon - treat 4dvar cv as tendency perturbation (default=false) ! lnested_loops - allow for nested resolution outer/inner loops ! jsiga - calculate approximate analysis errors from lanczos for jiter=jsiga -! idmodel - uses identity model when running 4D-Var (test purposes) +! idmodel - uses identity model when running 4d-var (test purposes) ! iwrtinc - when >0, writes out increments from iwrtinc-index slot ! nhr_obsbin - length of observation bins -! nhr_subwin - length of weak constraint 4d-Var sub-window intervals +! nhr_subwin - length of weak constraint 4d-var sub-window intervals ! iout_iter- output file number for iteration information ! npredp - number of predictors for precipitation bias correction -! retrieval- logical to turn off or on the SST physical retrieval -! tzr_qc - indicator to control the Tzr_QC mode: 0 = no Tz retrieval; -! 1 = Do Tz retrieval and applied to QC +! retrieval- logical to turn off or on the sst physical retrieval +! tzr_qc - indicator to control the tzr_qc mode: 0 = no tz retrieval; +! 1 = do tz retrieval and applied to qc ! tzr_bufrsave - logical to turn off or on the bufr Tz retrieval file true=on ! diag_rad - logical to turn off or on the diagnostic radiance file true=on ! diag_conv-logical to turn off or on the diagnostic conventional file (true=on) @@ -496,21 +495,21 @@ module gsimod ! write_diag - logical to write out diagnostic files on outer iteration ! lobsdiagsave - write out additional observation diagnostics ! ltlint - linearize inner loop -! lobskeep - keep obs from first outer loop for subsequent OL +! lobskeep - keep obs from first outer loop for subsequent ol ! lobsensfc - compute forecast sensitivity to observations -! lobsensjb - compute Jb sensitivity to observations +! lobsensjb - compute jb sensitivity to observations ! lobsensincr - compute increment sensitivity to observations -! lobsensadj - use adjoint of approx. Hessian to compute obs sensitivity -! llancdone - use to tell adjoint that Lanczos vecs have been pre-computed +! lobsensadj - use adjoint of approx. hessian to compute obs sensitivity +! llancdone - use to tell adjoint that lanczos vecs have been pre-computed ! lsensrecompute - does adjoint by recomputing forward solution ! lobsensmin - use minimisation to compute obs sensitivity -! lbicg - use B-precond w/ bi-conjugate gradient for minimization +! lbicg - use b-precond w/ bi-conjugate gradient for minimization ! iobsconv - compute convergence test in observation space ! =1 at final point, =2 at every iteration ! lobserver - when .t., calculate departure vectors only ! lanczosave - save lanczos vectors for forecast sensitivity computation ! ltcost - calculate true cost when using Lanczos (this is very expensive) -! lferrscale - apply H^TR^{-1}H to a forecast error vector read on the fly +! lferrscale - apply h^tr^{-1}h to a forecast error vector read on the fly ! iguess - flag for guess solution (currently not working) ! iguess = -1 do not use guess file ! iguess = 0 write only guess file @@ -524,9 +523,9 @@ module gsimod ! sfcmodel - if true, then use boundary layer forward model for surface temperature data. ! dtbduv_on - if true, use d(microwave brightness temperature)/d(uv wind) in inner loop ! ifact10 - flag for recomputing 10m wind factor -! ifact10 = 1 compute using GFS surface physics -! ifact10 = 2 compute using MM5 surface physics -! ifact10 = 0 or any other value - DO NOT recompute - use value from guess file +! ifact10 = 1 compute using gfs surface physics +! ifact10 = 2 compute using mm5 surface physics +! ifact10 = 0 or any other value - Do not recompute - use value from guess file ! offtime_data - if true, then allow use of obs files with ref time different ! from analysis time. default value = .false., in which case ! analysis fails if obs file ref time is different from analysis time. @@ -534,8 +533,8 @@ module gsimod ! perturb_obs - logical flag to perutrb observation (true=on) ! oberror_tune - logical flag to tune oberror table (true=on) ! perturb_fact - magnitude factor for observation perturbation -! crtm_coeffs_path - path of directory w/ CRTM coeffs files -! print_diag_pcg - logical turn on of printing of GMAO diagnostics in pcgsoi.f90 +! crtm_coeffs_path - path of directory w/ crtm coeffs files +! print_diag_pcg - logical turn on of printing of gmao diagnostics in pcgsoi.f90 ! preserve_restart_date - if true, then do not update regional restart file date. ! tsensible - option to use sensible temperature as the analysis variable. works ! only for twodvar_regional=.true. @@ -563,18 +562,18 @@ module gsimod ! reset_bad_radbc - option to turn on reseting bias correction coefficient when it is bad ! use_edges - option to exclude radiance data on scan edges ! biaspredvar - set background error variance for radiance bias coeffs -! (default 0.1K) +! (default 0.1k) ! use_compress - option to turn on the use of compressibility factors in geopotential heights ! nsig_ext - number of layers above the model top which are necessary to compute the bending angle for gpsro ! gpstop - maximum height for gpsro data assimilation. Reject anything above this height. -! use_gfs_nemsio - option to use nemsio to read global model NEMS/GFS first guess -! use_gfs_ncio - option to use netCDF to read global model FV3-GFS first guess -! use_fv3_aero - option to use FV3-Chem vs NGAC for global aerosol analysis -! sfcnst_comb - option to use nemsio sfc history file by regriding FV3 grid +! use_gfs_nemsio - option to use nemsio to read global model nems/gfs first guess +! use_gfs_ncio - option to use netcdf to read global model fv3-gfs first guess +! use_fv3_aero - option to use fv3-chem vs ngac for global aerosol analysis +! sfcnst_comb - option to use nemsio sfc history file by regriding fv3 grid ! use_readin_anl_sfcmask - option to use readin surface mask ! use_prepb_satwnd - allow using satwnd''s from prepbufr (historical) file -! id_drifter - option to identify drifting buoy observations (modify KX from 180/280) -! id_ship - option to identify ship observations (modify KX from 180) +! id_drifter - option to identify drifting buoy observations (modify kx from 180/280) +! id_ship - option to identify ship observations (modify kx from 180) ! use_gfs_stratosphere - for now, can only be set to true if nems_nmmb_regional=true. Later extend ! to other regional models. When true, a guess gfs valid at the same time ! as the nems-nmmb guess is used to replace the upper levels with gfs values. @@ -587,69 +586,69 @@ module gsimod ! is to allow direct use of gdas derived sat radiance bias correction coefs, ! since it has been determined that height of top level and stratosphere ! resolution are key to successful assimilation of most channels. -! (NOTE: I have not actually verified this statement yet!) +! (Note: I have not actually verified this statement yet!) ! pblend0,pblend1 - see above comment for use_gfs_stratosphere ! l4densvar - logical to turn on ensemble 4dvar ! ens_nstarthr - start hour for ensemble perturbations (generally should match min_offset) ! lwrite4danl - logical to write out 4d analysis states if 4dvar or 4denvar mode -! nhr_anal - forecast hours to write out if lwrite4danal=T +! nhr_anal - forecast hours to write out if lwrite4danal=t ! ladtest - if true, doing the adjoint test for the operator that maps ! control_vector to the model state_vector ! ladtest_obs - if true, doing the adjoint adjoint check for the -! observation operators that are currently used in the NCEP GSI variational +! observation operators that are currently used in the ncep gsi variational ! analysis scheme ! lrun_subdirs - logical to toggle use of subdirectires at runtime for pe specific files -! mpes_observer - informs Solver number of PEs used to run Observer +! mpes_observer - informs solver number of pes used to run observer ! emiss_bc - option to turn on emissivity bias predictor ! lsingleradob - logical for single radiance observation assimilation. -! Uses existing bufr file and rejects all radiances that don''t fall within a tight threshold around -! oblat/oblon (SINGLEOB_TEST) +! Uses existing bufr file and rejects all radiances that don't fall within a tight threshold around +! oblat/oblon (singleob_test) ! -! ssmis_method - choose method for SSMIS noise reduction 0=no smoothing 1=default -! ssmis_precond - weighting factor for SSMIS preconditioning (if not using newpc4pred) -! gmi_method - choose method for GMI noise reduction. 0=no smoothing, 4=default -! amsr2_method - choose method for AMSR2 noise reduction. 0=no smoothing, 5=default +! ssmis_method - choose method for ssmis noise reduction 0=no smoothing 1=default +! ssmis_precond - weighting factor for ssmis preconditioning (if not using newpc4pred) +! gmi_method - choose method for gmi noise reduction. 0=no smoothing, 4=default +! amsr2_method - choose method for amsr2 noise reduction. 0=no smoothing, 5=default ! bias_zero_start - Initialise bias correction from zero (default=true, ! false=mode start method) -! ec_amv_qc - If true use additional QC from ECMWF addressing issues with -! upper level GOES-16/17 winds (default = true) +! ec_amv_qc - If true use additional qc from ecmwf addressing issues with +! upper level goes-16/17 winds (default = true) ! R_option - Option to use variable correlation length for lcbas based on data -! density - follows Hayden and Purser (1995) (twodvar_regional only) +! density - follows hayden and purser (1995) (twodvar_regional only) ! thin4d - if true, removes thinning of observations due to the location in ! the time window -! lobsdiag_forenkf - if true, save linearized H operator (jacobian) in -! diagnostic file on 1st outer iteration. The Jacobian can then be used by -! the EnKF to compute ensemble perturbations in observation space. -! luse_obsdiag - use obsdiags (useful when running EnKF observers; e.g., echo Jo table) -! imp_physics - type of GFS microphysics -! lupp - if T, UPP is used and extra variables are output -! lcalc_gfdl_cfrac - if T, calculate and use GFDL cloud fraction in observation operator -! cao_check - if T, turn on cold-air-outbreak screening for quality control +! lobsdiag_forenkf - if true, save linearized h operator (jacobian) in +! diagnostic file on 1st outer iteration. The jacobian can then be used by +! the enkf to compute ensemble perturbations in observation space. +! luse_obsdiag - use obsdiags (useful when running enkf observers; e.g., echo jo table) +! imp_physics - type of gfs microphysics +! lupp - if t, upp is used and extra variables are output +! lcalc_gfdl_cfrac - if t, calculate and use gfdl cloud fraction in observation operator +! cao_check - if t, turn on cold-air-outbreak screening for quality control ! binary_diag - trigger binary diag-file output (being phased out) ! netcdf_diag - trigger netcdf diag-file output -! write_fv3_incr - trigger writing out FV3 netCDF increment file -! rather than NEMSIO analysis -! incvars_to_zero - list of strings of variable names in FV3 netCDF +! write_fv3_incr - trigger writing out fv3 netcdf increment file +! rather than nemsio analysis +! incvars_to_zero - list of strings of variable names in fv3 netcdf ! increment file that should be forced to be zero -! incvars_zero_strat - list of strings of variable names in FV3 netcdf +! incvars_zero_strat - list of strings of variable names in fv3 netcdf ! increment file that will be reduced to zero ! above the tropopause ! incvars_efold - scale factor x in which e^(-(k-ktrop)/x) for above fields ! ! diag_version - specifies desired version of diag files ! l_wcp_cwm - namelist logical whether to use swcp/lwcp operator that includes cwm -! aircraft_recon - namelist logical whether to apply DOE to aircraft data -! tau_fcst - controls EFSOI-like calculation -! efsoi_order - sets order of EFSOI-like calculation -! lupdqc - logical to replace the obs errors from satinfo with diag of est(R) in the case of correlated obs -! lqcoef - logical to combine the inflation coefficients generated by qc with est(R) +! aircraft_recon - namelist logical whether to apply doe to aircraft data +! tau_fcst - controls efsoi-like calculation +! efsoi_order - sets order of efsoi-like calculation +! lupdqc - logical to replace the obs errors from satinfo with diag of est(r) in the case of correlated obs +! lqcoef - logical to combine the inflation coefficients generated by qc with est(r) ! -! NOTE: for now, if in regional mode, then iguess=-1 is forced internally. +! Note: for now, if in regional mode, then iguess=-1 is forced internally. ! add use of guess file later for regional mode. namelist/setup/gencode,factqmin,factqmax,clip_supersaturation, & - factql,factqi,factqr,factqs,factqg, & - factv,factl,factp,factg,factw10m,facthowv,factcldch,R_option,deltim,dtphys,& + factql,factqi,factqr,factqs,factqg, & + factv,factl,factp,factg,factw10m,facthowv,factcldch,r_option,deltim,dtphys,& biascor,bcoption,diurnalbc,& neutral_stability_windfact_2dvar,use_similarity_2dvar,& niter,niter_no_qc,miter,qoption,cwoption,nhr_assimilation,& @@ -666,8 +665,8 @@ module gsimod ssmis_method, ssmis_precond, gmi_method, amsr2_method, bias_zero_start, & ec_amv_qc, lobsdiagsave, lobsdiag_forenkf, & l4dvar,lbicg,lsqrtb,lcongrad,lbfgsmin,ltlint,nhr_obsbin,nhr_subwin,& - mPES_observer,& - alwaysLocal,& + mpes_observer,& + alwayslocal,& use_fv3_aero,& nwrvecs,iorthomax,ladtest,ladtest_obs, lgrtest,lobskeep,lsensrecompute,jsiga,ltcost, & lobsensfc,lobsensjb,lobsensincr,lobsensadj,lobsensmin,iobsconv, & @@ -688,7 +687,7 @@ module gsimod write_fv3_incr,incvars_to_zero,incvars_zero_strat,incvars_efold,diag_version,& cao_check,lcalc_gfdl_cfrac,tau_fcst,efsoi_order,lupdqc,lqcoef,cnvw_option -! GRIDOPTS (grid setup variables,including regional specific variables): +! gridopts (grid setup variables,including regional specific variables): ! jcap - spectral resolution ! nsig - number of sigma levels ! nlat - number of latitudes @@ -701,21 +700,21 @@ module gsimod ! regional analysis file (default = false) ! netcdf - if true, then wrf files are in netcdf format, ! - otherwise wrf files are in binary format. -! regional - logical for regional GSI run -! wrf_nmm_regional - logical for input from WRF NMM -! fv3_regional - logical for input from FV3 regional -! wrf_mass_regional - logical for input from WRF MASS-CORE -! cmaq_regional - logical for input from CMAQ -! nems_nmmb_regional- logical for input from NEMS NMMB -! nmmb_reference_grid= 'H', then analysis grid covers H grid domain -! = 'V', then analysis grid covers V grid domain +! regional - logical for regional gsi run +! wrf_nmm_regional - logical for input from wrf nmm +! fv3_regional - logical for input from fv3 regional +! wrf_mass_regional - logical for input from wrf mass-core +! cmaq_regional - logical for input from cmaq +! nems_nmmb_regional- logical for input from nems nmmb +! nmmb_reference_grid= 'h', then analysis grid covers h grid domain +! = 'v', then analysis grid covers v grid domain ! grid_ratio_nmmb - ratio of analysis grid to nmmb model grid in nmmb model grid units. ! grid_ratio_fv3_regional - ratio of analysis grid to fv3 grid in fv3 grid units. ! grid_ratio_wrfmass - ratio of analysis grid to wrf mass grid in wrf grid units. ! twodvar_regional - logical for regional 2d-var analysis -! filled_grid - logical to fill in puts on WRF-NMM E-grid -! half_grid - logical to use every other row of WRF-NMM E-Grid -! nvege_type - number of types of vegetation; old=24, IGBP=20 +! filled_grid - logical to fill in puts on wrf-nmm e-grid +! half_grid - logical to use every other row of wrf-nmm e-grid +! nvege_type - number of types of vegetation; old=24, igbp=20 ! nlayers - number of sub-layers to break indicated model layer into ! prior to calling radiative transfer model ! jcap_gfs - spectral truncation used to transform high wavenumber @@ -723,7 +722,7 @@ module gsimod ! when use_gfs_ozone = .true. or use_gfs_stratosphere = .true. ! use_sp_eqspac - if .true., then ensemble grid is equal spaced, staggered 1/2 grid unit off ! poles. if .false., then gaussian grid assumed for ensemble (global only) -! wrf_mass_hybridcord - logical for using WRF MASS CORE with hybrid vertical coordinate +! wrf_mass_hybridcord - logical for using wrf mass core with hybrid vertical coordinate namelist/gridopts/jcap,jcap_b,nsig,nlat,nlon,nlat_regional,nlon_regional,& @@ -732,7 +731,7 @@ module gsimod nmmb_reference_grid,grid_ratio_nmmb,grid_ratio_fv3_regional,grid_ratio_wrfmass,jcap_gfs,jcap_cut,& wrf_mass_hybridcord -! BKGERR (background error related variables): +! bkgerr (background error related variables): ! vs - scale factor for vertical correlation lengths for background error ! nhscrf - number of horizontal scales for recursive filter ! hzscl(n) - scale factor for horizontal smoothing, n=1,number of scales (3 for now) @@ -754,14 +753,14 @@ module gsimod ! bkgv_rewgtfct - factor used to perform flow dependent reweighting of error variances ! bkgv_write - flag to turn on=.true. /off=.false. generation of binary file with reweighted variances ! fpsproj - controls full nsig projection to surface pressure -! fut2ps - controls the projection from unbalance T to surface pressure +! fut2ps - controls the projection from unbalance t to surface pressure ! adjustozvar - adjusts ozone variances in the stratosphere based on guess field -! cwcoveqqcov - sets cw Bcov to be the same as B-cov(q) (presently glb default) +! cwcoveqqcov - sets cw bcov to be the same as b-cov(q) (presently glb default) namelist/bkgerr/vs,nhscrf,hzscl,hswgt,norh,ndeg,noq,bw,norsp,fstat,pert_berr,pert_berr_fct, & - bkgv_flowdep,bkgv_rewgtfct,bkgv_write,fpsproj,adjustozvar,fut2ps,cwcoveqqcov + bkgv_flowdep,bkgv_rewgtfct,bkgv_write,fpsproj,adjustozvar,fut2ps,cwcoveqqcov -! ANBKGERR (anisotropic background error related variables): +! anbkgerr (anisotropic background error related variables): ! anisotropic - if true, then use anisotropic background error ! ancovmdl - covariance model settings - 0: pt-based, 1: ensemble based ! triad4 - for 2d variables, if true, use blended triad algorithm @@ -798,7 +797,7 @@ module gsimod ! nsmooth - number of 1-2-1 smoothing passes before and after background error application ! nsmooth_shapiro - number of 2nd moment preserving (shapiro) smoothing passes before and after ! background error application. -! NOTE: default for nsmooth and nsmooth_shapiro is 0. +! Note: default for nsmooth and nsmooth_shapiro is 0. ! if both are > 0, then nsmooth will be forced to zero. namelist/anbkgerr/anisotropic,ancovmdl,triad4,ifilt_ord,npass,normal,binom,& @@ -807,21 +806,21 @@ module gsimod rtma_subdomain_option,rtma_bkerr_sub2slab,lreadnorm,nsmooth,nsmooth_shapiro, & afact0,covmap -! JCOPTS (Jc term) +! jcopts (jc term) ! if .false., uses original formulation based on wind, temp, and ps tends ! ljcdfi - when .t. uses digital filter initialization of increments (4dvar) ! alphajc - parameter for digital filter ! ljpdry - when .t. uses dry pressure constraint on increment ! bamp_jcpdry - parameter for pdry_jc -! eps_eer - Errico-Ehrendofer parameter for q-term in energy norm -! ljc4tlevs - when true and in 4D mode, apply any weak constraints over all time levels +! eps_eer - errico-ehrendofer parameter for q-term in energy norm +! ljc4tlevs - when true and in 4d mode, apply any weak constraints over all time levels ! instead of just at a single time ! namelist/jcopts/ljcdfi,alphajc,switch_on_derivatives,tendsflag,ljcpdry,bamp_jcpdry,eps_eer,& ljc4tlevs,ljclimqc -! STRONGOPTS (strong dynamic constraint) +! strongopts (strong dynamic constraint) ! reg_tlnmc_type - =1 for 1st version of regional strong constraint ! =2 for 2nd version of regional strong constraint ! nstrong - if > 0, then number of iterations of implicit normal mode initialization @@ -836,18 +835,18 @@ module gsimod ! baldiag_full ! baldiag_inc ! tlnmc_option : integer flag for strong constraint (various capabilities for hybrid) -! =0: no TLNMC -! =1: TLNMC for 3DVAR mode -! =2: TLNMC on total increment for single time level only (for 3D EnVar) -! or if 4D EnVar mode, TLNMC applied to increment in center of window -! =3: TLNMC on total increment over all time levels (if in 4D EnVar mode) -! =4: TLNMC on static contribution to increment ONLY for any EnVar mode +! =0: no tlnmc +! =1: tlnmc for 3dvar mode +! =2: tlnmc on total increment for single time level only (for 3d envar) +! or if 4d envar mode, tlnmc applied to increment in center of window +! =3: tlnmc on total increment over all time levels (if in 4d envar mode) +! =4: tlnmc on static contribution to increment only for any envar mode namelist/strongopts/reg_tlnmc_type,tlnmc_option, & nstrong,period_max,period_width,nvmodes_keep, & - baldiag_full,baldiag_inc + baldiag_full,baldiag_inc -! OBSQC (observation quality control variables): +! obsqc (observation quality control variables): ! ! Parameters used for gross error checks ! obserrx = max(ermin,min(ermax,obs error) @@ -861,7 +860,7 @@ module gsimod ! tdrerr_inflate - logical for tdr obs error inflation ! oberrflg - logical for reading in new obs error table (if set to true) ! vadfile - character(10) variable holding name of vadwnd bufr file -! noiqc - logical flag to bypass OIQC (if set to true) +! noiqc - logical flag to bypass oiqc (if set to true) ! c_varqc - constant number to control var. qc turnning on speed ! blacklst - logical for reading in raob blacklist (if set to true) ! use_poq7 - logical flag to accept (.true.) sbuv profile quality flag 7 @@ -869,22 +868,22 @@ module gsimod ! tcp_width - parameter for tcps oberr inflation (width, mb) ! tcp_ermin - parameter for tcps oberr inflation (minimum oberr, mb) ! tcp_ermax - parameter for tcps oberr inflation (maximum oberr, mb) -! qc_noirjaco3 - controls whether to use O3 Jac from IR instruments -! qc_noirjaco3_pole - controls wheter to use O3 Jac from IR instruments near poles +! qc_noirjaco3 - controls whether to use o3 jac from ir instruments +! qc_noirjaco3_pole - controls wheter to use o3 jac from ir instruments near poles ! qc_satwnds - allow bypass sat-winds qc normally removing lots of mid-tropo obs ! aircraft_t_bc_pof - logical for aircraft temperature bias correction, pof ! is used for predictor ! aircraft_t_bc - logical for aircraft temperature bias correction ! aircraft_t_bc_ext - logical for reading aircraft temperature bias correction from external file ! buddycheck_t - When true, run buddy check algorithm on temperature observations -! buddydiag_save - When true, output files containing buddy check QC info for all +! buddydiag_save - When true, output files containing buddy check qc info for all ! obs run through the buddy check -! njqc - When true, use Purser''s non linear QC -! vqc - when true, use ECMWF's non linear QC -! nvqc - when true, use Dr. Purser's variational QC +! njqc - When true, use purser's non linear qc +! vqc - when true, use ecmwf's non linear qc +! nvqc - when true, use purser's variational qc ! hub_norm - when true,use huber norm format distribution ! closest_obs- when true, choose the timely closest surface observation from -! multiple observations at a station. Currently only applied to Ceiling +! multiple observations at a station. Currently only applied to ceiling ! height and visibility. ! pvis - power parameter in nonlinear transformation for vis ! pcldch - power parameter in nonlinear transformation for cldch @@ -897,18 +896,17 @@ module gsimod ! The following variables are the coefficients that describe the ! linear regression fits that are used to define the dynamic -! observation error (DOE) specifications for all reconnissance +! observation error (doe) specifications for all reconnissance ! observations collected within hurricanes/tropical cyclones; these -! apply only to the regional forecast models (e.g., HWRF); Henry -! R. Winterbottom (henry.winterbottom@noaa.gov). +! apply only to the regional forecast models (e.g., hwrf) ! Observation types: -! 1/236: HDOB (e.g., flight-level) observations. +! 1/236: hdob (e.g., flight-level) observations. -! 1/237: Dropsonde observations. +! 1/237: dropsonde observations. -! 292: SFMR observations. +! 292: sfmr observations. ! The following correspond to the specific humidity (q) observations: @@ -947,19 +945,19 @@ module gsimod pvis,pcldch,scale_cv,estvisoe,estcldchoe,vis_thres,cldch_thres,cld_det_dec2bin, & q_doe_a_136,q_doe_a_137,q_doe_b_136,q_doe_b_137, & t_doe_a_136,t_doe_a_137,t_doe_b_136,t_doe_b_137, & - uv_doe_a_236,uv_doe_a_237,uv_doe_a_292,uv_doe_b_236,uv_doe_b_237,uv_doe_b_292 + uv_doe_a_236,uv_doe_a_237,uv_doe_a_292,uv_doe_b_236,uv_doe_b_237,uv_doe_b_292 -! OBS_INPUT (controls input data): +! obs_input (controls input data): ! dmesh(max(dthin))- thinning mesh for each group ! time_window_max - upper limit on time window for all input data ! time_window_rad - upper limit on time window for certain radiance input data ! ext_sonde - logical for extended forward model on sonde data -! l_foreaft_thin - separate TDR fore/aft scan for thinning +! l_foreaft_thin - separate tdr fore/aft scan for thinning namelist/obs_input/dmesh,time_window_max,time_window_rad, & ext_sonde,l_foreaft_thin -! SINGLEOB_TEST (one observation test case setup): +! singleob_test (one observation test case setup): ! maginnov - magnitude of innovation for one ob ! magoberr - magnitude of observational error ! oneob_type - observation type (lsingleradob: platform type, i.e. 'airs') @@ -977,12 +975,12 @@ module gsimod oblat,oblon,obpres,obdattim,obhourset,pctswitch,& obchan,anel_rw,anaz_rw,range_rw,sstn,learthrel_rw -! SUPEROB_RADAR (level 2 bufr file to radar wind superobs): +! superob_radar (level 2 bufr file to radar wind superobs): ! del_azimuth - azimuth range for superob box (default 5 degrees) ! del_elev - elevation angle range for superob box (default .05 degrees) ! del_range - radial range for superob box (default 5 km) ! del_time - 1/2 time range for superob box (default .5 hours) -! elev_angle_max - max elevation angle (default of 5 deg recommended by S. Liu) +! elev_angle_max - max elevation angle (default of 5 deg recommended by s. liu) ! minnum - minimum number of samples needed to make a superob ! range_max - max radial range to use in constructing superobs (default 100km) ! l2superob_only - if true, then process level 2 data creating superobs, then quit. @@ -992,7 +990,7 @@ module gsimod namelist/superob_radar/del_azimuth,del_elev,del_range,del_time,& elev_angle_max,minnum,range_max,l2superob_only -! LAG_DATA (lagrangian data assimilation related variables): +! lag_data (lagrangian data assimilation related variables): ! lag_accur - Accuracy used to decide whether or not a balloon is on the grid ! infile_lag- File containing the initial position of the balloon ! lag_stepduration- Duration of one time step for the propagation model @@ -1002,13 +1000,13 @@ module gsimod namelist/lag_data/lag_accur,infile_lag,lag_stepduration,lag_nmax_bal,& lag_vorcore_stderr_a,lag_vorcore_stderr_b -! HYBRID_ENSEMBLE (parameters for use with hybrid ensemble option) +! hybrid_ensemble (parameters for use with hybrid ensemble option) ! l_hyb_ens - if true, then turn on hybrid ensemble option ! uv_hyb_ens - if true, then ensemble perturbation wind variables are u,v, ! otherwise, ensemble perturbation wind variables are stream, pot. functions. ! q_hyb_ens - if true, then use specific humidity ensemble perturbations, ! otherwise, use relative humidity -! oz_univ_static- if true, decouple ozone from other variables and defaults to static B (ozone only) +! oz_univ_static- if true, decouple ozone from other variables and defaults to static b (ozone only) ! aniso_a_en - if true, then use anisotropic localization of hybrid ensemble control variable a_en. ! generate_ens - if true, then generate internal ensemble based on existing background error ! n_ens - number of ensemble members. @@ -1021,13 +1019,13 @@ module gsimod ! =1, then ensemble information turned off ! =0, then static background turned off ! the weights are applied per vertical level such that : -! beta_s(:) = beta_s0 , vertically varying weights given to static B ; +! beta_s(:) = beta_s0 , vertically varying weights given to static b ; ! beta_e(:) = 1 - beta_s0 , vertically varying weights given ensemble derived covariance. ! If (readin_beta) then beta_s and beta_e are read from a file and beta_s0 is not used. ! s_ens_h - homogeneous isotropic horizontal ensemble localization scale (km) ! s_ens_v - vertical localization scale (grid units for now) ! s_ens_h, s_ens_v, and beta_s0 are tunable parameters. -! use_gfs_ens - controls use of global ensemble: .t. use GFS (default); .f. uses user-defined ens +! use_gfs_ens - controls use of global ensemble: .t. use gfs (default); .f. uses user-defined ens ! readin_localization - flag to read (.true.)external localization information file ! readin_beta - flag to read (.true.) the vertically varying beta parameters beta_s and beta_e ! from a file. @@ -1036,23 +1034,23 @@ module gsimod ! for ensemble (global only) ! use_localization_grid - if true, then use extra lower res gaussian grid for horizontal localization ! (global runs only--allows possiblity for non-gaussian ensemble grid) -! pseudo_hybens - if true, turn on pseudo ensemble hybrid for HWRF +! pseudo_hybens - if true, turn on pseudo ensemble hybrid for hwrf ! merge_two_grid_ensperts - if true, merge ensemble perturbations from two forecast domains -! to analysis domain (one way to deal with hybrid DA for HWRF moving nest) +! to analysis domain (one way to deal with hybrid da for hwrf moving nest) ! regional_ensemble_option - integer, used to select type of ensemble to read in for regional ! application. Currently takes values from 1 to 4. -! =1: use GEFS internally interpolated to ensemble grid. -! =2: ensembles are WRF NMM format -! =3: ensembles are ARW netcdf format. -! =4: ensembles are NEMS NMMB format. +! =1: use gefs internally interpolated to ensemble grid. +! =2: ensembles are wrf nmm format +! =3: ensembles are arw netcdf format. +! =4: ensembles are nems nmmb format. ! full_ensemble - if true, first ensemble perturbation on first guess istead of on ens mean -! pwgtflg - if true, use vertical integration function on ensemble contribution of Psfc +! pwgtflg - if true, use vertical integration function on ensemble contribution of psfc ! grid_ratio_ens - for regional runs, ratio of ensemble grid resolution to analysis grid resolution ! default value = 1 (dual resolution off) ! i_en_perts_io - flag to read in ensemble perturbations in ensemble grid. -! This is to speed up RAP/HRRR hybrid runs because the +! This is to speed up rap/hrrr hybrid runs because the ! same ensemble perturbations are used in 6 cycles -! =0: No ensemble perturbations IO (default) +! =0: No ensemble perturbations io (default) ! =2: skip get_gefs_for_regional and read in ensemble ! perturbations from saved files. ! l_ens_in_diff_time - if use ensembles that are available at different time @@ -1063,7 +1061,7 @@ module gsimod ! from analysis time in hybrid analysis ! ensemble_path - path to ensemble members; default './' ! ens_fast_read - read ensemble in parallel; default '.false.' -! sst_staticB - use only static background error covariance for SST statistic +! sst_staticb - use only static background error covariance for sst statistic ! ! namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,nlon_ens,nlat_ens,jcap_ens,& @@ -1071,69 +1069,69 @@ module gsimod jcap_ens_test,beta_s0,s_ens_h,s_ens_v,readin_localization,eqspace_ensgrid,readin_beta,& grid_ratio_ens, & oz_univ_static,write_ens_sprd,use_localization_grid,use_gfs_ens, & - i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB + i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticb ! rapidrefresh_cldsurf (options for cloud analysis and surface -! enhancement for RR appilcation ): -! dfi_radar_latent_heat_time_period - DFI forward integration window in minutes +! enhancement for rr appilcation ): +! dfi_radar_latent_heat_time_period - dfi forward integration window in minutes ! metar_impact_radius - metar low cloud observation impact radius in grid number -! l_gsd_terrain_match_surftobs - if .true., GSD terrain match for surface temperature observation +! l_gsd_terrain_match_surftobs - if .true., gsd terrain match for surface temperature observation ! l_sfcobserror_ramp_t - namelist logical for adjusting surface temperature observation error ! l_sfcobserror_ramp_q - namelist logical for adjusting surface moisture observation error -! l_pbl_pseudo_surfobst - if .true. produce pseudo-obs in PBL layer based on surface obs T -! l_pbl_pseudo_surfobsq - if .true. produce pseudo-obs in PBL layer based on surface obs Q -! l_pbl_pseudo_surfobsuv - if .true. produce pseudo-obs in PBL layer based on surface obs UV -! pblh_ration - percent of the PBL height within which to add pseudo-obs (default:0.75) +! l_pbl_pseudo_surfobst - if .true. produce pseudo-obs in pbl layer based on surface obs t +! l_pbl_pseudo_surfobsq - if .true. produce pseudo-obs in pbl layer based on surface obs q +! l_pbl_pseudo_surfobsuv - if .true. produce pseudo-obs in pbl layer based on surface obs uv +! pblh_ration - percent of the pbl height within which to add pseudo-obs (default:0.75) ! pps_press_incr - pressure increase for each additional pseudo-obs -! on top of previous level (default:30hPa) -! l_gsd_limit_ocean_q - if .true. do GSD limitation of Q over ocean -! l_pw_hgt_adjust - if .true. do GSD PW adjustment for model vs. obs station height -! l_limit_pw_innov - if .true. do GSD limitation of PW obs -! max_innov_pct - sets limit of PW ob to a percent of the background value (0-1) -! l_cleansnow_warmts - if .true. do GSD limitation of using retrieved snow over warn area -! (Ts > r_cleansnow_warmts_threshold) +! on top of previous level (default:30hpa) +! l_gsd_limit_ocean_q - if .true. do gsd limitation of q over ocean +! l_pw_hgt_adjust - if .true. do gsd pw adjustment for model vs. obs station height +! l_limit_pw_innov - if .true. do gsd limitation of pw obs +! max_innov_pct - sets limit of pw ob to a percent of the background value (0-1) +! l_cleansnow_warmts - if .true. do gsd limitation of using retrieved snow over warn area +! (ts > r_cleansnow_warmts_threshold) ! r_cleansnow_warmts_threshold - threshold for using retrieved snow over warn area -! l_conserve_thetaV - if .true. conserve thetaV during moisture adjustment in cloud analysis -! i_conserve_thetav_iternum - iteration number for conserving thetaV during moisture adjustment -! l_gsd_soiltq_nudge - if .true. do GSD soil T and Q nudging based on the lowest t analysis inc -! l_cld_bld - if .true. do GSD GOES cloud building -! cld_bld_hgt - sets limit below which GOES cloud building occurs (default:1200m) +! l_conserve_thetav - if .true. conserve thetav during moisture adjustment in cloud analysis +! i_conserve_thetav_iternum - iteration number for conserving thetav during moisture adjustment +! l_gsd_soiltq_nudge - if .true. do gsd soil t and q nudging based on the lowest t analysis inc +! l_cld_bld - if .true. do gsd goes cloud building +! cld_bld_hgt - sets limit below which goes cloud building occurs (default:1200m) ! build_cloud_frac_p - sets the threshold for building clouds from satellite ! clear_cloud_frac_p - sets the threshold for clearing clouds from satellite -! nesdis_npts_rad - NESDIS cloud product impact radiu (grid points) -! iclean_hydro_withRef - if =1, then clean hydrometeors if the grid point +! nesdis_npts_rad - nesdis cloud product impact radiu (grid points) +! iclean_hydro_withref - if =1, then clean hydrometeors if the grid point ! has no echo and maxref=0 -! iclean_hydro_withRef_allcol - if =1, then clean whole column hydrometeors +! iclean_hydro_withref_allcol - if =1, then clean whole column hydrometeors ! if the observed max ref =0 and satellite cloud shows ! clean ! i_use_2mq4b - background used for calculate surface moisture observation ! innovation -! =0 Use Q from the 1st model level. (default) -! =1 use 2m Q as part of background +! =0 Use q from the 1st model level. (default) +! =1 use 2m q as part of background ! i_use_2mt4b - background used for calculate surface temperature ! observation innovation -! =0 Use T from the 1st model level. (default) -! =1 use 2m T as part of background -! i_gsdcldanal_type - options for how GSD cloud analysis should be conducted +! =0 Use t from the 1st model level. (default) +! =1 use 2m t as part of background +! i_gsdcldanal_type - options for how gsd cloud analysis should be conducted ! =0. no cloud analysis (default) -! =1. cloud analysis after var analysis for WRF_ARW -! =2. cloud analysis after var analysis for NMMB +! =1. cloud analysis after var analysis for wrf_arw +! =2. cloud analysis after var analysis for nmmb ! =3. cloud analysis only; var is skipped -! =5. skip cloud analysis and updating NETCDF result file at +! =5. skip cloud analysis and updating netcdf result file at ! the end of the analysis -! =6. skip NETCDF background read step and do cloud analysis only -! =7 cloud analysis in observer with I/O -! =30 cloud analysis for GFS +! =6. skip netcdf background read step and do cloud analysis only +! =7 cloud analysis in observer with i/o +! =30 cloud analysis for gfs ! =99 only read hydrometer fields but no cloud analysis ! i_gsdsfc_uselist - options for how to use surface observation use or ! rejection list -! =0 . EMC method (default) -! =1 . GSD method +! =0 . emc method (default) +! =1 . gsd method ! i_lightpcp - options for how to deal with light precipitation ! =0 . don''t add light precipitation (default) ! =1 . add light precipitation in warm section -! i_sfct_gross - if use extended threshold for surface T gross check +! i_sfct_gross - if use extended threshold for surface t gross check ! =0 use threshold from convinfo (default) ! =1 for cold surface, threshold for gross check is ! enlarged to bring more large negative innovation into @@ -1155,7 +1153,7 @@ module gsimod ! =2. for moisture surface observations ! =3. for temperature and moisture surface observations ! i_gsdqc - option i_gsdqc to turn on special observation qc -! from GSD (for RAP/HRRR application) +! from gsd (for rap/hrrr application) ! =0 turn off ! =2 turn on ! qv_max_inc - threshold to limit the maximum water vapor increment @@ -1176,8 +1174,8 @@ module gsimod ! 0=single model run ! 1=ensemble mean ! 2=ensemble members -! DTsTmax - maximum allowed difference between Tskin and the first -! level T. This is to safety guard soil T adjustment. +! dtstmax - maximum allowed difference between tskin and the first +! level t. This is to safety guard soil t adjustment. ! namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, & metar_impact_radius,metar_impact_radius_lowcloud, & @@ -1186,39 +1184,39 @@ module gsimod l_pbl_pseudo_surfobst,l_pbl_pseudo_surfobsq,l_pbl_pseudo_surfobsuv, & pblh_ration,pps_press_incr,l_gsd_limit_ocean_q, & l_pw_hgt_adjust, l_limit_pw_innov, max_innov_pct, & - l_cleansnow_warmts,l_conserve_thetaV,r_cleansnow_warmts_threshold, & + l_cleansnow_warmts,l_conserve_thetav,r_cleansnow_warmts_threshold, & i_conserve_thetav_iternum,l_gsd_soiltq_nudge,l_cld_bld, cld_bld_hgt, & build_cloud_frac_p, clear_cloud_frac_p, & nesdis_npts_rad, & - iclean_hydro_withRef,iclean_hydro_withRef_allcol,& + iclean_hydro_withref,iclean_hydro_withref_allcol,& i_use_2mq4b,i_use_2mt4b,i_gsdcldanal_type,i_gsdsfc_uselist, & i_lightpcp,i_sfct_gross,l_use_hydroretrieval_all,l_numconc,l_closeobs,& i_coastline,i_gsdqc,qv_max_inc,ioption,l_precip_clear_only,l_fog_off,& cld_bld_coverage,cld_clr_coverage,& - i_cloud_q_innovation,i_ens_mean,DTsTmax + i_cloud_q_innovation,i_ens_mean,dtstmax ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require ! conversion to lower case and/or species names longer than 5 chars ! oneobtest_chem - one-ob trigger for chem constituent analysis -! maginnov_chem - O-B make-believe residual for one-ob chem test +! maginnov_chem - o-b make-believe residual for one-ob chem test ! magoberr_chem - make-believe obs error for one-ob chem test ! oneob_type_chem - type of chem-ob for one-ob test ! oblat_chem - latitude of make-believe chem obs ! oblon_chem - longitude of make-believe chem obs ! obpres_chem - pressure level of make-believe chem obs -! diag_incr - increment for CMAQ -! elev_tolerance - in meters when surface PM observation rejected due to elevation +! diag_incr - increment for cmaq +! elev_tolerance - in meters when surface pm observation rejected due to elevation ! disparity in background and observation -! tunable_error - a factor to calculate representativeness error for PM observations -! in_fname - CMAQ input filename -! out_fname - CMAQ output filename -! incr_fname - CMAQ increment filename -! laeroana_gocart - when true, do chem analysis with wrfchem (or NGAC) +! tunable_error - a factor to calculate representativeness error for pm observations +! in_fname - cmaq input filename +! out_fname - cmaq output filename +! incr_fname - cmaq increment filename +! laeroana_gocart - when true, do chem analysis with wrfchem (or ngac) ! l_aoderr_table - whethee to use aod error table or default error -! aod_qa_limit - minimum acceptable value of error flag for total column AOD -! luse_deepblue - whether to use MODIS AOD from the deepblue algorithm -! lread_ext_aerosol - if true, reads aerfNN file for aerosol arrays rather than sigfNN (NGAC NEMS IO) +! aod_qa_limit - minimum acceptable value of error flag for total column aod +! luse_deepblue - whether to use modis aod from the deepblue algorithm +! lread_ext_aerosol - if true, reads aerfnn file for aerosol arrays rather than sigfnn (ngac nems io) namelist/chem/berror_chem,oneobtest_chem,maginnov_chem,magoberr_chem,& oneob_type_chem,oblat_chem,oblon_chem,obpres_chem,& @@ -1227,14 +1225,14 @@ module gsimod laeroana_gocart, l_aoderr_table, aod_qa_limit, luse_deepblue,& aero_ratios,wrf_pm2_5, lread_ext_aerosol -! NST (NSST control namelist) : -! nst_gsi - indicator to control the Tr Analysis mode: 0 = no nst info in gsi at all; +! nst (nsst control namelist) : +! nst_gsi - indicator to control the tr analysis mode: 0 = no nst info in gsi at all; ! 1 = input nst info, but used for monitoring only -! 2 = input nst info, and used in CRTM simulation, but no Tr analysis -! 3 = input nst info, and used in CRTM simulation and Tr analysis is on +! 2 = input nst info, and used in crtm simulation, but no tr analysis +! 3 = input nst info, and used in crtm simulation and tr analysis is on ! nstinfo - number of nst variables -! zsea1 - upper depth (in mm) for vertical mean of T based on NSST T-Profile -! zsea2 - lower depth (in mm) for vertical mean of T based on NSST T-Profile +! zsea1 - upper depth (in mm) for vertical mean of t based on nsst t-profile +! zsea2 - lower depth (in mm) for vertical mean of t based on nsst t-profile ! fac_dtl - index to apply diurnal thermocline layer or not: 0 = no; 1 = yes. ! fac_tsl - index to apply thermal skin layer or not: 0 = no; 1 = yes. namelist/nst/nst_gsi,nstinfo,zsea1,zsea2,fac_dtl,fac_tsl @@ -1243,7 +1241,7 @@ module gsimod !--------------------------------------------------------------------------- - CONTAINS + contains !------------------------------------------------------------------------- ! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.3, GMAO ! @@ -1259,7 +1257,7 @@ subroutine gsimain_initialize !************************************************************* ! Begin gsi code ! - use m_gpsStats, only: gpsStats_create ! was done within obsmod::create_obsmod_vars() + use m_gpsstats, only: gpsstats_create ! was done within obsmod::create_obsmod_vars() use m_prad , only: prad_create ! was obsmod::create_passive_obsmod_vars() use m_obsdiags, only: obsdiags_create ! was done within obsmod::create_obsmod_vars() @@ -1268,7 +1266,7 @@ subroutine gsimain_initialize use gsi_4dcouplermod, only: gsi_4dcoupler_setservices implicit none character(len=*),parameter :: myname_='gsimod.gsimain_initialize' - integer:: ier,ios + integer(i_kind):: ier,ios real(r_kind):: varqc_max,c_varqc_new type(regional_io_class) :: regional_io @@ -1305,7 +1303,7 @@ subroutine gsimain_initialize call init_jfunc call init_balmod call init_berror - call init_anberror ! RTodling: alloc vectors should move to create + call init_anberror ! alloc vectors should move to create call init_grid call init_turbl call init_compact_diffs @@ -1324,12 +1322,12 @@ subroutine gsimain_initialize call init_gfs_stratosphere call set_fgrid2agrid call gsi_nstcoupler_init_nml - if(mype==0) write(6,*)' at 0 in gsimod, use_gfs_stratosphere,nems_nmmb_regional = ', & + if(mype==0) write(6,*)' at 0 in gsimod, use_gfs_stratosphere,nems_nmmb_regional = ', & use_gfs_stratosphere,nems_nmmb_regional ! Read user input from namelists. All processor elements -! read the namelist input. SGI MPI FORTRAN does not allow +! read the namelist input. sgi mpi fortran does not allow ! all tasks to read from standard in (unit 5). Hence, open ! namelist to different unit number and have each task read ! namelist file. @@ -1379,7 +1377,6 @@ subroutine gsimain_initialize if(ios/=0) call die(myname_,'read(strongopts)',ios) read(11,obsqc,iostat=ios) - if(ios/=0) call die(myname_,'read(obsqc)',ios) read(11,obs_input,iostat=ios) @@ -1406,11 +1403,11 @@ subroutine gsimain_initialize close(11) #endif if(jcap > jcap_cut)then - jcap_cut = jcap+1 - if(mype == 0)then - write(6,*) ' jcap_cut increased to jcap+1 = ', jcap+1 - write(6,*) ' jcap_cut < jcap+1 not allowed ' - end if + jcap_cut = jcap+1 + if(mype == 0)then + write(6,*) ' jcap_cut increased to jcap+1 = ', jcap+1 + write(6,*) ' jcap_cut < jcap+1 not allowed ' + end if end if if(vqc .and. niter_no_qc(1) < niter(1))then varqc_max=c_varqc*(niter(1)-niter_no_qc(1)) @@ -1425,19 +1422,19 @@ subroutine gsimain_initialize end if if(ltlint) then if(vqc .or. njqc .or. nvqc)then - vqc = .false. - nvqc = .false. - njqc = .false. - if(mype == 0) write(6,*) ' ltlint = true, so vqc and njqc must be false' + vqc = .false. + nvqc = .false. + njqc = .false. + if(mype == 0) write(6,*) ' ltlint = true, so vqc and njqc must be false' end if end if if (anisotropic) then - call init_fgrid2agrid(pf2aP1) - call init_fgrid2agrid(pf2aP2) - call init_fgrid2agrid(pf2aP3) + call init_fgrid2agrid(pf2ap1) + call init_fgrid2agrid(pf2ap2) + call init_fgrid2agrid(pf2ap3) endif -! 4D-Var setup +! 4d-var setup call setup_4dvar(mype) if (l4dvar) then if(reduce_diag) & @@ -1446,8 +1443,8 @@ subroutine gsimain_initialize ! Diagonal preconditioning is necessary for new bias correction if(newpc4pred .and. .not. diag_precon)then - diag_precon=.true. - step_start=8.e-4_r_kind + diag_precon=.true. + step_start=8.e-4_r_kind end if if( (.not.l4dvar) .and. (.not.l4densvar) ) ljcdfi=.false. @@ -1504,7 +1501,7 @@ subroutine gsimain_initialize call stop2(329) end if -! reg_tlnmc_type=2 currently requires that 2*nvmodes_keep <= npe +! reg_tlnmc_type=2 currently requires that 2*nvmodes_keep <= npe if(reg_tlnmc_type==2) then if(2*nvmodes_keep>npe) then if(mype==0) write(6,*)' reg_tlnmc_type=2 and nvmodes_keep > npe' @@ -1516,9 +1513,9 @@ subroutine gsimain_initialize if (tlnmc_option>=2 .and. tlnmc_option<=4) then if (.not.l_hyb_ens) then - if(mype==0) write(6,*)' GSIMOD: inconsistent set of options for Hybrid/EnVar & TLNMC = ',l_hyb_ens,tlnmc_option - if(mype==0) write(6,*)' GSIMOD: resetting tlnmc_option to 1 for 3DVAR mode' - tlnmc_option=1 + if(mype==0) write(6,*)' GSIMOD: inconsistent set of options for Hybrid/EnVar & TLNMC = ',l_hyb_ens,tlnmc_option + if(mype==0) write(6,*)' GSIMOD: resetting tlnmc_option to 1 for 3DVAR mode' + tlnmc_option=1 end if else if (tlnmc_option<0 .or. tlnmc_option>4) then if(mype==0) write(6,*)' GSIMOD: This option does not yet exist for tlnmc_option: ',tlnmc_option @@ -1532,9 +1529,9 @@ subroutine gsimain_initialize ! check consistency in q option if(pseudo_q2 .and. qoption==1)then if(mype==0)then - write(6,*)' pseudo-q2 = ', pseudo_q2, ' qoption = ', qoption - write(6,*)' pseudo-q2 must be used together w/ qoption=2 only, aborting.' - call stop2(999) + write(6,*)' pseudo-q2 = ', pseudo_q2, ' qoption = ', qoption + write(6,*)' pseudo-q2 must be used together w/ qoption=2 only, aborting.' + call stop2(999) endif endif @@ -1569,7 +1566,7 @@ subroutine gsimain_initialize if (mype==0) write(6,*)'GSIMOD: ***WARNING*** reset perturb_obs=',perturb_obs endif -! Force turn off cloud analysis and hydrometeor IO +! Force turn off cloud analysis and hydrometeor io if (i_gsdcldanal_type==0) then l_hydrometeor_bkio = .false. if (mype==0) write(6,*)'GSIMOD: ***WARNING*** set l_hydrometeor_bkio=false' @@ -1622,16 +1619,16 @@ subroutine gsimain_initialize ! If reflectivity is intended to be assimilated, beta_s0 should be zero. if ( beta_s0 > 0.0_r_kind )then - do i=1,ndat - if ( index(dtype(i), 'dbz') /= 0 )then - write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. Static B extended for radar reflectivity assimilation will be included in future version.' - call stop2(8888) - end if - end do + do i=1,ndat + if ( index(dtype(i), 'dbz') /= 0 )then + write(6,*)'beta_s0 needs to be set to zero in this GSI version, when reflectivity is directly assimilated. Static B extended for radar reflectivity assimilation will be included in future version.' + call stop2(8888) + end if + end do end if ! Turn off uv option if hybrid/ensemble options is false for purposes -! of TLNMC +! of tlnmc if (.not.l_hyb_ens) uv_hyb_ens=.false. ! Turn on derivatives if using dynamic constraint @@ -1645,7 +1642,7 @@ subroutine gsimain_initialize if (tendsflag) switch_on_derivatives=.true. -! Turn off Jc-pdry weak constraint if regional application +! Turn off jc-pdry weak constraint if regional application if (regional) ljcpdry=.false. ! Initialize lagrangian data assimilation - must be called after gsi_4dvar @@ -1653,7 +1650,7 @@ subroutine gsimain_initialize ! Ensure tendency flag is on if preciptation data listed as observation type. -! NOTE: only applicable for global run when not using observer +! Note: only applicable for global run when not using observer if (.not.tendsflag .and. .not.regional) then check_pcp: do i=1,ndat if ( .not.tendsflag .and. index(dtype(i),'pcp') /=0 ) then @@ -1701,7 +1698,7 @@ subroutine gsimain_initialize #else open(11,file='gsiparm.anl') read(11,singleob_test,iostat=ios) - if(ios/=0) call die(myname_,'read(singleob_test)',ios) + if(ios/=0) call die(myname_,'read(singleob_test)',ios) close(11) #endif dtype(1)=oneob_type @@ -1793,7 +1790,7 @@ subroutine gsimain_initialize if (switch_on_derivatives) call init_anadv ! moved from derivsmod call init_general_commvars call create_obsmod_vars - call gpsStats_create() ! extracted from obsmod::create_obsmod_vars() + call gpsstats_create() ! extracted from obsmod::create_obsmod_vars() call obsdiags_create() ! extracted from obsmod::create_obsmod_vars() if (passive_bc) call prad_create() ! replacing -- call obsmod::create_passive_obsmod_vars() @@ -1861,7 +1858,7 @@ subroutine gsimain_finalize implicit none ! Deallocate arrays -! RTodling debug: PROG HANGS; needs ATTENTION +! debug: Prog hangs; needs attention call mpi_comm_rank(mpi_comm_world,mype,ierror) if (anisotropic) then call final_fgrid2agrid(pf2aP3) @@ -1876,7 +1873,7 @@ subroutine gsimain_finalize call destroy_obsmod_vars call destroy_general_commvars call final_grid_vars -!_TBDone call final_reg_glob_ll ! gridmod +!_tbdone call final_reg_glob_ll ! gridmod call radiance_mode_destroy call final_anacv call final_anasv @@ -1886,7 +1883,7 @@ subroutine gsimain_finalize call clean_4dvar call destroy_qcvars -! Done with GSI. +! Done with gsi. if (mype==0) call w3tage('GSI_ANL') call mpi_finalize(ierror) diff --git a/src/gsi/gsisub.F90 b/src/gsi/gsisub.F90 index f66a261f0e..708a0d832c 100644 --- a/src/gsi/gsisub.F90 +++ b/src/gsi/gsisub.F90 @@ -34,7 +34,7 @@ subroutine gsisub(init_pass,last_pass) ! 2005-03-07 dee - support gmao model interface ! 2005-04-18 treadon - remove destroy_sst_an ! 2005-05-27 pondeca - bypass radinfo_ and pcpinfo_write when twodvar_regional=.t.! -! 2005-05-25 guo - added interfaces to handle GMAO first guess gridded fields +! 2005-05-25 guo - added interfaces to handle gmao first guess gridded fields ! 2005-07-25 treadon - remove redundant call to gengrid_vars ! 2005-09-08 derber - modify to use input group time window and simplify data set handling ! 2005-10-18 treadon - remove obs_load and dload, move deter_subdomain before read_obs @@ -44,7 +44,7 @@ subroutine gsisub(init_pass,last_pass) ! 2006-01-10 treadon - consolidate query guess file code in gesinfo ! 2006-04-20 kistler - moved conv_read from read_obs here to parallel other *info modules ! 2006-04-21 parrish - changes for new processing of level 2 radar wind data -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2007-10-03 todling - add observer call ! 2009-01-28 todling - update observer calling procedure ! 2009-08-19 guo - #ifdef out destroy_gesfinfo() call for multi-pass observer. @@ -62,7 +62,7 @@ subroutine gsisub(init_pass,last_pass) ! - add radiance_obstype_init,radiance_parameter_cloudy_init,radiance_parameter_aerosol_init ! 2016-07-28 lippi - add oneobmakerwsupob if 'rw' single ob test and skips radar_bufr_read_all. ! 2018-02-15 wu - add code for fv3_regional option -! 2018-01-04 Apodaca - add lightinfo_read call for GOES/GLM lightning observations +! 2018-01-04 Apodaca - add lightinfo_read call for goes/glm lightning observations ! 2018-07-24 W. Gu - move routine corr_ob_initialize/finalize from radinfo ! ! input argument list: @@ -185,17 +185,17 @@ subroutine gsisub(init_pass,last_pass) call tell('gsisub','lobserver=',lobserver) end if if (lobserver) then - if(init_pass) call observer_init() - if(print_verbose)then - call tell('gsisub','calling observer_run()') - end if - call observer_run(init_pass=init_pass,last_pass=last_pass) - if(print_verbose)then - call tell('gsisub','returned from observer_run()') - end if - if(last_pass) call observer_finalize() + if(init_pass) call observer_init() + if(print_verbose)then + call tell('gsisub','calling observer_run()') + end if + call observer_run(init_pass=init_pass,last_pass=last_pass) + if(print_verbose)then + call tell('gsisub','returned from observer_run()') + end if + if(last_pass) call observer_finalize() #ifndef HAVE_ESMF - call destroy_gesfinfo() ! paired with gesinfo() + call destroy_gesfinfo() ! paired with gesinfo() #endif else call glbsoi diff --git a/src/gsi/guess_grids.F90 b/src/gsi/guess_grids.F90 index 9eee5253fa..c4c6ab27e2 100644 --- a/src/gsi/guess_grids.F90 +++ b/src/gsi/guess_grids.F90 @@ -66,11 +66,11 @@ module guess_grids ! 2006-09-29 treadon - add flags to control 10m wind factor recompute ! 2007-05-30 h.liu - remove ozmz ! 2007-06-21 rancic - add pbl (ges_teta) -! 2006-12-01 todling - remove bias stuff; merging GMAO bias correction scheme +! 2006-12-01 todling - remove bias stuff; merging gmao bias correction scheme ! 2006-12-15 todling - add _initialized parameters to control allocations -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2008-02-07 eliu - fixed the unit difference between prsitmp -! (kPa) and toa_pressure (hPa). +! (kpa) and toa_pressure (hpa). ! 2009-08-19 guo - added sfc_grids_allocated_, ges_grids_allocated_, ! and gesfinfo_created_ to track the state of the data. ! for multi-pass observer. @@ -80,26 +80,26 @@ module guess_grids ! 2010-04-16 hou - add array definitions ges_co2 (co2 mixing ratio) and ! control variable igfsco2 ! 2010-04-22 todling - remove tracers,vtid,pdryini,xncld -! 2010-05-19 todling - add chem init and destroy (revamp Hou's implementation) +! 2010-05-19 todling - add chem init and destroy (revamp hou's implementation) ! 2010-08-31 cucurull - add logical use_compress ! 2010-09-15 pagowski - add cmaq ! 2010-12-20 cucurull - add integer nsig_ext ! 2011-01-05 cucurull - add real gpstop ! 2011-02-11 zhu - add ges_gust,ges_vis,ges_pblh -! 2011-03-13 li - add for nst FCST file +! 2011-03-13 li - add for nst fcst file ! 2011-04-29 todling - some of cloud fields move to wrf_guess_mod; some to met_guess ! 2011-05-01 todling - cwmr no longer in guess-grids; use metguess bundle now ! 2011-11-01 eliu - modified condition to allocate/deallocate arrays related to ! cloud water tendencies and derivatives ! 2011-12-27 kleist - add 4d guess array for saturation specific humidity -! 2012-01-11 Hu - add GSD PBL height -! 2013-02-22 Carley - Add NMMB to GSD PBL height calc +! 2012-01-11 Hu - add gsd pbl height +! 2013-02-22 Carley - Add nmmb to gsd pbl height calc ! 2013-10-19 todling - metguess now holds background ! all tendencies now in a bundle (see tendsmod) ! all derivaties now in a bundle (see derivsmod) ! 2015-01-15 Hu - Add coast_prox to hold coast proximity ! 2017-05-12 Y. Wang and X. Wang - add bottom and top levels of w and rho for -! radar DA later, POC: xuguang.wang@ou.edu +! radar da later ! 2017-10-10 wu - Add code for fv3_regional ! 2019-03-21 Wei/Martin - add code for external aerosol file input ! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment @@ -171,43 +171,43 @@ module guess_grids integer(i_kind) ntguessig ! location of actual guess time for sigma fields integer(i_kind) ntguessfc ! location of actual guess time for sfc fields - integer(i_kind) ntguesnst ! location of actual guess time for nst FCST fields - integer(i_kind) ntguesaer ! location of actual guess time for aer FCST fields + integer(i_kind) ntguesnst ! location of actual guess time for nst fcst fields + integer(i_kind) ntguesaer ! location of actual guess time for aer fcst fields - integer(i_kind), save:: ntguessig_ref ! replace ntguessig as the storage for its original value - integer(i_kind), save:: ntguessfc_ref ! replace ntguessfc as the storage for its original value + integer(i_kind), save:: ntguessig_ref ! replace ntguessig as the storage for its original value + integer(i_kind), save:: ntguessfc_ref ! replace ntguessfc as the storage for its original value integer(i_kind), save:: ntguesnst_ref ! replace ntguesnst as the storage for its original value integer(i_kind), save:: ntguesaer_ref ! replace ntguesaer as the storage for its original value integer(i_kind):: ifact10 = 0 ! 0 = use 10m wind factor from guess integer(i_kind):: nsig_ext = 13 ! use 13 layers above model top to compute the bending angle for gpsro - ! number of guess sigma/surface times are set in GSI_gridComp.rc + ! number of guess sigma/surface times are set in gsi_gridcomp.rc real(r_kind), allocatable, dimension(:), save:: hrdifsig_all ! a list of all times real(r_kind), allocatable, dimension(:), save:: hrdifsfc_all ! a list of all times real(r_kind), allocatable, dimension(:), save:: hrdifnst_all ! a list of all times real(r_kind), allocatable, dimension(:), save:: hrdifaer_all ! a list of all times - integer(i_kind), save:: nfldsig_all ! expected total count of time slots + integer(i_kind), save:: nfldsig_all ! expected total count of time slots integer(i_kind), save:: nfldsfc_all integer(i_kind), save:: nfldnst_all - integer(i_kind), save:: nfldsig ! actual count of in-cache time slots + integer(i_kind), save:: nfldsig ! actual count of in-cache time slots integer(i_kind), save:: nfldsfc - integer(i_kind), save:: nfldnst ! actual count of in-cache time slots for NST file + integer(i_kind), save:: nfldnst ! actual count of in-cache time slots for nst file - integer(i_kind), save:: nfldsig_now ! current count of filled time slots + integer(i_kind), save:: nfldsig_now ! current count of filled time slots integer(i_kind), save:: nfldsfc_now integer(i_kind), save:: nfldnst_now ! variables for external aerosol files integer(i_kind), save:: nfldaer_all - integer(i_kind), save:: nfldaer ! actual count of in-cache time slots for AER file + integer(i_kind), save:: nfldaer ! actual count of in-cache time slots for aer file integer(i_kind), save:: nfldaer_now - logical, save:: extrap_intime ! compute o-f interpolate within the time ranges of guess_grids, - ! or also extrapolate outside the time ranges. + logical, save:: extrap_intime ! compute o-f interpolate within the time ranges of guess_grids, + ! or also extrapolate outside the time ranges. real(r_kind), allocatable, dimension(:):: hrdifsig ! times for cached sigma guess_grid real(r_kind), allocatable, dimension(:):: hrdifsfc ! times for cached surface guess_grid @@ -251,8 +251,8 @@ module guess_grids real(r_kind),allocatable,dimension(:,:,:,:):: geop_hgti ! guess geopotential height at level interfaces real(r_kind),allocatable,dimension(:,:,:,:):: ges_geopi ! input guess geopotential height at level interfaces - real(r_kind),allocatable,dimension(:,:,:):: pbl_height ! GSD PBL height in hPa - ! Guess Fields ... + real(r_kind),allocatable,dimension(:,:,:):: pbl_height ! gsd pbl height in hpa + ! guess fields ... real(r_kind),allocatable,dimension(:,:):: wgt_lcbas ! weight given to base height of lowest cloud seen real(r_kind),allocatable,dimension(:,:,:,:):: ges_prsi ! interface pressure real(r_kind),allocatable,dimension(:,:,:,:):: ges_prsl ! layer midpoint pressure @@ -315,10 +315,10 @@ subroutine create_sfc_grids ! 2004-07-15 todling, protex-compliant prologue ! 2004-07-28 treadon - remove subroutine call list, pass variables via modules ! 2005-06-03 parrish - allocate and initialize sfct_lat and sfct_lon -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2008-12-5 todling - add time dimension to dsfct ! 2009-01-23 todling - zero out arrays -! 2012-03-06 akella - add call to initialize arrays for NST analysis +! 2012-03-06 akella - add call to initialize arrays for nst analysis ! 2017-08-31 li - move gsi_nstcoupler_init & gsi_nstcoupler_final to ! satthin.F90 and read_obs.F90 respectivaly ! @@ -438,10 +438,10 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) ! 2006-07-31 kleist - use ges_ps arrays instead of ln(ps) ! 2006-12-04 todling - remove bias initialization; rename routine ! 2006-12-15 todling - protection to allow initializing ges/tnd/drv at will -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2011-02-09 zhu - add ges_gust,ges_vis,ges_pblh ! 2012-05-14 todling - revisit cw check to check also on some hydrometeors -! 2013-10-19 todling - revisit initialization of certain vars wrt ESMF +! 2013-10-19 todling - revisit initialization of certain vars wrt esmf ! 2014-06-09 carley/zhu - add wgt_lcbas ! 2019-03-21 Wei/Martin - add capability to read external aerosol file ! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment @@ -466,7 +466,7 @@ subroutine create_ges_grids(switch_on_derivatives,tendsflag) nfldsig_all=nfldsig nfldsfc_all=nfldsfc nfldnst_all=nfldnst - nfldsig_now=0 ! _now variables are not used if not for ESMF + nfldsig_now=0 ! _now variables are not used if not for esmf nfldsfc_now=0 nfldnst_now=0 nfldaer_all=nfldaer @@ -618,7 +618,7 @@ subroutine create_metguess_grids(mype,istatus) istatus=0 -! When proper connection to ESMF is complete, +! When proper connection to esmf is complete, ! the following will not be needed here ! ------------------------------------------ call gsi_metguess_get('dim',nmguess,istatus) @@ -628,20 +628,20 @@ subroutine create_metguess_grids(mype,istatus) endif if(nmguess==0) return if (nmguess>0) then - allocate (mguess(nmguess)) - call gsi_metguess_get('gsinames',mguess,istatus) - if(istatus/=0) then - if(mype==0) write(6,*) myname_, ': trouble getting name of met-guess fields' - return - endif + allocate (mguess(nmguess)) + call gsi_metguess_get('gsinames',mguess,istatus) + if(istatus/=0) then + if(mype==0) write(6,*) myname_, ': trouble getting name of met-guess fields' + return + endif -! Allocate memory for guess fields -! -------------------------------- - call gsi_metguess_create_grids(lat2,lon2,nsig,nfldsig,istatus) - if(istatus/=0) then - if(mype==0) write(6,*) myname_, ': trouble allocating mem for met-guess' - return - endif +! Allocate memory for guess fields +! -------------------------------- + call gsi_metguess_create_grids(lat2,lon2,nsig,nfldsig,istatus) + if(istatus/=0) then + if(mype==0) write(6,*) myname_, ': trouble allocating mem for met-guess' + return + endif endif end subroutine create_metguess_grids @@ -676,13 +676,13 @@ subroutine destroy_metguess_grids(mype,istatus) ! todling org: w/nmc20 date: 2011-04-29 ! !EOP - character(len=*),parameter::myname_=myname//'destroy_metguess_grids' - istatus=0 - call gsi_metguess_destroy_grids(istatus) - if(istatus/=0) then - if(mype==0) write(6,*) myname_, ': trouble deallocating mem for met-guess' - return - endif + character(len=*),parameter::myname_=myname//'destroy_metguess_grids' + istatus=0 + call gsi_metguess_destroy_grids(istatus) + if(istatus/=0) then + if(mype==0) write(6,*) myname_, ': trouble deallocating mem for met-guess' + return + endif end subroutine destroy_metguess_grids !------------------------------------------------------------------------- @@ -723,13 +723,13 @@ subroutine create_chemges_grids(mype,istatus) ! !EOP !------------------------------------------------------------------------- - character(len=*),parameter::myname_=myname//'*create_chemges_grids' + character(len=*),parameter::myname_=myname//'*create_chemges_grids' integer(i_kind) :: ntgases ! number of tracer gases (namelist) character(len=max_varname_length),allocatable:: tgases(:) ! names of tracer gases - istatus=0 + istatus=0 -! When proper connection to ESMF is complete, +! When proper connection to esmf is complete, ! the following will not be needed here ! ------------------------------------------ call gsi_chemguess_get('dim',ntgases,istatus) @@ -786,8 +786,8 @@ subroutine destroy_chemges_grids(istatus) ! todling org: w/nmc20 date: 2010-05-19 ! !EOP - istatus=0 - call gsi_chemguess_destroy_grids(istatus) + istatus=0 + call gsi_chemguess_destroy_grids(istatus) end subroutine destroy_chemges_grids !------------------------------------------------------------------------- @@ -820,7 +820,7 @@ subroutine destroy_ges_grids ! 2006-07-31 kleist - use ges_ps arrays instead of ln(ps) ! 2006-12-04 todling - remove bias destroy; rename routine ! 2006-12-15 todling - using internal switches to deallc(tnds/drvs) -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2012-05-14 todling - revist cw check to check also on some hyrometeors ! 2019-09-10 martin - added new fields to save guess tsen/geop_hgt for writing increment ! @@ -873,11 +873,11 @@ subroutine destroy_sfc_grids ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-06-03 parrish - deallocate sfct_lat and sfct_lon -! 2007-03-15 todling - merged in da Silva/Cruz ESMF changes +! 2007-03-15 todling - merged in da silva/cruz esmf changes ! 2008-06-30 derber - remove sfct deallocate to allow earlier call ! 2009-01-17 todling - move isli2,sno2 into destroy_sfct ! 2010-03-15 todling - esmf protection -! 2012-03-06 akella - add call to destroy NST analysis arrays +! 2012-03-06 akella - add call to destroy nst analysis arrays ! ! !REMARKS: ! language: f90 @@ -955,7 +955,7 @@ subroutine create_gesfinfo nfldsig_all=nfldsig nfldsfc_all=nfldsfc nfldnst_all=nfldnst - nfldsig_now=0 ! _now variables are not used if not for ESMF + nfldsig_now=0 ! _now variables are not used if not for esmf nfldsfc_now=0 nfldnst_now=0 nfldaer_all=nfldaer @@ -965,11 +965,11 @@ subroutine create_gesfinfo hrdifnst(nfldnst),ifilenst(nfldnst), & hrdifsig(nfldsig),ifilesig(nfldsig), & hrdifaer(nfldaer),ifileaer(nfldaer), & - hrdifsfc_all(nfldsfc_all), & + hrdifsfc_all(nfldsfc_all), & hrdifnst_all(nfldnst_all), & - hrdifsig_all(nfldsig_all), & + hrdifsig_all(nfldsig_all), & hrdifaer_all(nfldaer_all), & - stat=istatus) + stat=istatus) if (istatus/=0) & write(6,*)'CREATE_GESFINFO(hrdifsfc,..): allocate error, istatus=',& istatus @@ -1015,7 +1015,7 @@ subroutine destroy_gesfinfo #ifndef HAVE_ESMF deallocate(hrdifsfc,ifilesfc,hrdifnst,hrdifaer,ifilenst,hrdifsig,ifilesig,ifileaer,& - hrdifsfc_all,hrdifnst_all,hrdifsig_all,hrdifaer_all,stat=istatus) + hrdifsfc_all,hrdifnst_all,hrdifsig_all,hrdifaer_all,stat=istatus) if (istatus/=0) & write(6,*)'DESTROY_GESFINFO: deallocate error, istatus=',& istatus @@ -1069,7 +1069,7 @@ subroutine load_prsges ! 2006-07-31 kleist - use ges_ps instead of ln(ps) ! 2007-05-08 kleist - add fully generalized coordinate for pressure calculation ! 2011-07-07 todling - add cap for log(pressure) calculation -! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS +! 2017-03-23 Hu - add code to use hybrid vertical coodinate in wrf mass ! core ! ! !REMARKS: @@ -1088,8 +1088,8 @@ subroutine load_prsges ! Declare local variables real(r_kind) kap1,kapr,trk - real(r_kind),dimension(:,:) ,pointer::ges_ps=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() + real(r_kind),dimension(:,:) ,pointer::ges_ps=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>null() real(r_kind) pinc(lat2,lon2) integer(i_kind) i,j,k,ii,jj,itv,ips,kp logical ihaveprs(nfldsig) @@ -1107,20 +1107,20 @@ subroutine load_prsges endif !!!!!!!!!!!! load delp to ges_prsi in read_fv3_netcdf_guess !!!!!!!!!!!!!!!!! - if (fv3_regional ) then - do j=1,lon2 - do i=1,lat2 - pinc(i,j)=(ges_ps(i,j)-ges_prsi(i,j,1,jj)) - enddo - enddo - do k=1,nsig+1 + if (fv3_regional ) then do j=1,lon2 do i=1,lat2 - ges_prsi(i,j,k,jj)=ges_prsi(i,j,k,jj)+eta2_ll(k)*pinc(i,j) + pinc(i,j)=(ges_ps(i,j)-ges_prsi(i,j,1,jj)) enddo enddo - enddo - endif + do k=1,nsig+1 + do j=1,lon2 + do i=1,lat2 + ges_prsi(i,j,k,jj)=ges_prsi(i,j,k,jj)+eta2_ll(k)*pinc(i,j) + enddo + enddo + enddo + endif do k=1,nsig+1 do j=1,lon2 @@ -1265,8 +1265,8 @@ subroutine load_prsges end if ! end regional/global block -! Compute density for dBZ assimilation purposes - multiply by 1000 to convert -! to Pa +! Compute density for dbz assimilation purposes - multiply by 1000 to convert +! to pa do ii=1,ndat if ( index(dtype(ii), 'dbz') /= 0 )then do jj=1,nfldsig @@ -1277,7 +1277,7 @@ subroutine load_prsges do j=1,lon2 do i=1,lat2 do k=1,nsig - ges_rho(i,j,k,jj)=(ges_prsl(i,j,k,jj)/(ges_tv(i,j,k)*rd))*r1000 + ges_rho(i,j,k,jj)=(ges_prsl(i,j,k,jj)/(ges_tv(i,j,k)*rd))*r1000 end do end do end do @@ -1389,10 +1389,10 @@ subroutine load_geop_hgt ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2004-10-28 treadon - replace "tiny" with "tiny_r_kind" -! 2004-12-15 treadon - replace use of Paul van Delst's Geopotential +! 2004-12-15 treadon - replace use of paul van delst's geopotential ! function with simple integration of hydrostatic -! equation (done to be consistent with Lidia -! Cucurull's GPS work) +! equation (done to be consistent with lidia +! cucurull's gps work) ! 2005-05-24 pondeca - add regional surface analysis option ! 2010-08-27 cucurull - add option to compute and use compressibility factors in geopot heights ! @@ -1412,10 +1412,10 @@ subroutine load_geop_hgt integer(i_kind) i,j,k,jj,ier,istatus real(r_kind) h,dz,rdog real(r_kind),dimension(nsig+1):: height - real(r_kind) cmpr, x_v, rl_hm, fact, pw, tmp_K, tmp_C, prs_sv, prs_a, ehn_fct, prs_v - real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_q=>NULL() - real(r_kind),dimension(:,: ),pointer::ges_z=>NULL() + real(r_kind) cmpr, x_v, rl_hm, fact, pw, tmp_k, tmp_c, prs_sv, prs_a, ehn_fct, prs_v + real(r_kind),dimension(:,:,:),pointer::ges_tv=>null() + real(r_kind),dimension(:,:,:),pointer::ges_q=>null() + real(r_kind),dimension(:,: ),pointer::ges_z=>null() if (twodvar_regional) return @@ -1423,8 +1423,8 @@ subroutine load_geop_hgt if (use_compress) then -! Compute compressibility factor (Picard et al 2008) and geopotential heights at midpoint -! of each layer +! Compute compressibility factor (picard et al 2008) and geopotential heights at midpoint +! of each layer do jj=1,nfldsig ier=0 @@ -1440,19 +1440,19 @@ subroutine load_geop_hgt k = 1 fact = one + fv * ges_q(i,j,k) pw = eps + ges_q(i,j,k)*( one - eps ) - tmp_K = ges_tv(i,j,k) / fact - tmp_C = tmp_K - t0c - prs_sv = exp(psv_a*tmp_K**2 + psv_b*tmp_K + psv_c + psv_d/tmp_K) ! Pvap sat, eq A1.1 (Pa) - prs_a = thousand * exp(half*(log(ges_prsi(i,j,k,jj)) + log(ges_prsl(i,j,k,jj)))) ! (Pa) - ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_C**2 ! enhancement factor (eq. A1.2) - prs_v = ges_q(i,j,k) * prs_a / pw ! vapor pressure (Pa) + tmp_k = ges_tv(i,j,k) / fact + tmp_c = tmp_k - t0c + prs_sv = exp(psv_a*tmp_k**2 + psv_b*tmp_k + psv_c + psv_d/tmp_k) ! pvap sat, eq A1.1 (pa) + prs_a = thousand * exp(half*(log(ges_prsi(i,j,k,jj)) + log(ges_prsl(i,j,k,jj)))) ! (pa) + ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_c**2 ! enhancement factor (eq. A1.2) + prs_v = ges_q(i,j,k) * prs_a / pw ! vapor pressure (pa) rl_hm = prs_v / prs_sv ! relative humidity x_v = rl_hm * ehn_fct * prs_sv / prs_a ! molar fraction of water vapor (eq. A1.3) - ! Compressibility factor (eq A1.4 from Picard et al 2008) - cmpr = one - (prs_a/tmp_K) * (cpf_a0 + cpf_a1*tmp_C + cpf_a2*tmp_C**2 & - + (cpf_b0 + cpf_b1*tmp_C)*x_v + (cpf_c0 + cpf_c1*tmp_C)*x_v**2 ) & - + (prs_a**2/tmp_K**2) * (cpf_d + cpf_e*x_v**2) + ! Compressibility factor (eq A1.4 from picard et al 2008) + cmpr = one - (prs_a/tmp_k) * (cpf_a0 + cpf_a1*tmp_c + cpf_a2*tmp_c**2 & + + (cpf_b0 + cpf_b1*tmp_c)*x_v + (cpf_c0 + cpf_c1*tmp_c)*x_v**2 ) & + + (prs_a**2/tmp_k**2) * (cpf_d + cpf_e*x_v**2) h = rdog * ges_tv(i,j,k) dz = h * cmpr * log(ges_prsi(i,j,k,jj)/ges_prsl(i,j,k,jj)) @@ -1461,17 +1461,17 @@ subroutine load_geop_hgt do k=2,nsig fact = one + fv * half * (ges_q(i,j,k-1)+ges_q(i,j,k)) pw = eps + half * (ges_q(i,j,k-1)+ges_q(i,j,k)) * (one - eps) - tmp_K = half * (ges_tv(i,j,k-1)+ges_tv(i,j,k)) / fact - tmp_C = tmp_K - t0c - prs_sv = exp(psv_a*tmp_K**2 + psv_b*tmp_K + psv_c + psv_d/tmp_K) ! eq A1.1 (Pa) - prs_a = thousand * exp(half*(log(ges_prsl(i,j,k-1,jj))+log(ges_prsl(i,j,k,jj)))) ! (Pa) - ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_C**2 ! enhancement factor (eq. A1.2) - prs_v = half*(ges_q(i,j,k-1)+ges_q(i,j,k) ) * prs_a / pw ! (Pa) + tmp_k = half * (ges_tv(i,j,k-1)+ges_tv(i,j,k)) / fact + tmp_c = tmp_k - t0c + prs_sv = exp(psv_a*tmp_k**2 + psv_b*tmp_k + psv_c + psv_d/tmp_k) ! eq A1.1 (pa) + prs_a = thousand * exp(half*(log(ges_prsl(i,j,k-1,jj))+log(ges_prsl(i,j,k,jj)))) ! (pa) + ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_c**2 ! enhancement factor (eq. A1.2) + prs_v = half*(ges_q(i,j,k-1)+ges_q(i,j,k) ) * prs_a / pw ! (pa) rl_hm = prs_v / prs_sv ! relative humidity x_v = rl_hm * ehn_fct * prs_sv / prs_a ! molar fraction of water vapor (eq. A1.3) - cmpr = one - (prs_a/tmp_K) * ( cpf_a0 + cpf_a1*tmp_C + cpf_a2*tmp_C**2 & - + (cpf_b0 + cpf_b1*tmp_C)*x_v + (cpf_c0 + cpf_c1*tmp_C)*x_v**2 ) & - + (prs_a**2/tmp_K**2) * (cpf_d + cpf_e*x_v**2) + cmpr = one - (prs_a/tmp_k) * ( cpf_a0 + cpf_a1*tmp_c + cpf_a2*tmp_c**2 & + + (cpf_b0 + cpf_b1*tmp_c)*x_v + (cpf_c0 + cpf_c1*tmp_c)*x_v**2 ) & + + (prs_a**2/tmp_k**2) * (cpf_d + cpf_e*x_v**2) h = rdog * half * (ges_tv(i,j,k-1)+ges_tv(i,j,k)) dz = h * cmpr * log(ges_prsl(i,j,k-1,jj)/ges_prsl(i,j,k,jj)) height(k) = height(k-1) + dz @@ -1485,7 +1485,7 @@ subroutine load_geop_hgt enddo if(ier/=0) return -! Compute compressibility factor (Picard et al 2008) and geopotential heights at interface +! Compute compressibility factor (picard et al 2008) and geopotential heights at interface ! between layers do jj=1,nfldsig @@ -1505,17 +1505,17 @@ subroutine load_geop_hgt do k=2,nsig fact = one + fv * ges_q(i,j,k-1) pw = eps + ges_q(i,j,k-1)*(one - eps) - tmp_K = ges_tv(i,j,k-1) / fact - tmp_C = tmp_K - t0c - prs_sv = exp(psv_a*tmp_K**2 + psv_b*tmp_K + psv_c + psv_d/tmp_K) ! eq A1.1 (Pa) + tmp_k = ges_tv(i,j,k-1) / fact + tmp_c = tmp_k - t0c + prs_sv = exp(psv_a*tmp_k**2 + psv_b*tmp_k + psv_c + psv_d/tmp_k) ! eq A1.1 (pa) prs_a = thousand * exp(half*(log(ges_prsi(i,j,k-1,jj))+log(ges_prsi(i,j,k,jj)))) - ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_C**2 ! enhancement factor (eq. A1.2) - prs_v = ges_q(i,j,k-1) * prs_a / pw ! vapor pressure (Pa) + ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_c**2 ! enhancement factor (eq. A1.2) + prs_v = ges_q(i,j,k-1) * prs_a / pw ! vapor pressure (pa) rl_hm = prs_v / prs_sv ! relative humidity x_v = rl_hm * ehn_fct * prs_sv / prs_a ! molar fraction of water vapor (eq. A1.3) - cmpr = one - (prs_a/tmp_K) * ( cpf_a0 + cpf_a1*tmp_C + cpf_a2*tmp_C**2 & - + (cpf_b0 + cpf_b1*tmp_C)*x_v + (cpf_c0 + cpf_c1*tmp_C)*x_v**2 ) & - + (prs_a**2/tmp_K**2) * (cpf_d + cpf_e*x_v**2) + cmpr = one - (prs_a/tmp_k) * ( cpf_a0 + cpf_a1*tmp_c + cpf_a2*tmp_c**2 & + + (cpf_b0 + cpf_b1*tmp_c)*x_v + (cpf_c0 + cpf_c1*tmp_c)*x_v**2 ) & + + (prs_a**2/tmp_k**2) * (cpf_d + cpf_e*x_v**2) h = rdog * ges_tv(i,j,k-1) dz = h * cmpr * log(ges_prsi(i,j,k-1,jj)/ges_prsi(i,j,k,jj)) height(k) = height(k-1) + dz @@ -1524,17 +1524,17 @@ subroutine load_geop_hgt k=nsig+1 fact = one + fv* ges_q(i,j,k-1) pw = eps + ges_q(i,j,k-1)*(one - eps) - tmp_K = ges_tv(i,j,k-1) / fact - tmp_C = tmp_K - t0c - prs_sv = exp(psv_a*tmp_K**2 + psv_b*tmp_K + psv_c + psv_d/tmp_K) ! eq A1.1 (Pa) - prs_a = thousand * exp(half*(log(ges_prsi(i,j,k-1,jj))+log(ges_prsl(i,j,k-1,jj)))) ! (Pa) - ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_C**2 ! enhancement factor (eq. A1.2) + tmp_k = ges_tv(i,j,k-1) / fact + tmp_c = tmp_k - t0c + prs_sv = exp(psv_a*tmp_k**2 + psv_b*tmp_k + psv_c + psv_d/tmp_k) ! eq A1.1 (pa) + prs_a = thousand * exp(half*(log(ges_prsi(i,j,k-1,jj))+log(ges_prsl(i,j,k-1,jj)))) ! (pa) + ehn_fct = ef_alpha + ef_beta*prs_a + ef_gamma*tmp_c**2 ! enhancement factor (eq. A1.2) prs_v = ges_q(i,j,k-1) * prs_a / pw rl_hm = prs_v / prs_sv ! relative humidity x_v = rl_hm * ehn_fct * prs_sv / prs_a ! molar fraction of water vapor (eq. A1.3) - cmpr = one - (prs_a/tmp_K) * ( cpf_a0 + cpf_a1*tmp_C + cpf_a2*tmp_C**2 & - + (cpf_b0 + cpf_b1*tmp_C)*x_v + (cpf_c0 + cpf_c1*tmp_C)*x_v**2 ) & - + (prs_a**2/tmp_K**2) * (cpf_d + cpf_e*x_v**2) + cmpr = one - (prs_a/tmp_k) * ( cpf_a0 + cpf_a1*tmp_c + cpf_a2*tmp_c**2 & + + (cpf_b0 + cpf_b1*tmp_c)*x_v + (cpf_c0 + cpf_c1*tmp_c)*x_v**2 ) & + + (prs_a**2/tmp_k**2) * (cpf_d + cpf_e*x_v**2) h = rdog * ges_tv(i,j,k-1) dz = h * cmpr * log(ges_prsi(i,j,k-1,jj)/ges_prsl(i,j,k-1,jj)) height(k) = height(k-1) + dz @@ -1642,7 +1642,7 @@ subroutine load_gsdpbl_hgt(mype) ! ! !REVISION HISTORY: ! 2011-06-06 Ming Hu -! 2013-02-22 Jacob Carley - Added NMMB +! 2013-02-22 Jacob Carley - Added nmmb ! ! !REMARKS: ! language: f90 @@ -1659,9 +1659,9 @@ subroutine load_gsdpbl_hgt(mype) real(r_kind),dimension(nsig):: thetav real(r_kind),dimension(nsig):: pbk real(r_kind) :: thsfc, d - real(r_kind),dimension(:,: ),pointer::ges_ps_01=>NULL() - real(r_kind),dimension(:,: ),pointer::ges_ps=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() + real(r_kind),dimension(:,: ),pointer::ges_ps_01=>null() + real(r_kind),dimension(:,: ),pointer::ges_ps=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>null() if (twodvar_regional) return if (fv3_regional) then @@ -1685,24 +1685,24 @@ subroutine load_gsdpbl_hgt(mype) do k=1,nsig if (wrf_mass_regional) pbk(k) = aeta1_ll(k)*(ges_ps_01(i,j)*ten-pt_ll)+aeta2_ll(k)+pt_ll - if (nems_nmmb_regional) then - pbk(k) = aeta1_ll(k)*pdtop_ll + aeta2_ll(k)*(ten*ges_ps(i,j) & - -pdtop_ll-pt_ll) + pt_ll - end if - - thetav(k) = ges_tv(i,j,k)*(r1000/pbk(k))**rd_over_cp_mass + if (nems_nmmb_regional) then + pbk(k) = aeta1_ll(k)*pdtop_ll + aeta2_ll(k)*(ten*ges_ps(i,j) & + -pdtop_ll-pt_ll) + pt_ll + end if + + thetav(k) = ges_tv(i,j,k)*(r1000/pbk(k))**rd_over_cp_mass end do pbl_height(i,j,jj) = zero thsfc = thetav(1) k=1 - DO while (abs(pbl_height(i,j,jj)) < 0.0001_r_kind) - if( thetav(k) > thsfc + 1.0_r_kind ) then - pbl_height(i,j,jj) = float(k) - (thetav(k) - (thsfc + 1.0_r_kind))/ & - max((thetav(k)-thetav(k-1)),0.01_r_kind) + do while (abs(pbl_height(i,j,jj)) < 0.0001_r_kind) + if( thetav(k) > thsfc + 1.0_r_kind ) then + pbl_height(i,j,jj) = real(k,r_kind) - (thetav(k) - (thsfc + 1.0_r_kind))/ & + max((thetav(k)-thetav(k-1)),0.01_r_kind) endif k=k+1 - ENDDO + enddo if(abs(pbl_height(i,j,jj)) < 0.0001_r_kind) pbl_height(i,j,jj)=two k=int(pbl_height(i,j,jj)) if( k < 1 .or. k > nsig-1) then @@ -1723,7 +1723,7 @@ end subroutine load_gsdpbl_hgt !------------------------------------------------------------------------- !BOP ! -! !IROUTINE: add_rtm_layers --- Add pressure layers for RTM use +! !IROUTINE: add_rtm_layers --- Add pressure layers for rtm use ! ! !INTERFACE: ! @@ -1747,12 +1747,12 @@ subroutine add_rtm_layers(prsitmp,prsltmp,prsitmp_ext,prsltmp_ext,klevel) real(r_kind) ,dimension(msig) ,intent( out) :: prsltmp_ext -! !DESCRIPTION: Add pressure layers for use in RTM +! !DESCRIPTION: Add pressure layers for use in rtm ! ! !REVISION HISTORY: ! 2005-06-01 treadon ! 2006-05-10 derber modify how levels are added above model top -! 2013-03-27 rancic fix for toa units: crtm(hPa); prsitmp(kPa) +! 2013-03-27 rancic fix for toa units: crtm(hpa); prsitmp(kpa) ! ! !REMARKS: ! language: f90 @@ -1768,12 +1768,12 @@ subroutine add_rtm_layers(prsitmp,prsltmp,prsitmp_ext,prsltmp_ext,klevel) integer(i_kind) k,kk,l real(r_kind) dprs,toa_prs_kpa -! Convert toa_pressure to kPa +! Convert toa_pressure to kpa ! --------------------------- toa_prs_kpa = toa_pressure*one_tenth ! Check if model top pressure above rtm top pressure, where prsitmp -! is in kPa and toa_pressure is in hPa. +! is in kpa and toa_pressure is in hpa. if (prsitmp(nsig) < toa_prs_kpa)then write(6,*)'ADD_RTM_LAYERS: model top pressure(hPa)=', & ten*prsitmp(nsig),& @@ -1849,11 +1849,11 @@ subroutine load_fact10 integer(i_kind):: i,j,it,itt,nt,regime,ier,istatus integer(i_kind),dimension(nfldsfc):: indx real(r_kind):: u10ges,v10ges,t2ges,q2ges - real(r_kind),dimension(:,: ),pointer::ges_ps=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_u=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_v=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_q=>NULL() + real(r_kind),dimension(:,: ),pointer::ges_ps=>null() + real(r_kind),dimension(:,:,:),pointer::ges_u=>null() + real(r_kind),dimension(:,:,:),pointer::ges_v=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv=>null() + real(r_kind),dimension(:,:,:),pointer::ges_q=>null() nt=0 indx=1 @@ -1908,7 +1908,7 @@ subroutine load_fact10 if(ier/=0) call die(myname_,'not all fields available, ier=',ier) do j=1,lon2 do i=1,lat2 - call SFC_WTQ_FWD (& + call sfc_wtq_fwd (& ges_ps(i,j),& sfct(i,j,itt),& ges_lnprsl(i,j,1,itt),& @@ -1985,16 +1985,16 @@ subroutine comp_fact10(dlat,dlon,dtime,skint,sfcrough,islimsk,mype,factw) real(r_kind):: u10ges,v10ges,t2ges,q2ges real(r_kind):: pgesin,ugesin,vgesin,qgesin,tgesin,prsigesin1 real(r_kind):: prsigesin2,lnpgesin1,lnpgesin2,tgesin2,qgesin2,geopgesin,ts - real(r_kind),dimension(:,: ),pointer::ges_ps_itsig=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_u_itsig=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_v_itsig=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv_itsig=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_q_itsig=>NULL() - real(r_kind),dimension(:,: ),pointer::ges_ps_itsigp=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_u_itsigp=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_v_itsigp=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_tv_itsigp=>NULL() - real(r_kind),dimension(:,:,:),pointer::ges_q_itsigp=>NULL() + real(r_kind),dimension(:,: ),pointer::ges_ps_itsig=>null() + real(r_kind),dimension(:,:,:),pointer::ges_u_itsig=>null() + real(r_kind),dimension(:,:,:),pointer::ges_v_itsig=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv_itsig=>null() + real(r_kind),dimension(:,:,:),pointer::ges_q_itsig=>null() + real(r_kind),dimension(:,: ),pointer::ges_ps_itsigp=>null() + real(r_kind),dimension(:,:,:),pointer::ges_u_itsigp=>null() + real(r_kind),dimension(:,:,:),pointer::ges_v_itsigp=>null() + real(r_kind),dimension(:,:,:),pointer::ges_tv_itsigp=>null() + real(r_kind),dimension(:,:,:),pointer::ges_q_itsigp=>null() islimsk2=islimsk if(islimsk2 > 2)islimsk2=islimsk2-3 @@ -2168,7 +2168,7 @@ subroutine comp_fact10(dlat,dlon,dtime,skint,sfcrough,islimsk,mype,factw) geop_hgtl(ixp,iy ,1,itsigp)*w10+ & geop_hgtl(ix ,iyp,1,itsigp)*w01+ & geop_hgtl(ixp,iyp,1,itsigp)*w11)*dtsigp - call SFC_WTQ_FWD (pgesin,ts,lnpgesin1,tgesin,qgesin,ugesin,vgesin, & + call sfc_wtq_fwd (pgesin,ts,lnpgesin1,tgesin,qgesin,ugesin,vgesin, & lnpgesin2,tgesin2,qgesin2,geopgesin,sfcrough,islimsk, & factw,u10ges,v10ges,t2ges,q2ges,regime,iqtflg) endif @@ -2233,7 +2233,7 @@ subroutine guess_grids_stats3d_(name,a,mype) end do end do end do - work_a(nsig+1)=float(lon1*lat1) + work_a(nsig+1)=real(lon1*lat1,r_kind) call mpi_allreduce(work_a,work_a1,nsig+1,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) @@ -2301,7 +2301,7 @@ subroutine guess_grids_stats2d_(name,a,mype) work_a(1) = work_a(1) + a(i,j) end do end do - work_a(2)=float(lon1*lat1) + work_a(2)=real(lon1*lat1,r_kind) call mpi_allreduce(work_a,work_a1,2,mpi_rtype,mpi_sum,& mpi_comm_world,ierror) @@ -2438,7 +2438,7 @@ subroutine print2r8_(name,fld,undef) ! real(r_kind) avg,rms write(6,100) trim(name),minval(fld),maxval(fld),sum(fld) - call pstats_(fld,UNDEF,avg,rms) + call pstats_(fld,undef,avg,rms) write(6,99) trim(name),avg,rms 100 format(a,': range,sum = ',1P3E16.4) 99 format(a,': avg, rms = ',1P2E16.4) @@ -2484,7 +2484,7 @@ subroutine print3r8_(name,fld,undef,allk) if(prntlevs) then do k=1,size(fld,3) write(6,101) trim(name),k,minval(fld(:,:,k)),maxval(fld(:,:,k)),sum(fld(:,:,k)) - call pstats_(fld(:,:,k),UNDEF,avg,rms) + call pstats_(fld(:,:,k),undef,avg,rms) write(6,99) trim(name),avg,rms end do else @@ -2537,7 +2537,7 @@ subroutine print4r8_(name,fld,undef,allk) do it=1,size(fld,4) do k=1,size(fld,3) write(6,101) trim(name),it,k,minval(fld(:,:,k,it)),maxval(fld(:,:,k,it)),sum(fld(:,:,k,it)) - call pstats_(fld(:,:,k,it),UNDEF,avg,rms) + call pstats_(fld(:,:,k,it),undef,avg,rms) write(6,99) trim(name),avg,rms end do end do diff --git a/src/gsi/half_nmm_grid2.f90 b/src/gsi/half_nmm_grid2.f90 index c3613bfd02..a68518f67f 100644 --- a/src/gsi/half_nmm_grid2.f90 +++ b/src/gsi/half_nmm_grid2.f90 @@ -4,14 +4,14 @@ subroutine half_nmm_grid2(gin,nx,ny,gout,igtype,iorder) ! subprogram: half_nmm_grid2 make a-grid from every other row of e-grid ! prgmmr: parrish org: np22 date: 2004-06-22 ! -! abstract: creates an unstaggered A grid from the staggered E grid used by the wrf nmm. -! This is done by keeping every other row of the original E grid. If this +! abstract: creates an unstaggered a grid from the staggered e grid used by the wrf nmm. +! This is done by keeping every other row of the original e grid. If this ! is a mass variable (igtype=1), then no interpolation is required. If this ! is a wind variable (igtype=2), then interpolation is necessary. This procedure ! is necessary because the gsi is not yet able to work with anything other than ! unstaggered grids. This solution introduces greater interpolation error ! compared to the option fill_nmm_grid2, but has the advantage of 4 times fewer -! grid points compared to the output of fill_nmm__grid2. This routine will be +! grid points compared to the output of fill_nmm_grid2. This routine will be ! eliminated when the gsi has the capability to work directly with staggered grids. ! ! program history log: diff --git a/src/gsi/hilbert_curve.f90 b/src/gsi/hilbert_curve.f90 index 6605949b1d..5378563b8a 100644 --- a/src/gsi/hilbert_curve.f90 +++ b/src/gsi/hilbert_curve.f90 @@ -30,9 +30,9 @@ subroutine hilbert(mskip,nob,xob,yob,test_set) ! the efficient sorting procedure, bsort. The resulting linked list of obs ! is accessed by "firsta" and terminated when "next(iob)" ==0. ! -! From this linked list, "A", construct linked subsets, "B", that can be used -! us validation subsets. Members of old A not able to be put into any of the -! mskip B subset are gathered into a reconstritued lined list, new "A". All +! From this linked list, "a", construct linked subsets, "b", that can be used +! us validation subsets. Members of old a not able to be put into any of the +! mskip b subset are gathered into a reconstritued lined list, new "a". All ! this is done in subroutine getvalsets. ! !$$$ end documentation block @@ -50,10 +50,10 @@ subroutine hilbert(mskip,nob,xob,yob,test_set) !real(r_kind),parameter :: delta=.001_r_kind,xhskip=.00001_r_kind !real(r_kind),parameter :: delta=.001_r_kind,xhskip=.005_r_kind -integer(i_kind) ,intent(IN ) :: mskip,nob -real(r_kind), dimension(nob) ,intent(IN ) :: xob,yob +integer(i_kind) ,intent(in ) :: mskip,nob +real(r_kind), dimension(nob) ,intent(in ) :: xob,yob -integer(i_kind), dimension(nob),intent( OUT) :: test_set +integer(i_kind), dimension(nob),intent( out) :: test_set real(r_kind),dimension(nob) :: xh integer(i_kind),dimension(nob) :: next diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 9231392f6b..f9159fe9e0 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -26,15 +26,15 @@ module hybrid_ensemble_isotropic ! 2010-07-29 kleist - combine hybrid_ensemble_isotropic global/regional modules ! 2011-02-28 parrish - introduce more complete use of gsi_bundlemod to eliminate hard-wired variables ! 2011-06-28 parrish - add code to allow sqrt of localization correlation so hybrid ensemble option -! can be extended to sqrt(B) minimization option. +! can be extended to sqrt(b) minimization option. ! 2011-08-31 todling - revisit en_perts (single-prec) in light of extended bundle ! 2011-10-26 kleist - add time dimension to en_perts for 4d extensions ! 2011-11-01 kleist - 4d-ensemble-var available as part of ensemble forward models(s) and adjoints, -! as described in Liu et al. (2008), MWR, vol.36 and Buehner et al. (2010), -! MWR, vol.138. This specific implementation uses the linearized observation -! operators as in Buehner et al., but also has the capability to allow for a -! contribution from a static, time-invariant (3DVAR) B. Capability also exists -! for actual hybrid Ens-4DVAR (with TL/AD). +! as described in liu et al. (2008), mwr, vol.36 and buehner et al. (2010), +! mwr, vol.138. This specific implementation uses the linearized observation +! operators as in buehner et al., but also has the capability to allow for a +! contribution from a static, time-invariant (3dvar) b. Capability also exists +! for actual hybrid ens-4dvar (with tl/ad). ! 2012-01-17 wu - option "pwgtflg": psfc with vertically integrated contribution ! in forward and adjoint routines ! 2012-02-08 parrish - add changes to allow regional dual res @@ -99,7 +99,7 @@ module hybrid_ensemble_isotropic use gsi_bundlemod, only: gsi_gridcreate use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d - use string_utility, only: StrUpCase + use string_utility, only: strupcase implicit none @@ -142,13 +142,13 @@ module hybrid_ensemble_isotropic public :: acceptable_for_essl_fft interface sqrt_beta_s_mult - module procedure sqrt_beta_s_mult_cvec - module procedure sqrt_beta_s_mult_bundle + module procedure sqrt_beta_s_mult_cvec + module procedure sqrt_beta_s_mult_bundle end interface interface sqrt_beta_e_mult - module procedure sqrt_beta_e_mult_cvec - module procedure sqrt_beta_e_mult_bundle + module procedure sqrt_beta_e_mult_cvec + module procedure sqrt_beta_e_mult_bundle end interface ! set passed variables to public @@ -206,10 +206,10 @@ subroutine init_rf_z(z_len) ! For the current s_ens_v > 0, the measure is vertical grid units. ! s_ens_v = 20 and s_ens_v = -0.44 are roughly comparable, and ! connection of .44 is .44 = (sqrt(.15)/sqrt(2))*1.6, where 1.6 is the value used -! by Jeff Whitaker for his distance in which the Gaspari-Cohn function 1st = 0. +! by jeff whitaker for his distance in which the gaspari-cohn function 1st = 0. ! 2011-07-19 tong - add the calculation of pressure vertical profile for regional model, ! when vertical localization length scale is in units of ln(p) -! 2017-03-23 Hu - add code to use hybrid vertical coodinate in WRF MASS +! 2017-03-23 Hu - add code to use hybrid vertical coodinate in wrf mass ! core ! ! input argument list: @@ -245,7 +245,7 @@ subroutine init_rf_z(z_len) kap1=rd_over_cp+one kapr=one/rd_over_cp nxy=grd_ens%latlon11 - rnsig=float(nsig) + rnsig=real(nsig,r_kind) ! use new factorization: @@ -261,19 +261,19 @@ subroutine init_rf_z(z_len) enddo do i=1,nxy - call get_new_alpha_beta(aspect,nsig,fmatz_tmp,fmat0z_tmp) - do l=1,2 - do k=1,nsig - do j=1,2 - fmatz(i,j,k,l)=fmatz_tmp(j,k,l) + call get_new_alpha_beta(aspect,nsig,fmatz_tmp,fmat0z_tmp) + do l=1,2 + do k=1,nsig + do j=1,2 + fmatz(i,j,k,l)=fmatz_tmp(j,k,l) + enddo enddo - enddo - enddo - do l=1,2 - do k=1,nsig - fmat0z(i,k,l)=fmat0z_tmp(k,l) - enddo - enddo + enddo + do l=1,2 + do k=1,nsig + fmat0z(i,k,l)=fmat0z_tmp(k,l) + enddo + enddo enddo else @@ -281,7 +281,7 @@ subroutine init_rf_z(z_len) ! abs(z_len) is in units of ln(p) ! put in approximate vertical scale which depends on ln(p) ! use ensemble mean ps (ps_bar) to construct pressure -! profiles using GFS sigma-p coordinate [ add mods to be able +! profiles using gfs sigma-p coordinate [ add mods to be able ! to use fully generalized coordinate later** ] ! i=0 @@ -329,16 +329,16 @@ subroutine init_rf_z(z_len) call get_new_alpha_beta(aspect,nsig,fmatz_tmp,fmat0z_tmp) do l=1,2 - do k=1,nsig - do j=1,2 - fmatz(i,j,k,l)=fmatz_tmp(j,k,l) - enddo - enddo + do k=1,nsig + do j=1,2 + fmatz(i,j,k,l)=fmatz_tmp(j,k,l) + enddo + enddo enddo do l=1,2 - do k=1,nsig - fmat0z(i,k,l)=fmat0z_tmp(k,l) - enddo + do k=1,nsig + fmat0z(i,k,l)=fmat0z_tmp(k,l) + enddo enddo enddo enddo @@ -812,36 +812,36 @@ subroutine normal_new_factorization_rf_z znorm_new=one do k=1,grd_ens%nsig - f=zero - f(:,k)=one + f=zero + f(:,k)=one - iadvance=1 ; iback=2 - call new_factorization_rf_z(f,iadvance,iback) - iadvance=2 ; iback=1 - call new_factorization_rf_z(f,iadvance,iback) + iadvance=1 ; iback=2 + call new_factorization_rf_z(f,iadvance,iback) + iadvance=2 ; iback=1 + call new_factorization_rf_z(f,iadvance,iback) - diag(:,k)=sqrt(one/f(:,k)) + diag(:,k)=sqrt(one/f(:,k)) enddo do k=1,grd_ens%nsig - znorm_new(:,k)=diag(:,k) + znorm_new(:,k)=diag(:,k) enddo ! Check result: if(debug)then - do k=1,grd_ens%nsig - f=zero - f(:,k)=one + do k=1,grd_ens%nsig + f=zero + f(:,k)=one - iadvance=1 ; iback=2 - call new_factorization_rf_z(f,iadvance,iback) - iadvance=2 ; iback=1 - call new_factorization_rf_z(f,iadvance,iback) + iadvance=1 ; iback=2 + call new_factorization_rf_z(f,iadvance,iback) + iadvance=2 ; iback=1 + call new_factorization_rf_z(f,iadvance,iback) - diag(:,k)=sqrt(one/f(:,k)) - enddo + diag(:,k)=sqrt(one/f(:,k)) + enddo - write(6,*)'in normal_new_factorization_rf_z, min,max(diag)=',minval(diag),maxval(diag) + write(6,*)'in normal_new_factorization_rf_z, min,max(diag)=',minval(diag),maxval(diag) end if return @@ -1005,11 +1005,11 @@ subroutine normal_new_factorization_rf_y ynorm_new=one if(grd_loc%nlat <= grd_loc%nlon)then - lend=1 - iend=grd_loc%nlat + lend=1 + iend=grd_loc%nlat else - lend=grd_loc%nlat/grd_loc%nlon + 1 - iend=grd_loc%nlon + lend=grd_loc%nlat/grd_loc%nlon + 1 + iend=grd_loc%nlon endif do loop=1,lend @@ -1017,9 +1017,9 @@ subroutine normal_new_factorization_rf_y f=zero do k=1,kl do i=1,iend - lcount=ll+i - f(lcount,i,k)=one - if(lcount == grd_loc%nlat) exit + lcount=ll+i + f(lcount,i,k)=one + if(lcount == grd_loc%nlat) exit enddo enddo @@ -1062,13 +1062,13 @@ subroutine normal_new_factorization_rf_y if(lcount == grd_loc%nlat) exit enddo enddo - enddo - write(6,*)' in normal_new_factorization_rf_y, min,max(diag)=',minval(diag),maxval(diag) + enddo + write(6,*)' in normal_new_factorization_rf_y, min,max(diag)=',minval(diag),maxval(diag) endif return end subroutine normal_new_factorization_rf_y - subroutine create_ensemble +subroutine create_ensemble !$$$ subprogram documentation block ! . . . . ! subprogram: create_ensemble allocate space for ensembles @@ -1092,45 +1092,45 @@ subroutine create_ensemble ! machine: ibm RS/6000 SP ! !$$$ - use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens - use hybrid_ensemble_parameters, only: nelen,en_perts,ps_bar + use hybrid_ensemble_parameters, only: n_ens,grd_ens,ntlevs_ens + use hybrid_ensemble_parameters, only: nelen,en_perts,ps_bar - implicit none + implicit none - type(gsi_grid) :: grid_ens + type(gsi_grid) :: grid_ens - integer(i_kind) n,istatus,m - character(len=*),parameter::myname_=trim(myname)//'*create_ensemble' + integer(i_kind) n,istatus,m + character(len=*),parameter::myname_=trim(myname)//'*create_ensemble' - nelen=grd_ens%latlon11*(max(0,nc3d)*grd_ens%nsig+max(0,nc2d)) -! create ensemble perturbations bundles (using newly added r_single capability + nelen=grd_ens%latlon11*(max(0,nc3d)*grd_ens%nsig+max(0,nc2d)) +! create ensemble perturbations bundles (using newly added r_single capability - allocate(en_perts(n_ens,ntlevs_ens)) - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + allocate(en_perts(n_ens,ntlevs_ens)) + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - do m=1,ntlevs_ens - do n=1,n_ens - call gsi_bundlecreate(en_perts(n,m),grid_ens,'ensemble perts',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating en_perts bundle' - call stop2(999) - endif - enddo - enddo - - - allocate(ps_bar(grd_ens%lat2,grd_ens%lon2,ntlevs_ens) ) - if(debug) then - write(6,*)' in create_ensemble, grd_ens%latlon11,grd_ens%latlon1n,n_ens,ntlevs_ens=', & - grd_ens%latlon11,grd_ens%latlon1n,n_ens,ntlevs_ens - write(6,*)' in create_ensemble, total bytes allocated=',4*nelen*n_ens*ntlevs_ens - end if - return - - end subroutine create_ensemble - - subroutine load_ensemble + do m=1,ntlevs_ens + do n=1,n_ens + call gsi_bundlecreate(en_perts(n,m),grid_ens,'ensemble perts',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_single) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating en_perts bundle' + call stop2(999) + endif + enddo + enddo + + + allocate(ps_bar(grd_ens%lat2,grd_ens%lon2,ntlevs_ens) ) + if(debug) then + write(6,*)' in create_ensemble, grd_ens%latlon11,grd_ens%latlon1n,n_ens,ntlevs_ens=', & + grd_ens%latlon11,grd_ens%latlon1n,n_ens,ntlevs_ens + write(6,*)' in create_ensemble, total bytes allocated=',4*nelen*n_ens*ntlevs_ens + end if + return + +end subroutine create_ensemble + +subroutine load_ensemble !$$$ subprogram documentation block ! . . . . ! subprogram: load_ensemble read/generate ensemble perturbations @@ -1163,215 +1163,215 @@ subroutine load_ensemble ! machine: ibm RS/6000 SP ! !$$$ - use gridmod, only: regional - use constants, only: zero,one - use hybrid_ensemble_parameters, only: n_ens,generate_ens,grd_ens,grd_anl,ntlevs_ens, & - pseudo_hybens,regional_ensemble_option,& - i_en_perts_io - use hybrid_ensemble_parameters, only: nelen,en_perts,ps_bar - use gsi_enscouplermod, only: gsi_enscoupler_put_gsi_ens - use mpimod, only: mype - use get_pseudo_ensperts_mod, only: get_pseudo_ensperts_class - use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class - use get_fv3_regional_ensperts_mod, only: get_fv3_regional_ensperts_class - use get_wrf_nmm_ensperts_mod, only: get_wrf_nmm_ensperts_class + use gridmod, only: regional + use constants, only: zero,one + use hybrid_ensemble_parameters, only: n_ens,generate_ens,grd_ens,grd_anl,ntlevs_ens, & + pseudo_hybens,regional_ensemble_option,& + i_en_perts_io + use hybrid_ensemble_parameters, only: nelen,en_perts,ps_bar + use gsi_enscouplermod, only: gsi_enscoupler_put_gsi_ens + use mpimod, only: mype + use get_pseudo_ensperts_mod, only: get_pseudo_ensperts_class + use get_wrf_mass_ensperts_mod, only: get_wrf_mass_ensperts_class + use get_fv3_regional_ensperts_mod, only: get_fv3_regional_ensperts_class + use get_wrf_nmm_ensperts_mod, only: get_wrf_nmm_ensperts_class use hybrid_ensemble_parameters, only: region_lat_ens,region_lon_ens - use mpimod, only: mpi_comm_world - - implicit none - - type(get_pseudo_ensperts_class) :: pseudo_enspert - type(get_wrf_mass_ensperts_class) :: wrf_mass_enspert - type(get_wrf_nmm_ensperts_class) :: wrf_nmm_enspert - type(get_fv3_regional_ensperts_class) :: fv3_regional_enspert - type(gsi_bundle),allocatable:: en_bar(:) - type(gsi_bundle):: bundle_anl,bundle_ens - type(gsi_grid) :: grid_anl,grid_ens - integer(i_kind) i,j,n,ii,m - integer(i_kind) istatus - real(r_kind),allocatable:: seed(:,:) - real(r_kind),pointer,dimension(:,:) :: cv_ps=>NULL() - real(r_kind) sig_norm,bar_norm - character(len=*),parameter::myname_=trim(myname)//'*load_ensemble' + use mpimod, only: mpi_comm_world + + implicit none + + type(get_pseudo_ensperts_class) :: pseudo_enspert + type(get_wrf_mass_ensperts_class) :: wrf_mass_enspert + type(get_wrf_nmm_ensperts_class) :: wrf_nmm_enspert + type(get_fv3_regional_ensperts_class) :: fv3_regional_enspert + type(gsi_bundle),allocatable:: en_bar(:) + type(gsi_bundle):: bundle_anl,bundle_ens + type(gsi_grid) :: grid_anl,grid_ens + integer(i_kind) i,j,n,ii,m + integer(i_kind) istatus + real(r_kind),allocatable:: seed(:,:) + real(r_kind),pointer,dimension(:,:) :: cv_ps=>null() + real(r_kind) sig_norm,bar_norm + character(len=*),parameter::myname_=trim(myname)//'*load_ensemble' ! create simple regular grid - if(generate_ens) then + if(generate_ens) then - call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - allocate(en_bar(ntlevs_ens)) + allocate(en_bar(ntlevs_ens)) - do m=1,ntlevs_ens - call gsi_bundlecreate(en_bar(m),grid_ens,'ensemble',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - enddo - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating en_bar bundle' - call stop2(999) - endif - sig_norm=sqrt(one/max(one,n_ens-one)) - bar_norm=one/n_ens - if(n_ens == 1) bar_norm=zero + do m=1,ntlevs_ens + call gsi_bundlecreate(en_bar(m),grid_ens,'ensemble',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + enddo + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating en_bar bundle' + call stop2(999) + endif + sig_norm=sqrt(one/max(one,n_ens-one)) + bar_norm=one/n_ens + if(n_ens == 1) bar_norm=zero ! initialize subdomain to slab routine special_sd2h - call special_sd2h0 - allocate(seed(nval2f,nscl)) - seed=-one + call special_sd2h0 + allocate(seed(nval2f,nscl)) + seed=-one - do m=1,ntlevs_ens - en_bar(m)%values=zero - enddo - -! create two internal bundles, one on analysis grid and one on ensemble grid - - call gsi_bundlecreate (bundle_anl,grid_anl,'ensemble work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating bundle_anl bundle' - call stop2(999) - endif - call gsi_bundlecreate (bundle_ens,grid_ens,'ensemble work ens',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating bundle_ens bundle' - call stop2(999) - endif - - do m=1,ntlevs_ens - do n=1,n_ens - call generate_one_ensemble_perturbation(bundle_anl,bundle_ens,seed) - do ii=1,nelen - en_perts(n,m)%valuesr4(ii)=bundle_ens%values(ii) - en_bar(m)%values(ii)=en_bar(m)%values(ii)+bundle_ens%values(ii) - enddo - enddo - + do m=1,ntlevs_ens + en_bar(m)%values=zero + enddo + +! create two internal bundles, one on analysis grid and one on ensemble grid + + call gsi_bundlecreate (bundle_anl,grid_anl,'ensemble work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating bundle_anl bundle' + call stop2(999) + endif + call gsi_bundlecreate (bundle_ens,grid_ens,'ensemble work ens',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating bundle_ens bundle' + call stop2(999) + endif + + do m=1,ntlevs_ens + do n=1,n_ens + call generate_one_ensemble_perturbation(bundle_anl,bundle_ens,seed) + do ii=1,nelen + en_perts(n,m)%valuesr4(ii)=bundle_ens%values(ii) + en_bar(m)%values(ii)=en_bar(m)%values(ii)+bundle_ens%values(ii) + enddo + enddo + ! Load ps_bar for use with vertical localization later - call gsi_bundlegetpointer (en_bar(m),'ps' ,cv_ps ,istatus) - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - ps_bar(i,j,m)=cv_ps(i,j)*bar_norm - enddo - enddo - enddo + call gsi_bundlegetpointer (en_bar(m),'ps' ,cv_ps ,istatus) + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + ps_bar(i,j,m)=cv_ps(i,j)*bar_norm + enddo + enddo + enddo ! do some cleanning - call gsi_bundledestroy(bundle_anl,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying bundle_anl bundle' - call stop2(999) - endif - call gsi_bundledestroy(bundle_ens,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying bundle_ens bundle' - call stop2(999) - endif + call gsi_bundledestroy(bundle_anl,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying bundle_anl bundle' + call stop2(999) + endif + call gsi_bundledestroy(bundle_ens,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying bundle_ens bundle' + call stop2(999) + endif ! remove mean, which is locally significantly non-zero, due to sample size. ! with real ensembles, the mean of the actual sample will be removed. - do m=1,ntlevs_ens - do n=1,n_ens - do ii=1,nelen - en_perts(n,m)%valuesr4(ii)=(en_perts(n,m)%valuesr4(ii)-en_bar(m)%values(ii)*bar_norm)*sig_norm - enddo - call gsi_enscoupler_put_gsi_ens(grd_ens,n,m,en_perts(n,m),istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble writing perts' - call stop2(999) - endif - enddo - - call gsi_bundledestroy(en_bar(m),istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying en_bar bundle' - call stop2(999) - end if - enddo - - deallocate(en_bar) - deallocate(seed) - - else + do m=1,ntlevs_ens + do n=1,n_ens + do ii=1,nelen + en_perts(n,m)%valuesr4(ii)=(en_perts(n,m)%valuesr4(ii)-en_bar(m)%values(ii)*bar_norm)*sig_norm + enddo + call gsi_enscoupler_put_gsi_ens(grd_ens,n,m,en_perts(n,m),istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble writing perts' + call stop2(999) + endif + enddo + + call gsi_bundledestroy(en_bar(m),istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying en_bar bundle' + call stop2(999) + end if + enddo + + deallocate(en_bar) + deallocate(seed) + + else ! read in ensembles - if (.not.regional) then - - call get_gefs_ensperts_dualres - - else - - if(regional_ensemble_option < 1 .or. regional_ensemble_option > 5) then - if(mype==0) then - write(6,'(" IMPROPER CHOICE FOR ENSEMBLE INPUT IN SUBROUTINE LOAD_ENSEMBLE")') - write(6,'(" regional_ensemble_option = ",i5)') regional_ensemble_option - write(6,'(" allowed values of regional_ensemble_option:")') - write(6,'(" regional_ensemble_option=1:")') - write(6,'(" use GEFS internally interpolated to ensemble grid.")') - write(6,'(" can add pseudo ensemble hybrid option for hwrf.")') - write(6,'(" regional_ensemble_option=2:")') - write(6,'(" ensembles are WRF NMM (HWRF) format.")') - write(6,'(" regional_ensemble_option=3:")') - write(6,'(" ensembles are ARW netcdf format.")') - write(6,'(" regional_ensemble_option=4:")') - write(6,'(" ensembles are NEMS NMMB format.")') - end if - call stop2(999) - end if - select case(regional_ensemble_option) - - case(1) - -! regional_ensemble_option = 1: use GEFS internally interpolated to ensemble grid. - - if(i_en_perts_io==2) then ! get en_perts from save files - call en_perts_get_from_save - elseif(i_en_perts_io==3) then ! get en_perts from save files - call en_perts_get_from_save_fulldomain - else - call get_gefs_for_regional - endif + if (.not.regional) then + + call get_gefs_ensperts_dualres + + else + + if(regional_ensemble_option < 1 .or. regional_ensemble_option > 5) then + if(mype==0) then + write(6,'(" IMPROPER CHOICE FOR ENSEMBLE INPUT IN SUBROUTINE LOAD_ENSEMBLE")') + write(6,'(" regional_ensemble_option = ",i5)') regional_ensemble_option + write(6,'(" allowed values of regional_ensemble_option:")') + write(6,'(" regional_ensemble_option=1:")') + write(6,'(" use GEFS internally interpolated to ensemble grid.")') + write(6,'(" can add pseudo ensemble hybrid option for hwrf.")') + write(6,'(" regional_ensemble_option=2:")') + write(6,'(" ensembles are WRF NMM (HWRF) format.")') + write(6,'(" regional_ensemble_option=3:")') + write(6,'(" ensembles are ARW netcdf format.")') + write(6,'(" regional_ensemble_option=4:")') + write(6,'(" ensembles are NEMS NMMB format.")') + end if + call stop2(999) + end if + select case(regional_ensemble_option) + + case(1) + +! regional_ensemble_option = 1: use gefs internally interpolated to ensemble grid. + + if(i_en_perts_io==2) then ! get en_perts from save files + call en_perts_get_from_save + elseif(i_en_perts_io==3) then ! get en_perts from save files + call en_perts_get_from_save_fulldomain + else + call get_gefs_for_regional + endif ! pseudo_hybens = .true.: pseudo ensemble hybrid option for hwrf -! GEFS ensemble perturbations in TC vortex area -! are replaced with TC vortex library perturbations - if (pseudo_hybens) then - call pseudo_enspert%get_pseudo_ensperts(en_perts,nelen) - end if - case(2) +! gefs ensemble perturbations in tc vortex area +! are replaced with tc vortex library perturbations + if (pseudo_hybens) then + call pseudo_enspert%get_pseudo_ensperts(en_perts,nelen) + end if + case(2) ! regional_ensemble_option = 2: ensembles are WRF NMM (HWRF) format - call wrf_nmm_enspert%get_wrf_nmm_ensperts(en_perts,nelen,region_lat_ens,region_lon_ens,ps_bar) + call wrf_nmm_enspert%get_wrf_nmm_ensperts(en_perts,nelen,region_lat_ens,region_lon_ens,ps_bar) - case(3) + case(3) ! regional_ensemble_option = 3: ensembles are ARW netcdf format. - call wrf_mass_enspert%get_wrf_mass_ensperts(en_perts,nelen,ps_bar) + call wrf_mass_enspert%get_wrf_mass_ensperts(en_perts,nelen,ps_bar) - case(4) + case(4) ! regional_ensemble_option = 4: ensembles are NEMS NMMB format. - call get_nmmb_ensperts - case(5) + call get_nmmb_ensperts + case(5) ! regional_ensemble_option = 5: ensembles are fv3 regional. - call fv3_regional_enspert%get_fv3_regional_ensperts(en_perts,nelen,ps_bar) + call fv3_regional_enspert%get_fv3_regional_ensperts(en_perts,nelen,ps_bar) - end select + end select - end if + end if - end if - return + end if + return - end subroutine load_ensemble +end subroutine load_ensemble - subroutine generate_one_ensemble_perturbation(bundle_anl,bundle_ens,seed) +subroutine generate_one_ensemble_perturbation(bundle_anl,bundle_ens,seed) !$$$ subprogram documentation block ! . . . ! subprogram: generate_one_ensemble_perturbation @@ -1422,119 +1422,119 @@ subroutine generate_one_ensemble_perturbation(bundle_anl,bundle_ens,seed) ! !$$$ end documentation block - use kinds, only: r_kind,i_kind,i_llong - use gridmod, only: vlevs,nnnn1o,regional - use mpimod, only: mype,mpi_rtype,mpi_comm_world,ierror - use hybrid_ensemble_parameters, only: uv_hyb_ens,grd_ens,grd_anl,p_e2a - use general_sub2grid_mod, only: general_suba2sube - use constants, only: zero,one - use jfunc, only: nval_lenz - implicit none - - character(len=*),parameter::myname_=myname//'*generate_one_ensemble_perturbation' - real(r_kind) ,intent(inout) :: seed(nval2f,nscl) - type(gsi_bundle),intent(inout) :: bundle_anl,bundle_ens - - real(r_kind),dimension(nval2f,nnnn1o,nscl):: z - real(r_kind) vert1(vlevs) - integer(i_llong) iseed - integer(4) iiseed(4) ! must be integer*4 given lapack interface - integer(i_kind) nvert,i,is,naux,k,ic3 - integer(i_kind) istat_st,istat_vp - integer(i_kind) nval_lenz_save - real(r_kind),dimension(nh_0:nh_1,vlevs,nscl):: zsub - real(r_kind),dimension(:,:,:),allocatable:: ua,va - real(r_kind),pointer,dimension(:,:,:):: st=>NULL() - real(r_kind),pointer,dimension(:,:,:):: vp=>NULL() - - naux=0 - nvert=vlevs - zsub=zero - if(maxval(seed) < zero) then + use kinds, only: r_kind,i_kind,i_llong + use gridmod, only: vlevs,nnnn1o,regional + use mpimod, only: mype,mpi_rtype,mpi_comm_world,ierror + use hybrid_ensemble_parameters, only: uv_hyb_ens,grd_ens,grd_anl,p_e2a + use general_sub2grid_mod, only: general_suba2sube + use constants, only: zero,one + use jfunc, only: nval_lenz + implicit none + + character(len=*),parameter::myname_=myname//'*generate_one_ensemble_perturbation' + real(r_kind) ,intent(inout) :: seed(nval2f,nscl) + type(gsi_bundle),intent(inout) :: bundle_anl,bundle_ens + + real(r_kind),dimension(nval2f,nnnn1o,nscl):: z + real(r_kind) vert1(vlevs) + integer(i_llong) iseed + integer(i_kind) iiseed(4) ! must be integer*4 given lapack interface + integer(i_kind) nvert,i,is,naux,k,ic3 + integer(i_kind) istat_st,istat_vp + integer(i_kind) nval_lenz_save + real(r_kind),dimension(nh_0:nh_1,vlevs,nscl):: zsub + real(r_kind),dimension(:,:,:),allocatable:: ua,va + real(r_kind),pointer,dimension(:,:,:):: st=>null() + real(r_kind),pointer,dimension(:,:,:):: vp=>null() + + naux=0 + nvert=vlevs + zsub=zero + if(maxval(seed) < zero) then ! create initial seed for random numbers for each horizontal location. - if(mype == 0) then - call random_number(seed) - do is=1,nscl - do i=1,nval2f - iseed=1+nint(seed(i,is)*1234567._r_kind) - seed(i,is)=iseed - enddo - enddo - end if - call mpi_bcast(seed,nval2f*nscl,mpi_rtype,0,mpi_comm_world,ierror) - - end if - - do is=1,nscl - do i=nh_0,nh_1 + if(mype == 0) then + call random_number(seed) + do is=1,nscl + do i=1,nval2f + iseed=1+nint(seed(i,is)*1234567._r_kind) + seed(i,is)=iseed + enddo + enddo + end if + call mpi_bcast(seed,nval2f*nscl,mpi_rtype,0,mpi_comm_world,ierror) + + end if + + do is=1,nscl + do i=nh_0,nh_1 #ifdef ibm_sp #ifdef _REAL4_ - call snrand(seed(i,is),nvert,vert1,aux,naux) + call snrand(seed(i,is),nvert,vert1,aux,naux) #else - call dnrand(seed(i,is),nvert,vert1,aux,naux) + call dnrand(seed(i,is),nvert,vert1,aux,naux) #endif #else /* ibm_sp */ -! Generate a Vector of Normally Distributed Random Numbers (function from Lapack lib) - iiseed=seed(i,is) - iiseed(4)=mod(iiseed(4),2)+1 ! must be odd +! Generate a vector of normally distributed random numbers (function from lapack lib) + iiseed=seed(i,is) + iiseed(4)=mod(iiseed(4),2)+1 ! must be odd #ifdef _REAL4_ - call slarnv(3,iiseed,nvert,vert1) + call slarnv(3,iiseed,nvert,vert1) #else - call dlarnv(3,iiseed,nvert,vert1) + call dlarnv(3,iiseed,nvert,vert1) #endif - seed(i,is)=iiseed(1) ! update seed; is this good enough? + seed(i,is)=iiseed(1) ! update seed; is this good enough? #endif /* ibm_sp */ - do k=1,nvert - zsub(i,k,is)=vert1(k) - enddo - enddo - enddo - call special_sd2h(zsub,z) + do k=1,nvert + zsub(i,k,is)=vert1(k) + enddo + enddo + enddo + call special_sd2h(zsub,z) ! if this is a global run, then need to fix tropical belt part of z so periodic overlap is correct - if(.not.regional) call fix_belt(z) + if(.not.regional) call fix_belt(z) ! temporarily redefine nval_lenz - nval_lenz_save=nval_lenz - nval_lenz=nval2f*nnnn1o*nscl - call ckgcov(z,bundle_anl,nval_lenz) + nval_lenz_save=nval_lenz + nval_lenz=nval2f*nnnn1o*nscl + call ckgcov(z,bundle_anl,nval_lenz) ! restore nval_lenz - nval_lenz=nval_lenz_save + nval_lenz=nval_lenz_save ! if uv_hyb_ens=.true., then convert st,vp to u,v - if(uv_hyb_ens) then - allocate(ua(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig)) - allocate(va(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig)) - istat_st=-999 - istat_vp=-999 - do ic3=1,nc3d - if(trim(cvars3d(ic3))=='sf') call gsi_bundlegetpointer (bundle_anl, cvars3d(ic3),st, istat_st) - if(trim(cvars3d(ic3))=='vp') call gsi_bundlegetpointer (bundle_anl, cvars3d(ic3),vp, istat_vp) - enddo - if(istat_st/=0.or.istat_vp/=0) then - write(6,*) myname_,': error getting sf/vp pointers, aborting ...' - call stop2(999) - endif - call getuv(ua,va,st,vp,0) - st=ua - vp=va - deallocate(va) - deallocate(ua) - end if - - if(p_e2a%identity) then - bundle_ens%values=bundle_anl%values - else - call general_suba2sube(grd_anl,grd_ens,p_e2a,bundle_anl%values,bundle_ens%values,regional) - end if - return - - - end subroutine generate_one_ensemble_perturbation - - subroutine fix_belt(z) + if(uv_hyb_ens) then + allocate(ua(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig)) + allocate(va(grd_anl%lat2,grd_anl%lon2,grd_anl%nsig)) + istat_st=-999 + istat_vp=-999 + do ic3=1,nc3d + if(trim(cvars3d(ic3))=='sf') call gsi_bundlegetpointer (bundle_anl, cvars3d(ic3),st, istat_st) + if(trim(cvars3d(ic3))=='vp') call gsi_bundlegetpointer (bundle_anl, cvars3d(ic3),vp, istat_vp) + enddo + if(istat_st/=0.or.istat_vp/=0) then + write(6,*) myname_,': error getting sf/vp pointers, aborting ...' + call stop2(999) + endif + call getuv(ua,va,st,vp,0) + st=ua + vp=va + deallocate(va) + deallocate(ua) + end if + + if(p_e2a%identity) then + bundle_ens%values=bundle_anl%values + else + call general_suba2sube(grd_anl,grd_ens,p_e2a,bundle_anl%values,bundle_ens%values,regional) + end if + return + + +end subroutine generate_one_ensemble_perturbation + +subroutine fix_belt(z) !$$$ subprogram documentation block ! . . . ! subprogram: fix_belt @@ -1562,46 +1562,46 @@ subroutine fix_belt(z) !$$$ end documentation block - use kinds, only: r_kind,i_kind - use gridmod, only: nnnn1o - use berror, only: nx,ny - use hybrid_ensemble_parameters, only: grd_ens - implicit none + use kinds, only: r_kind,i_kind + use gridmod, only: nnnn1o + use berror, only: nx,ny + use hybrid_ensemble_parameters, only: grd_ens + implicit none - real(r_kind),intent(inout) :: z(nval2f,nnnn1o,nscl) + real(r_kind),intent(inout) :: z(nval2f,nnnn1o,nscl) - real(r_kind) zloc1(ny,nx) - integer(i_kind) i,ii,j,jj,k + real(r_kind) zloc1(ny,nx) + integer(i_kind) i,ii,j,jj,k !$omp parallel do schedule(dynamic,1) private(j,k,i,jj,ii,zloc1) - do j=1,nscl - do k=1,nnnn1o - i=0 - do jj=1,nx - do ii=1,ny - i=i+1 - zloc1(ii,jj)=z(i,k,j) - enddo - enddo - do jj=grd_ens%nlon+1,nx - do ii=1,ny - zloc1(ii,jj)=zloc1(ii,jj-grd_ens%nlon) - enddo - enddo - i=0 - do jj=1,nx - do ii=1,ny - i=i+1 - z(i,k,j)=zloc1(ii,jj) - enddo - enddo - enddo - enddo - return + do j=1,nscl + do k=1,nnnn1o + i=0 + do jj=1,nx + do ii=1,ny + i=i+1 + zloc1(ii,jj)=z(i,k,j) + enddo + enddo + do jj=grd_ens%nlon+1,nx + do ii=1,ny + zloc1(ii,jj)=zloc1(ii,jj-grd_ens%nlon) + enddo + enddo + i=0 + do jj=1,nx + do ii=1,ny + i=i+1 + z(i,k,j)=zloc1(ii,jj) + enddo + enddo + enddo + enddo + return - end subroutine fix_belt +end subroutine fix_belt - subroutine rescale_ensemble_rh_perturbations +subroutine rescale_ensemble_rh_perturbations !$$$ subprogram documentation block ! . . . . ! subprogram: rescale_ensemble_rh_perturbations @@ -1625,52 +1625,52 @@ subroutine rescale_ensemble_rh_perturbations ! machine: ibm RS/6000 SP ! !$$$ - use kinds, only: r_kind,i_kind - use gridmod, only: regional - use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,grd_a1,grd_e1,p_e2a,ntlevs_ens - use hybrid_ensemble_parameters, only: en_perts - use general_sub2grid_mod, only: general_suba2sube - use berror, only: qvar3d - implicit none - - integer(i_kind) i,j,k,n,istatus,m - real(r_kind) qvar3d_ens(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,1) - real(r_single),pointer,dimension(:,:,:):: w3=>NULL() - - call gsi_bundlegetpointer(en_perts(1,1),'q',w3,istatus) - if(istatus/=0) then - write(6,*)' rh variable not available, skip subroutine rescale_ensemble_rh_perturbations' - return - end if - - if(grd_anl%latlon11 == grd_ens%latlon11) then - qvar3d_ens=reshape(qvar3d,(/size(qvar3d,1),size(qvar3d,2),size(qvar3d,3),1/)) - else - call general_suba2sube(grd_a1,grd_e1,p_e2a, & - reshape(qvar3d,(/size(qvar3d,1),size(qvar3d,2),size(qvar3d,3),1/)),qvar3d_ens,regional) - end if - do m=1,ntlevs_ens + use kinds, only: r_kind,i_kind + use gridmod, only: regional + use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,grd_a1,grd_e1,p_e2a,ntlevs_ens + use hybrid_ensemble_parameters, only: en_perts + use general_sub2grid_mod, only: general_suba2sube + use berror, only: qvar3d + implicit none + + integer(i_kind) i,j,k,n,istatus,m + real(r_kind) qvar3d_ens(grd_ens%lat2,grd_ens%lon2,grd_ens%nsig,1) + real(r_single),pointer,dimension(:,:,:):: w3=>null() + + call gsi_bundlegetpointer(en_perts(1,1),'q',w3,istatus) + if(istatus/=0) then + write(6,*)' rh variable not available, skip subroutine rescale_ensemble_rh_perturbations' + return + end if + + if(grd_anl%latlon11 == grd_ens%latlon11) then + qvar3d_ens=reshape(qvar3d,(/size(qvar3d,1),size(qvar3d,2),size(qvar3d,3),1/)) + else + call general_suba2sube(grd_a1,grd_e1,p_e2a, & + reshape(qvar3d,(/size(qvar3d,1),size(qvar3d,2),size(qvar3d,3),1/)),qvar3d_ens,regional) + end if + do m=1,ntlevs_ens !$omp parallel do schedule(dynamic,1) private(n,i,j,k,w3,istatus) - do n=1,n_ens - call gsi_bundlegetpointer(en_perts(n,m),'q',w3,istatus) - if(istatus/=0) then - write(6,*)' error retrieving pointer to rh variable for ensemble number ',n - call stop2(999) - end if - do k=1,grd_ens%nsig - do j=1,grd_ens%lon2 - do i=1,grd_ens%lat2 - w3(i,j,k)=qvar3d_ens(i,j,k,1)*w3(i,j,k) - enddo - enddo - enddo - enddo - enddo - return + do n=1,n_ens + call gsi_bundlegetpointer(en_perts(n,m),'q',w3,istatus) + if(istatus/=0) then + write(6,*)' error retrieving pointer to rh variable for ensemble number ',n + call stop2(999) + end if + do k=1,grd_ens%nsig + do j=1,grd_ens%lon2 + do i=1,grd_ens%lat2 + w3(i,j,k)=qvar3d_ens(i,j,k,1)*w3(i,j,k) + enddo + enddo + enddo + enddo + enddo + return - end subroutine rescale_ensemble_rh_perturbations +end subroutine rescale_ensemble_rh_perturbations - subroutine destroy_ensemble +subroutine destroy_ensemble !$$$ subprogram documentation block ! . . . . ! subprogram: destroy_ensemble deallocate space for ensembles @@ -1692,30 +1692,30 @@ subroutine destroy_ensemble ! machine: ibm RS/6000 SP ! !$$$ - use hybrid_ensemble_parameters, only: l_hyb_ens,n_ens,ntlevs_ens - use hybrid_ensemble_parameters, only: en_perts,ps_bar - implicit none - - integer(i_kind) istatus,n,m - - if(l_hyb_ens) then - do m=1,ntlevs_ens - do n=1,n_ens - call gsi_bundleunset(en_perts(n,m),istatus) - if(istatus/=0) then - write(6,*)'in destroy_ensemble: trouble destroying en_perts bundle' - call stop2(999) - endif - enddo - enddo - deallocate(ps_bar) - deallocate(en_perts) - end if - return - - end subroutine destroy_ensemble - - subroutine ensemble_forward_model(cvec,a_en,ibin) + use hybrid_ensemble_parameters, only: l_hyb_ens,n_ens,ntlevs_ens + use hybrid_ensemble_parameters, only: en_perts,ps_bar + implicit none + + integer(i_kind) istatus,n,m + + if(l_hyb_ens) then + do m=1,ntlevs_ens + do n=1,n_ens + call gsi_bundleunset(en_perts(n,m),istatus) + if(istatus/=0) then + write(6,*)'in destroy_ensemble: trouble destroying en_perts bundle' + call stop2(999) + endif + enddo + enddo + deallocate(ps_bar) + deallocate(en_perts) + end if + return + +end subroutine destroy_ensemble + +subroutine ensemble_forward_model(cvec,a_en,ibin) !$$$ subprogram documentation block ! . . . . ! subprogram: ensemble_forward_model add ensemble part to anl vars @@ -1723,7 +1723,7 @@ subroutine ensemble_forward_model(cvec,a_en,ibin) ! ! abstract: For the hybrid ensemble method, add ensemble contribution ! to standard analysis control variables. (This follows, -! method outlined in Wang et al, MWR, 2008). +! method outlined in wang et al, mwr, 2008). ! program history log: ! 2009-09-11 parrish @@ -1752,116 +1752,116 @@ subroutine ensemble_forward_model(cvec,a_en,ibin) ! machine: ibm RS/6000 SP ! !$$$ - use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt - use hybrid_ensemble_parameters, only: en_perts - use constants, only: zero - - implicit none - type(gsi_bundle),intent(inout) :: cvec - type(gsi_bundle),intent(in) :: a_en(n_ens) - integer,intent(in) :: ibin - - character(len=*),parameter :: myname_=trim(myname)//'*ensemble_forward_model' - logical :: nogood - integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipic,ipx,km_tmp - integer(i_kind) :: ipc3d(nc3d),ipc2d(nc2d),istatus - - im=cvec%grid%im - jm=cvec%grid%jm - km=cvec%grid%km - -! Check resolution consistency between static and ensemble components - nogood=im/=a_en(1)%grid%im.or.jm/=a_en(1)%grid%jm.or.km/=a_en(1)%grid%km - if (nogood) then - write(6,*) myname_,': static&ensemble vectors have inconsistent dims' - call stop2(999) - endif - -! Request ensemble-corresponding fields from control vector -! NOTE: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and -! ipc2d indices for cvec and en_perts bundles. - call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 3d pointers' - call stop2(999) - endif - call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 2d pointers' - call stop2(999) - endif + use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt + use hybrid_ensemble_parameters, only: en_perts + use constants, only: zero + + implicit none + type(gsi_bundle),intent(inout) :: cvec + type(gsi_bundle),intent(in) :: a_en(n_ens) + integer(i_kind),intent(in) :: ibin + + character(len=*),parameter :: myname_=trim(myname)//'*ensemble_forward_model' + logical :: nogood + integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipic,ipx,km_tmp + integer(i_kind) :: ipc3d(nc3d),ipc2d(nc2d),istatus + + im=cvec%grid%im + jm=cvec%grid%jm + km=cvec%grid%km + +! Check resolution consistency between static and ensemble components + nogood=im/=a_en(1)%grid%im.or.jm/=a_en(1)%grid%jm.or.km/=a_en(1)%grid%km + if (nogood) then + write(6,*) myname_,': static&ensemble vectors have inconsistent dims' + call stop2(999) + endif + +! Request ensemble-corresponding fields from control vector +! Note: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and +! ipc2d indices for cvec and en_perts bundles. + call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 3d pointers' + call stop2(999) + endif + call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 2d pointers' + call stop2(999) + endif - ipx=1 + ipx=1 !$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic) - do k=1,km - do ic3=1,nc3d - ipic=ipc3d(ic3) - do j=1,jm - do i=1,im - cvec%r3(ipic)%q(i,j,k)=zero - enddo - enddo - do n=1,n_ens - do j=1,jm - do i=1,im - cvec%r3(ipic)%q(i,j,k)=cvec%r3(ipic)%q(i,j,k) & - +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) - enddo - enddo - enddo - enddo - enddo + do k=1,km + do ic3=1,nc3d + ipic=ipc3d(ic3) + do j=1,jm + do i=1,im + cvec%r3(ipic)%q(i,j,k)=zero + enddo + enddo + do n=1,n_ens + do j=1,jm + do i=1,im + cvec%r3(ipic)%q(i,j,k)=cvec%r3(ipic)%q(i,j,k) & + +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) + enddo + enddo + enddo + enddo + enddo !$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic) - do ic2=1,nc2d - ipic=ipc2d(ic2) - do j=1,jm - do i=1,im - cvec%r2(ipic)%q(i,j)=zero - enddo - enddo - - select case ( trim(StrUpCase(cvars2d(ic2))) ) + do ic2=1,nc2d + ipic=ipc2d(ic2) + do j=1,jm + do i=1,im + cvec%r2(ipic)%q(i,j)=zero + enddo + enddo + + select case ( trim(strupcase(cvars2d(ic2))) ) - case('PS') + case('PS') - if ( pwgtflg ) then - km_tmp = km - else - km_tmp = 1 - endif - - do n=1,n_ens - do j=1,jm - do k=1,km_tmp - do i=1,im - cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) & - +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) - enddo - enddo - enddo - enddo ! enddo n_ens - - case('SST') - - do n=1,n_ens - do j=1,jm - do i=1,im - cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) & - +a_en(n)%r3(ipx)%q(i,j,1)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) - enddo - enddo - enddo ! enddo n_ens + if ( pwgtflg ) then + km_tmp = km + else + km_tmp = 1 + endif + + do n=1,n_ens + do j=1,jm + do k=1,km_tmp + do i=1,im + cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) & + +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) + enddo + enddo + enddo + enddo ! enddo n_ens + + case('SST') - end select + do n=1,n_ens + do j=1,jm + do i=1,im + cvec%r2(ipic)%q(i,j)=cvec%r2(ipic)%q(i,j) & + +a_en(n)%r3(ipx)%q(i,j,1)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) + enddo + enddo + enddo ! enddo n_ens - enddo - return + end select + + enddo + return - end subroutine ensemble_forward_model +end subroutine ensemble_forward_model - subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) +subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) !$$$ subprogram documentation block ! . . . . ! subprogram: ensemble_forward_model_dual_res use for dualres option @@ -1879,7 +1879,7 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) ! ensemble grid. ! the ensemble part is still not updated for ! generalized control variable -! 2010-05-18 todling - revisited bundle usage in light of Dave's change (2010-05-07) +! 2010-05-18 todling - revisited bundle usage in light of dave's change (2010-05-07) ! 2011-02-28 parrish - bundle changes ! 2011-10-03 wu - add option to weight ensemble contribution to surface pressure with vertical profile ! 2011-10-26 kleist - 4d capability for ensemble/hybrid @@ -1901,144 +1901,144 @@ subroutine ensemble_forward_model_dual_res(cvec,a_en,ibin) ! machine: ibm RS/6000 SP ! !$$$ - use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt - use hybrid_ensemble_parameters, only: grd_ens,grd_anl,p_e2a - use hybrid_ensemble_parameters, only: en_perts - use general_sub2grid_mod, only: general_sube2suba - use gridmod,only: regional - use constants, only: zero - implicit none - - type(gsi_bundle),intent(inout) :: cvec - type(gsi_bundle),intent(in) :: a_en(n_ens) - integer,intent(in) :: ibin - - character(len=*),parameter::myname_=trim(myname)//'*ensemble_forward_model_dual_res' - type(gsi_grid) :: grid_ens,grid_anl - type(gsi_bundle) :: work_ens,work_anl - integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipic,ipx,km_tmp - integer(i_kind) :: ipc2d(nc2d),ipc3d(nc3d),istatus - -! Request ensemble-corresponding fields from control vector -! NOTE: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and -! ipc2d indices for cvec and en_perts bundles. - call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 3d pointers' - call stop2(999) - endif - call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 2d pointers' - call stop2(999) - endif - - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - call gsi_bundlecreate (work_ens,grid_ens,'ensemble work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating work_ens bundle' - call stop2(999) - endif - call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) - call gsi_bundlecreate (work_anl,grid_anl,'analysis work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating work_anl bundle' - call stop2(999) - endif + use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt + use hybrid_ensemble_parameters, only: grd_ens,grd_anl,p_e2a + use hybrid_ensemble_parameters, only: en_perts + use general_sub2grid_mod, only: general_sube2suba + use gridmod,only: regional + use constants, only: zero + implicit none + + type(gsi_bundle),intent(inout) :: cvec + type(gsi_bundle),intent(in) :: a_en(n_ens) + integer(i_kind),intent(in) :: ibin + + character(len=*),parameter::myname_=trim(myname)//'*ensemble_forward_model_dual_res' + type(gsi_grid) :: grid_ens,grid_anl + type(gsi_bundle) :: work_ens,work_anl + integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipic,ipx,km_tmp + integer(i_kind) :: ipc2d(nc2d),ipc3d(nc3d),istatus + +! Request ensemble-corresponding fields from control vector +! Note: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and +! ipc2d indices for cvec and en_perts bundles. + call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 3d pointers' + call stop2(999) + endif + call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 2d pointers' + call stop2(999) + endif + + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + call gsi_bundlecreate (work_ens,grid_ens,'ensemble work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating work_ens bundle' + call stop2(999) + endif + call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) + call gsi_bundlecreate (work_anl,grid_anl,'analysis work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating work_anl bundle' + call stop2(999) + endif - ipx=1 - im=work_ens%grid%im - jm=work_ens%grid%jm - km=work_ens%grid%km + ipx=1 + im=work_ens%grid%im + jm=work_ens%grid%jm + km=work_ens%grid%km !$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ipic) - do k=1,km - do ic3=1,nc3d - ipic=ipc3d(ic3) - do j=1,jm - do i=1,im - work_ens%r3(ipic)%q(i,j,k)=zero - enddo - enddo - do n=1,n_ens - do j=1,jm - do i=1,im - work_ens%r3(ipic)%q(i,j,k)=work_ens%r3(ipic)%q(i,j,k) & - +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) - enddo - enddo - enddo - enddo - enddo + do k=1,km + do ic3=1,nc3d + ipic=ipc3d(ic3) + do j=1,jm + do i=1,im + work_ens%r3(ipic)%q(i,j,k)=zero + enddo + enddo + do n=1,n_ens + do j=1,jm + do i=1,im + work_ens%r3(ipic)%q(i,j,k)=work_ens%r3(ipic)%q(i,j,k) & + +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) + enddo + enddo + enddo + enddo + enddo !$omp parallel do schedule(dynamic,1) private(j,n,k,i,ic2,ipic) - do ic2=1,nc2d - ipic=ipc2d(ic2) - do j=1,jm - do i=1,im - work_ens%r2(ipic)%q(i,j)=zero - enddo - enddo - - select case ( trim(StrUpCase(cvars2d(ic2))) ) - - case('PS') - - if ( pwgtflg ) then - km_tmp = km - else - km_tmp = 1 - endif - - do n=1,n_ens - do k=1,km_tmp - do j=1,jm - do i=1,im - work_ens%r2(ipic)%q(i,j)=work_ens%r2(ipic)%q(i,j) & - +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) - enddo - enddo - enddo - enddo ! enddo n_ens - - case('SST') - - do n=1,n_ens - do j=1,jm - do i=1,im - work_ens%r2(ipic)%q(i,j)=work_ens%r2(ipic)%q(i,j) & - +a_en(n)%r3(ipx)%q(i,j,1)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) - enddo - enddo - enddo ! enddo n_ens - - end select - - enddo - - call general_sube2suba(grd_ens,grd_anl,p_e2a,work_ens%values,work_anl%values,regional) - call gsi_bundledestroy(work_ens,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying work ens bundle' - call stop2(999) - endif - do ic3=1,nc3d - cvec%r3(ipc3d(ic3))%q=work_anl%r3(ipc3d(ic3))%q - enddo - do ic2=1,nc2d - cvec%r2(ipc2d(ic2))%q=work_anl%r2(ipc2d(ic2))%q - enddo - call gsi_bundledestroy(work_anl,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying work anl bundle' - call stop2(999) - endif - return - - end subroutine ensemble_forward_model_dual_res - - subroutine ensemble_forward_model_ad(cvec,a_en,ibin) + do ic2=1,nc2d + ipic=ipc2d(ic2) + do j=1,jm + do i=1,im + work_ens%r2(ipic)%q(i,j)=zero + enddo + enddo + + select case ( trim(strupcase(cvars2d(ic2))) ) + + case('PS') + + if ( pwgtflg ) then + km_tmp = km + else + km_tmp = 1 + endif + + do n=1,n_ens + do k=1,km_tmp + do j=1,jm + do i=1,im + work_ens%r2(ipic)%q(i,j)=work_ens%r2(ipic)%q(i,j) & + +a_en(n)%r3(ipx)%q(i,j,k)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) + enddo + enddo + enddo + enddo ! enddo n_ens + + case('SST') + + do n=1,n_ens + do j=1,jm + do i=1,im + work_ens%r2(ipic)%q(i,j)=work_ens%r2(ipic)%q(i,j) & + +a_en(n)%r3(ipx)%q(i,j,1)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) + enddo + enddo + enddo ! enddo n_ens + + end select + + enddo + + call general_sube2suba(grd_ens,grd_anl,p_e2a,work_ens%values,work_anl%values,regional) + call gsi_bundledestroy(work_ens,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying work ens bundle' + call stop2(999) + endif + do ic3=1,nc3d + cvec%r3(ipc3d(ic3))%q=work_anl%r3(ipc3d(ic3))%q + enddo + do ic2=1,nc2d + cvec%r2(ipc2d(ic2))%q=work_anl%r2(ipc2d(ic2))%q + enddo + call gsi_bundledestroy(work_anl,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying work anl bundle' + call stop2(999) + endif + return + +end subroutine ensemble_forward_model_dual_res + +subroutine ensemble_forward_model_ad(cvec,a_en,ibin) !$$$ subprogram documentation block ! . . . . ! subprogram: ensemble_forward_model add ensemble part to anl vars @@ -2046,7 +2046,7 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin) ! ! abstract: For the hybrid ensemble method, add ensemble contribution ! to standard analysis control variables. (This follows, -! method outlined in Wang et al, MWR, 2008). +! method outlined in wang et al, mwr, 2008). ! program history log: ! 2009-09-11 parrish @@ -2075,95 +2075,95 @@ subroutine ensemble_forward_model_ad(cvec,a_en,ibin) ! !$$$ - use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt - use hybrid_ensemble_parameters, only: en_perts - implicit none - - type(gsi_bundle),intent(inout) :: cvec - type(gsi_bundle),intent(inout) :: a_en(n_ens) - integer,intent(in) :: ibin - - character(len=*),parameter :: myname_=trim(myname)//'*ensemble_forward_model_ad' - logical :: nogood - integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipx,ipic,km_tmp - integer(i_kind) :: ipc3d(nc3d),ipc2d(nc2d),istatus - - im=cvec%grid%im - jm=cvec%grid%jm - km=cvec%grid%km -! Check resolution consistency between static and ensemble components - nogood=im/=a_en(1)%grid%im.or.jm/=a_en(1)%grid%jm.or.km/=a_en(1)%grid%km - if (nogood) then - write(6,*) myname_,': static/ensemble vectors have inconsistent dims' - call stop2(999) - endif - -! Request ensemble-corresponding fields from control vector -! NOTE: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and -! ipc2d indices for cvec and en_perts bundles. - call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 3d pointers' - call stop2(999) - endif - call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 2d pointers' - call stop2(999) - endif - - ipx=1 + use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt + use hybrid_ensemble_parameters, only: en_perts + implicit none + + type(gsi_bundle),intent(inout) :: cvec + type(gsi_bundle),intent(inout) :: a_en(n_ens) + integer(i_kind),intent(in) :: ibin + + character(len=*),parameter :: myname_=trim(myname)//'*ensemble_forward_model_ad' + logical :: nogood + integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipx,ipic,km_tmp + integer(i_kind) :: ipc3d(nc3d),ipc2d(nc2d),istatus + + im=cvec%grid%im + jm=cvec%grid%jm + km=cvec%grid%km +! Check resolution consistency between static and ensemble components + nogood=im/=a_en(1)%grid%im.or.jm/=a_en(1)%grid%jm.or.km/=a_en(1)%grid%km + if (nogood) then + write(6,*) myname_,': static/ensemble vectors have inconsistent dims' + call stop2(999) + endif + +! Request ensemble-corresponding fields from control vector +! Note: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and +! ipc2d indices for cvec and en_perts bundles. + call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 3d pointers' + call stop2(999) + endif + call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 2d pointers' + call stop2(999) + endif + + ipx=1 !$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic) - do n=1,n_ens - do ic3=1,nc3d - ipic=ipc3d(ic3) - do k=1,km - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & - +cvec%r3(ipic)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) - enddo - enddo - enddo - enddo - do ic2=1,nc2d - - ipic=ipc2d(ic2) - select case ( trim(StrUpCase(cvars2d(ic2))) ) + do n=1,n_ens + do ic3=1,nc3d + ipic=ipc3d(ic3) + do k=1,km + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & + +cvec%r3(ipic)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) + enddo + enddo + enddo + enddo + do ic2=1,nc2d + + ipic=ipc2d(ic2) + select case ( trim(strupcase(cvars2d(ic2))) ) + + case('PS') - case('PS') + if ( pwgtflg ) then + km_tmp = km + else + km_tmp = 1 + endif + + do k=1,km_tmp + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & + +cvec%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) + enddo + enddo + enddo - if ( pwgtflg ) then - km_tmp = km - else - km_tmp = 1 - endif - - do k=1,km_tmp - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & - +cvec%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) - enddo - enddo - enddo + case('SST') - case('SST') - - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,1)=a_en(n)%r3(ipx)%q(i,j,1) & - +cvec%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) - enddo - enddo - - end select - enddo - enddo ! enddo n_ens - return - end subroutine ensemble_forward_model_ad + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,1)=a_en(n)%r3(ipx)%q(i,j,1) & + +cvec%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) + enddo + enddo - subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin) + end select + enddo + enddo ! enddo n_ens + return +end subroutine ensemble_forward_model_ad + +subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin) !$$$ subprogram documentation block ! . . . . ! subprogram: ensemble_forward_model_ad_dual_res use for dualres option @@ -2181,7 +2181,7 @@ subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin) ! to ensemble grid. ! the ensemble part is still not updated for ! generalized control variable -! 2010-05-18 todling - revisited bundle usage in light of Dave's change (2010-05-07) +! 2010-05-18 todling - revisited bundle usage in light of dave's change (2010-05-07) ! 2011-02-28 parrish - bundle changes ! 2011-10-03 wu - add option to weight ensemble contribution to surface pressure with vertical profile ! 2011-11-01 kleist - 4d capability for ensemble/hybrid @@ -2204,128 +2204,128 @@ subroutine ensemble_forward_model_ad_dual_res(cvec,a_en,ibin) ! machine: ibm RS/6000 SP ! !$$$ - use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt - use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,p_e2a - use hybrid_ensemble_parameters, only: en_perts - use general_sub2grid_mod, only: general_sube2suba_ad - use gridmod,only: regional - use constants, only: zero - implicit none - - type(gsi_bundle),intent(inout) :: cvec - type(gsi_bundle),intent(inout) :: a_en(n_ens) - integer,intent(in) :: ibin - - character(len=*),parameter::myname_=trim(myname)//'*ensemble_forward_model_ad_dual_res' - type(gsi_grid) :: grid_ens,grid_anl - type(gsi_bundle) :: work_ens,work_anl - integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipx,ipic,km_tmp - integer(i_kind) :: ipc2d(nc2d),ipc3d(nc3d),istatus - -! Request ensemble-corresponding fields from control vector -! NOTE: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and -! ipc2d indices for cvec and en_perts bundles. - call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 3d pointers' - call stop2(999) - endif - call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) - if(istatus/=0) then - write(6,*) myname_,': cannot find 2d pointers' - call stop2(999) - endif - - call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) - call gsi_bundlecreate (work_ens,grid_ens,'ensemble work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating work_ens bundle' - call stop2(999) - endif - call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) - call gsi_bundlecreate (work_anl,grid_anl,'analysis work',istatus, & - names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble creating work_anl bundle' - call stop2(999) - endif - - do ic3=1,nc3d - work_anl%r3(ipc3d(ic3))%q=cvec%r3(ipc3d(ic3))%q - enddo - do ic2=1,nc2d - work_anl%r2(ipc2d(ic2))%q=cvec%r2(ipc2d(ic2))%q - enddo - work_ens%values=zero - call general_sube2suba_ad(grd_ens,grd_anl,p_e2a,work_ens%values,work_anl%values,regional) - call gsi_bundledestroy(work_anl,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying work anl bundle' - call stop2(999) - endif - - ipx=1 - im=a_en(1)%grid%im - jm=a_en(1)%grid%jm - km=a_en(1)%grid%km + use hybrid_ensemble_parameters, only: n_ens,pwgtflg,pwgt + use hybrid_ensemble_parameters, only: n_ens,grd_ens,grd_anl,p_e2a + use hybrid_ensemble_parameters, only: en_perts + use general_sub2grid_mod, only: general_sube2suba_ad + use gridmod,only: regional + use constants, only: zero + implicit none + + type(gsi_bundle),intent(inout) :: cvec + type(gsi_bundle),intent(inout) :: a_en(n_ens) + integer(i_kind),intent(in) :: ibin + + character(len=*),parameter::myname_=trim(myname)//'*ensemble_forward_model_ad_dual_res' + type(gsi_grid) :: grid_ens,grid_anl + type(gsi_bundle) :: work_ens,work_anl + integer(i_kind) :: i,j,k,n,im,jm,km,ic2,ic3,ipx,ipic,km_tmp + integer(i_kind) :: ipc2d(nc2d),ipc3d(nc3d),istatus + +! Request ensemble-corresponding fields from control vector +! Note: because ensemble perturbation bundle structure is same as control vector, use same ipc3d and +! ipc2d indices for cvec and en_perts bundles. + call gsi_bundlegetpointer (cvec,cvars3d,ipc3d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 3d pointers' + call stop2(999) + endif + call gsi_bundlegetpointer (cvec,cvars2d,ipc2d,istatus) + if(istatus/=0) then + write(6,*) myname_,': cannot find 2d pointers' + call stop2(999) + endif + + call gsi_gridcreate(grid_ens,grd_ens%lat2,grd_ens%lon2,grd_ens%nsig) + call gsi_bundlecreate (work_ens,grid_ens,'ensemble work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating work_ens bundle' + call stop2(999) + endif + call gsi_gridcreate(grid_anl,grd_anl%lat2,grd_anl%lon2,grd_anl%nsig) + call gsi_bundlecreate (work_anl,grid_anl,'analysis work',istatus, & + names2d=cvars2d,names3d=cvars3d,bundle_kind=r_kind) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble creating work_anl bundle' + call stop2(999) + endif + + do ic3=1,nc3d + work_anl%r3(ipc3d(ic3))%q=cvec%r3(ipc3d(ic3))%q + enddo + do ic2=1,nc2d + work_anl%r2(ipc2d(ic2))%q=cvec%r2(ipc2d(ic2))%q + enddo + work_ens%values=zero + call general_sube2suba_ad(grd_ens,grd_anl,p_e2a,work_ens%values,work_anl%values,regional) + call gsi_bundledestroy(work_anl,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying work anl bundle' + call stop2(999) + endif + + ipx=1 + im=a_en(1)%grid%im + jm=a_en(1)%grid%jm + km=a_en(1)%grid%km !$omp parallel do schedule(dynamic,1) private(j,n,ic3,k,i,ic2,ipic) - do n=1,n_ens - do ic3=1,nc3d - ipic=ipc3d(ic3) - do k=1,km - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & - +work_ens%r3(ipic)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) - enddo - enddo - enddo - enddo - do ic2=1,nc2d - - ipic=ipc2d(ic2) - select case ( trim(StrUpCase(cvars2d(ic2))) ) - - case('PS') - - if ( pwgtflg ) then - km_tmp = km - else - km_tmp = 1 - endif - - do k=1,km_tmp - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & - +work_ens%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) - enddo - enddo - enddo - - case('SST') - - do j=1,jm - do i=1,im - a_en(n)%r3(ipx)%q(i,j,1)=a_en(n)%r3(ipx)%q(i,j,1) & - +work_ens%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) - enddo - enddo - - end select - enddo - enddo ! enddo n_ens - call gsi_bundledestroy(work_ens,istatus) - if(istatus/=0) then - write(6,*)trim(myname_),': trouble destroying work ens bundle' - call stop2(999) - endif - return - - end subroutine ensemble_forward_model_ad_dual_res - - subroutine special_sd2h0 + do n=1,n_ens + do ic3=1,nc3d + ipic=ipc3d(ic3) + do k=1,km + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & + +work_ens%r3(ipic)%q(i,j,k)*en_perts(n,ibin)%r3(ipic)%qr4(i,j,k) + enddo + enddo + enddo + enddo + do ic2=1,nc2d + + ipic=ipc2d(ic2) + select case ( trim(strupcase(cvars2d(ic2))) ) + + case('PS') + + if ( pwgtflg ) then + km_tmp = km + else + km_tmp = 1 + endif + + do k=1,km_tmp + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,k)=a_en(n)%r3(ipx)%q(i,j,k) & + +work_ens%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j)*pwgt(i,j,k) + enddo + enddo + enddo + + case('SST') + + do j=1,jm + do i=1,im + a_en(n)%r3(ipx)%q(i,j,1)=a_en(n)%r3(ipx)%q(i,j,1) & + +work_ens%r2(ipic)%q(i,j)*en_perts(n,ibin)%r2(ipic)%qr4(i,j) + enddo + enddo + + end select + enddo + enddo ! enddo n_ens + call gsi_bundledestroy(work_ens,istatus) + if(istatus/=0) then + write(6,*)trim(myname_),': trouble destroying work ens bundle' + call stop2(999) + endif + return + +end subroutine ensemble_forward_model_ad_dual_res + +subroutine special_sd2h0 !$$$ subprogram documentation block ! . . . . ! subprogram: special_sd2h0 initialize subroutine special_sd2h @@ -2336,7 +2336,7 @@ subroutine special_sd2h0 ! ! program history log: ! 2009-06-16 parrish -! 2010-02-10 parrish, correct allocate error on ndrecv_sd2h, found by Arthur Mizzi. +! 2010-02-10 parrish, correct allocate error on ndrecv_sd2h, found by arthur mizzi. ! ! input argument list: ! @@ -2348,127 +2348,127 @@ subroutine special_sd2h0 ! !$$$ - use kinds, only: r_kind,i_kind - use mpimod, only: npe,mype,mpi_comm_world,ierror,mpi_rtype - use gridmod, only: nlat,nlon,nnnn1o,regional,vlevs - use berror, only: nx,ny,nf - implicit none - - integer(i_kind),dimension(0:npe-1):: nh_0_all,nh_1_all,nv_0_all,nv_1_all - integer(i_kind) nvert,nh_tot,nh_this,nn,nv_tot,nv_this,kchk,n,kk,i,k - real(r_kind),allocatable:: zsub(:,:),z(:) - -! set nval2f (loosely paraphrased from jfunc.f90) - - nscl=3 ! hard-wired here, later generalize when generalizing control variables - if(regional) then - nval2f=nlat*nlon - else - nval2f=ny*nx + 2*(2*nf+1)*(2*nf+1) - end if - - - allocate(nsend_sd2h(0:npe-1),ndsend_sd2h(0:npe),nrecv_sd2h(0:npe-1),ndrecv_sd2h(0:npe)) - allocate(i_recv(nval2f*nnnn1o),k_recv(nval2f*nnnn1o)) - nvert=vlevs - -! compute nv_0,nv_1 - - nv_tot=nvert - nv_this=nv_tot/npe - if(mod(nv_tot,npe)==0) then - kchk=npe - else - nv_this=nv_this+1 - kchk=mod(nv_tot,npe) - end if - - nv_0_all=-1 - nv_1_all=-2 - nn=0 - do n=1,npe - if(n<=kchk) then - kk=nv_this - else - kk=nv_this-1 - end if - if(kk>0) then - nv_0_all(n-1)=nn+1 - nv_1_all(n-1)=nn+kk - end if - nn=nn+kk - enddo - nv_0=nv_0_all(mype) - nv_1=nv_1_all(mype) + use kinds, only: r_kind,i_kind + use mpimod, only: npe,mype,mpi_comm_world,ierror,mpi_rtype + use gridmod, only: nlat,nlon,nnnn1o,regional,vlevs + use berror, only: nx,ny,nf + implicit none + + integer(i_kind),dimension(0:npe-1):: nh_0_all,nh_1_all,nv_0_all,nv_1_all + integer(i_kind) nvert,nh_tot,nh_this,nn,nv_tot,nv_this,kchk,n,kk,i,k + real(r_kind),allocatable:: zsub(:,:),z(:) + +! set nval2f (loosely paraphrased from jfunc.f90) + + nscl=3 ! hard-wired here, later generalize when generalizing control variables + if(regional) then + nval2f=nlat*nlon + else + nval2f=ny*nx + 2*(2*nf+1)*(2*nf+1) + end if + + + allocate(nsend_sd2h(0:npe-1),ndsend_sd2h(0:npe),nrecv_sd2h(0:npe-1),ndrecv_sd2h(0:npe)) + allocate(i_recv(nval2f*nnnn1o),k_recv(nval2f*nnnn1o)) + nvert=vlevs + +! compute nv_0,nv_1 + + nv_tot=nvert + nv_this=nv_tot/npe + if(mod(nv_tot,npe)==0) then + kchk=npe + else + nv_this=nv_this+1 + kchk=mod(nv_tot,npe) + end if + + nv_0_all=-1 + nv_1_all=-2 + nn=0 + do n=1,npe + if(n<=kchk) then + kk=nv_this + else + kk=nv_this-1 + end if + if(kk>0) then + nv_0_all(n-1)=nn+1 + nv_1_all(n-1)=nn+kk + end if + nn=nn+kk + enddo + nv_0=nv_0_all(mype) + nv_1=nv_1_all(mype) ! compute nh_0, nh_1 - nh_tot=nval2f - nh_this=nh_tot/npe - if(mod(nh_tot,npe)/=0) nh_this=nh_this+1 - if(mod(nh_tot,npe)==0) then - kchk=npe - else - kchk=mod(nh_tot,npe) - end if - - nh_0_all=-1 - nh_1_all=-2 - nn=0 - do n=1,npe - if(n<=kchk) then - kk=nh_this - else - kk=nh_this-1 - end if - if(kk>0) then - nh_0_all(n-1)=nn+1 - nh_1_all(n-1)=nn+kk - end if - nn=nn+kk - enddo - nh_0=nh_0_all(mype) - nh_1=nh_1_all(mype) - -! compute nsend_sd2h,ndsend_sd2h,nrecv_sd2h,ndrecv_sd2h - - ndsend_sd2h(0)=0 - ndrecv_sd2h(0)=0 - do n=0,npe-1 - nsend_sd2h(n)=max(0,(nv_1_all(n)-nv_0_all(n)+1)*(nh_1-nh_0+1)) - ndsend_sd2h(n+1)=ndsend_sd2h(n)+nsend_sd2h(n) - nrecv_sd2h(n)=max(0,(nv_1-nv_0+1)*(nh_1_all(n)-nh_0_all(n)+1)) - ndrecv_sd2h(n+1)=ndrecv_sd2h(n)+nrecv_sd2h(n) - enddo - allocate(zsub(nh_0:nh_1,nvert),z(nval2f*(nv_1-nv_0+1))) - do k=1,nvert - do i=nh_0,nh_1 - zsub(i,k)=i - enddo - enddo - call mpi_alltoallv(zsub,nsend_sd2h,ndsend_sd2h,mpi_rtype,& - z,nrecv_sd2h,ndrecv_sd2h,mpi_rtype,mpi_comm_world,ierror) - do i=1,nval2f*(nv_1-nv_0+1) - i_recv(i)=nint(z(i)) - enddo - - do k=1,nvert - do i=nh_0,nh_1 - zsub(i,k)=k - enddo - enddo - call mpi_alltoallv(zsub,nsend_sd2h,ndsend_sd2h,mpi_rtype,& - z,nrecv_sd2h,ndrecv_sd2h,mpi_rtype,mpi_comm_world,ierror) - do i=1,nval2f*(nv_1-nv_0+1) - k_recv(i)=nint(z(i)) - enddo - - deallocate(zsub,z) - return - - end subroutine special_sd2h0 - - subroutine special_sd2h(zsub,z) + nh_tot=nval2f + nh_this=nh_tot/npe + if(mod(nh_tot,npe)/=0) nh_this=nh_this+1 + if(mod(nh_tot,npe)==0) then + kchk=npe + else + kchk=mod(nh_tot,npe) + end if + + nh_0_all=-1 + nh_1_all=-2 + nn=0 + do n=1,npe + if(n<=kchk) then + kk=nh_this + else + kk=nh_this-1 + end if + if(kk>0) then + nh_0_all(n-1)=nn+1 + nh_1_all(n-1)=nn+kk + end if + nn=nn+kk + enddo + nh_0=nh_0_all(mype) + nh_1=nh_1_all(mype) + +! compute nsend_sd2h,ndsend_sd2h,nrecv_sd2h,ndrecv_sd2h + + ndsend_sd2h(0)=0 + ndrecv_sd2h(0)=0 + do n=0,npe-1 + nsend_sd2h(n)=max(0,(nv_1_all(n)-nv_0_all(n)+1)*(nh_1-nh_0+1)) + ndsend_sd2h(n+1)=ndsend_sd2h(n)+nsend_sd2h(n) + nrecv_sd2h(n)=max(0,(nv_1-nv_0+1)*(nh_1_all(n)-nh_0_all(n)+1)) + ndrecv_sd2h(n+1)=ndrecv_sd2h(n)+nrecv_sd2h(n) + enddo + allocate(zsub(nh_0:nh_1,nvert),z(nval2f*(nv_1-nv_0+1))) + do k=1,nvert + do i=nh_0,nh_1 + zsub(i,k)=i + enddo + enddo + call mpi_alltoallv(zsub,nsend_sd2h,ndsend_sd2h,mpi_rtype,& + z,nrecv_sd2h,ndrecv_sd2h,mpi_rtype,mpi_comm_world,ierror) + do i=1,nval2f*(nv_1-nv_0+1) + i_recv(i)=nint(z(i)) + enddo + + do k=1,nvert + do i=nh_0,nh_1 + zsub(i,k)=k + enddo + enddo + call mpi_alltoallv(zsub,nsend_sd2h,ndsend_sd2h,mpi_rtype,& + z,nrecv_sd2h,ndrecv_sd2h,mpi_rtype,mpi_comm_world,ierror) + do i=1,nval2f*(nv_1-nv_0+1) + k_recv(i)=nint(z(i)) + enddo + + deallocate(zsub,z) + return + +end subroutine special_sd2h0 + +subroutine special_sd2h(zsub,z) !$$$ subprogram documentation block ! . . . . ! subprogram: special_sd2h subdomain to slab for variable a_en @@ -2500,7 +2500,7 @@ subroutine special_sd2h(zsub,z) implicit none real(r_kind),dimension(nh_0:nh_1,vlevs,nscl),intent(in ) :: zsub - real(r_kind),dimension(nval2f,nv_0:nv_1,nscl) ,intent( out) :: z + real(r_kind),dimension(nval2f,nv_0:nv_1,nscl),intent( out) :: z real(r_kind) zsub1(nh_0:nh_1,vlevs),work(nval2f*(nv_1-nv_0+1)) integer(i_kind) i,ii,is,k @@ -2539,11 +2539,11 @@ subroutine sqrt_beta_s_mult_cvec(grady) ! ! program history log: ! 2009-10-12 parrish initial documentation -! 2010-03-29 kleist comment out beta_s0 for SST +! 2010-03-29 kleist comment out beta_s0 for sst ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional ! 2012-05-12 el akkraoui hybrid beta parameters now vertically varying -! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance +! 2015-09-18 todling - add sst_staticb to control use of ensemble sst error covariance ! ! input argument list: ! grady - input field grady_x1 @@ -2560,7 +2560,7 @@ subroutine sqrt_beta_s_mult_cvec(grady) use gsi_4dvar, only: nsubwin use hybrid_ensemble_parameters, only: oz_univ_static use hybrid_ensemble_parameters, only: sqrt_beta_s - use hybrid_ensemble_parameters, only: sst_staticB + use hybrid_ensemble_parameters, only: sst_staticb use constants, only: one use gsi_bundlemod, only: gsi_bundlegetpointer use control_vectors,only: control_vector @@ -2581,7 +2581,7 @@ subroutine sqrt_beta_s_mult_cvec(grady) ! Initialize timer call timer_ini('sqrt_beta_s_mult_cvec') - ! Request CV pointers to vars pertinent to ensemble + ! Request cv pointers to vars pertinent to ensemble call gsi_bundlegetpointer ( grady%step(1), cvars3d, ipc3d, istatus ) if ( istatus /= 0 ) then write(6,*) myname_,': cannot proceed, CV does not contain ens-required 3d fields' @@ -2599,7 +2599,7 @@ subroutine sqrt_beta_s_mult_cvec(grady) do ii=1,nsubwin do ic3=1,nc3d ! check for ozone and skip if oz_univ_static = true - if ( trim(StrUpCase(cvars3d(ic3))) == 'OZ' .and. oz_univ_static ) cycle + if ( trim(strupcase(cvars3d(ic3))) == 'OZ' .and. oz_univ_static ) cycle do k=1,nsig do i=1,lat2 grady%step(ii)%r3(ipc3d(ic3))%q(i,j,k) = sqrt_beta_s(k)*grady%step(ii)%r3(ipc3d(ic3))%q(i,j,k) @@ -2607,12 +2607,12 @@ subroutine sqrt_beta_s_mult_cvec(grady) enddo enddo do ic2=1,nc2d - ! Default to static B estimate for SST - if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) then - if(sst_staticB) then + ! Default to static b estimate for sst + if ( trim(strupcase(cvars2d(ic2))) == 'SST' ) then + if(sst_staticb) then cycle else - if(j==1.and.mype==0) write(6,*) myname_, ': scale static SST B-error by ', sqrt_beta_s(1) + if(j==1.and.mype==0) write(6,*) myname_, ': scale static SST B-error by ', sqrt_beta_s(1) endif endif do i=1,lat2 @@ -2638,11 +2638,11 @@ subroutine sqrt_beta_s_mult_bundle(grady) ! ! program history log: ! 2009-10-12 parrish initial documentation -! 2010-03-29 kleist comment out sqrt_beta_s for SST +! 2010-03-29 kleist comment out sqrt_beta_s for sst ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional ! 2012-05-12 el akkraoui hybrid beta parameters now vertically varying -! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance +! 2015-09-18 todling - add sst_staticb to control use of ensemble sst error covariance ! ! input argument list: ! grady - input field grady_x1 @@ -2658,7 +2658,7 @@ subroutine sqrt_beta_s_mult_bundle(grady) use kinds, only: r_kind,i_kind use hybrid_ensemble_parameters, only: oz_univ_static use hybrid_ensemble_parameters, only: sqrt_beta_s - use hybrid_ensemble_parameters, only: sst_staticB + use hybrid_ensemble_parameters, only: sst_staticb use constants, only: one use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -2679,7 +2679,7 @@ subroutine sqrt_beta_s_mult_bundle(grady) ! Initialize timer call timer_ini('sqrt_beta_s_mult_bundle') - ! Request CV pointers to vars pertinent to ensemble + ! Request cv pointers to vars pertinent to ensemble call gsi_bundlegetpointer ( grady, cvars3d, ipc3d, istatus ) if ( istatus /= 0 ) then write(6,*) myname_,': cannot proceed, CV does not contain ens-required 3d fields' @@ -2696,7 +2696,7 @@ subroutine sqrt_beta_s_mult_bundle(grady) do j=1,lon2 do ic3=1,nc3d ! check for ozone and skip if oz_univ_static = true - if ( trim(StrUpCase(cvars3d(ic3))) == 'OZ' .and. oz_univ_static ) cycle + if ( trim(strupcase(cvars3d(ic3))) == 'OZ' .and. oz_univ_static ) cycle do k=1,nsig do i=1,lat2 grady%r3(ipc3d(ic3))%q(i,j,k) = sqrt_beta_s(k)*grady%r3(ipc3d(ic3))%q(i,j,k) @@ -2704,9 +2704,9 @@ subroutine sqrt_beta_s_mult_bundle(grady) enddo enddo do ic2=1,nc2d - ! Default to static B estimate for SST - if ( trim(StrUpCase(cvars2d(ic2))) == 'SST' ) then - if(sst_staticB) then + ! Default to static b estimate for sst + if ( trim(strupcase(cvars2d(ic2))) == 'SST' ) then + if(sst_staticb) then cycle else if(mype==0) write(6,*) myname_, ': scale static SST B-error by ', sqrt_beta_s(1) @@ -2734,7 +2734,7 @@ subroutine sqrt_beta_e_mult_cvec(grady) ! ! program history log: ! 2009-10-12 parrish initial documentation -! 2010-03-29 kleist comment out sqrt_beta_e for SST +! 2010-03-29 kleist comment out sqrt_beta_e for sst ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional ! 12-05-2012 el akkraoui hybrid beta parameters now vertically varying @@ -2800,7 +2800,7 @@ subroutine sqrt_beta_e_mult_bundle(aens) ! ! program history log: ! 2009-10-12 parrish initial documentation -! 2010-03-29 kleist comment out sqrt_beta_e for SST +! 2010-03-29 kleist comment out sqrt_beta_e for sst ! 2010-04-28 todling update to use gsi_bundle ! 2011-06-13 wu used height dependent beta for regional ! 12-05-2012 el akkraoui hybrid beta parameters now vertically varying @@ -2964,7 +2964,7 @@ subroutine init_sf_xy(jcap_in) write(6,*)' ensemble and analysis nlat,nlon are the same ' else do j=1,grd_ens%nlon - if(j.le.nlon_sploc) then + if(j<=nlon_sploc) then write(6,'(" j,rlon_sploc(j),rlon_ens(j)=",i4,2f12.3)') & j,rad2deg*sp_loc%rlons(j),rad2deg*sp_ens%rlons(j) else @@ -2973,7 +2973,7 @@ subroutine init_sf_xy(jcap_in) end if enddo do i=1,grd_ens%nlat - if(i.le.nlat_sploc) then + if(i<=nlat_sploc) then write(6,'(" i,rlat_sploc(i),rlat_ens(i)=",i4,2f12.3)') & i,rad2deg*sp_loc%rlats(i),rad2deg*sp_ens%rlats(i) else @@ -2997,33 +2997,33 @@ subroutine init_sf_xy(jcap_in) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! how spectrum is obtained: ! -! Correlation matrix: C = Y*D*Ytrans +! Correlation matrix: c = y*d*ytrans ! -! where Y is matrix of spherical harmonics, evaluated on gaussian grid, and D is a diagonal matrix +! where y is matrix of spherical harmonics, evaluated on gaussian grid, and d is a diagonal matrix ! -! To obtain D, exploit fact that for D a function only of total wave-number n, then C is homogeneous +! To obtain d, exploit fact that for d a function only of total wave-number n, then c is homogeneous ! and isotropic on the sphere. ! ! So look at the special case of a test point centered on the north pole. The correlation function ! is then only a function of latitude, call it c(phi), where c(pi/2) = 1. ! -! Now we have C = P*D*Ptrans, where we have reduced the problem to 1 dimension, latitude, and in -! spectral space, total wave number n. P is the zonal component only of Y. +! Now we have c = p*d*ptrans, where we have reduced the problem to 1 dimension, latitude, and in +! spectral space, total wave number n. p is the zonal component only of y. ! ! Next, form the product -! C*e1 =P*D*Ptrans*e1, +! c*e1 =p*d*ptrans*e1, ! ! where e1 is a vector of all 0, except for 1 at the north pole. ! -! Then have P*D*Ptrans*e1 = sum(n) p(n,j)*d(n)*p(n,1) = c(j,1) +! Then have p*d*ptrans*e1 = sum(n) p(n,j)*d(n)*p(n,1) = c(j,1) ! ! where j=1 corresponds to north pole point in this formulation. ! -! Now if we have available C(j,1), a gaussian of desired length-scale evaluated (note, doesn't have to +! Now if we have available c(j,1), a gaussian of desired length-scale evaluated (note, doesn't have to ! be gaussian!) on the gaussian grid, then applying the inverse transform subroutine g2s0 to -! C yields the product +! c yields the product ! -! Chat(n) = d(n)*p(n,1) +! chat(n) = d(n)*p(n,1) ! ! So finally the desired spectrum is ! @@ -3158,20 +3158,20 @@ subroutine init_sf_xy(jcap_in) enddo if(make_test_maps) then - ftest=zero - do k=grd_loc%kbegin_loc,grd_loc%kend_loc - ftest(grd_ens%nlat/2,grd_ens%nlon/2,k)=one - enddo - call sf_xy(ftest,grd_loc%kbegin_loc,grd_loc%kend_loc) - if(mype==0) then - do j=1,grd_ens%nlon - do i=1,grd_ens%nlat - out1(j,i)=ftest(i,j,grd_loc%kbegin_loc) - enddo + ftest=zero + do k=grd_loc%kbegin_loc,grd_loc%kend_loc + ftest(grd_ens%nlat/2,grd_ens%nlon/2,k)=one enddo - write(mapname,'("out_",i2.2)')1+mod(grd_loc%kbegin_loc-1,grd_ens%nsig) - call outgrads1(out1,grd_ens%nlon,grd_ens%nlat,mapname) - end if + call sf_xy(ftest,grd_loc%kbegin_loc,grd_loc%kend_loc) + if(mype==0) then + do j=1,grd_ens%nlon + do i=1,grd_ens%nlat + out1(j,i)=ftest(i,j,grd_loc%kbegin_loc) + enddo + enddo + write(mapname,'("out_",i2.2)')1+mod(grd_loc%kbegin_loc-1,grd_ens%nsig) + call outgrads1(out1,grd_ens%nlon,grd_ens%nlat,mapname) + end if end if deallocate(rkm,f,f0) return @@ -3197,7 +3197,7 @@ subroutine sf_xy(f,k_start,k_end) ! k_start - starting horizontal slab index ! k_end - ending horizontal slab index (k_end can be less than k_start, meaning there is ! no work on this processor) -! NOTE: above args allow horizontal localization length to vary in vertical +! Note: above args allow horizontal localization length to vary in vertical ! ! output argument list: ! f - filtered output @@ -3224,19 +3224,19 @@ subroutine sf_xy(f,k_start,k_end) if(.not.use_localization_grid) then !$omp parallel do schedule(dynamic,1) private(k) - do k=k_start,k_end - call sfilter(grd_ens,sp_loc,spectral_filter(1,k_index(k)),f(1,1,k)) - enddo + do k=k_start,k_end + call sfilter(grd_ens,sp_loc,spectral_filter(1,k_index(k)),f(1,1,k)) + enddo else - vector=.false. + vector=.false. !$omp parallel do schedule(dynamic,1) private(k,work) - do k=k_start,k_end - call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) - call sfilter(grd_ens,sp_loc,spectral_filter(:,k_index(k)),f(1,1,k)) - call g_egrid2agrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) - enddo + do k=k_start,k_end + call g_egrid2agrid_ad(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) + call sfilter(grd_ens,sp_loc,spectral_filter(:,k_index(k)),f(1,1,k)) + call g_egrid2agrid(p_sploc2ens,work,f(:,:,k:k),k,k,vector(k:k)) + enddo endif return @@ -3260,7 +3260,7 @@ subroutine sqrt_sf_xy(z,f,k_start,k_end) ! k_start - starting horizontal slab index ! k_end - ending horizontal slab index (k_end can be less than k_start, meaning there is ! no work on this processor) -! NOTE: above args allow horizontal localization length to vary in vertical +! Note: above args allow horizontal localization length to vary in vertical ! ! output argument list: ! f - output grid space variable @@ -3288,10 +3288,10 @@ subroutine sqrt_sf_xy(z,f,k_start,k_end) if(.not.use_localization_grid) then - do k=k_start,k_end - g(:)=z(:,k)*sqrt_spectral_filter(:,k_index(k)) - call general_s2g0(grd_ens,sp_loc,g,f(:,:,k)) - enddo + do k=k_start,k_end + g(:)=z(:,k)*sqrt_spectral_filter(:,k_index(k)) + call general_s2g0(grd_ens,sp_loc,g,f(:,:,k)) + enddo else @@ -3324,7 +3324,7 @@ subroutine sqrt_sf_xy_ad(z,f,k_start,k_end) ! k_start - starting horizontal slab index ! k_end - ending horizontal slab index (k_end can be less than k_start, meaning there is ! no work on this processor) -! NOTE: above args allow horizontal localization length to vary in vertical +! Note: above args allow horizontal localization length to vary in vertical ! ! output argument list: ! z - spectral space variable @@ -3353,10 +3353,10 @@ subroutine sqrt_sf_xy_ad(z,f,k_start,k_end) if(.not.use_localization_grid) then - do k=k_start,k_end - call general_s2g0_ad(grd_ens,sp_loc,g,f(:,:,k)) - z(:,k)=g(:)*sqrt_spectral_filter(:,k_index(k)) - enddo + do k=k_start,k_end + call general_s2g0_ad(grd_ens,sp_loc,g,f(:,:,k)) + z(:,k)=g(:)*sqrt_spectral_filter(:,k_index(k)) + enddo else @@ -3380,7 +3380,7 @@ subroutine get_new_alpha_beta(aspect,ng,fmat_out,fmat0_out) ! ! prgrmmr: ! -! abstract: compute various constants for new factorization Purser 1-d high-order filter. +! abstract: compute various constants for new factorization purser 1-d high-order filter. ! adapted as simplification from new_alpha_betaa4 in raflib.f90 for use with ! simple homogeneous isotropic localization filter. ! @@ -3503,7 +3503,7 @@ subroutine bkerror_a_en(gradx,grady) ! deallocate(z) !else ! write(6,*)' using bkgcov_a_en_new_factorization' - call bkgcov_a_en_new_factorization(grady%aens(ii,1:n_ens)) + call bkgcov_a_en_new_factorization(grady%aens(ii,1:n_ens)) !end if enddo @@ -3662,7 +3662,7 @@ subroutine ckgcov_a_en_new_factorization(z,a_en) ! Local Variables integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) +!Note: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) ! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, ! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global ! but internal array hwork always has @@ -3742,12 +3742,12 @@ subroutine ckgcov_a_en_new_factorization_ad(z,a_en) ! ! input argument list: ! z - long vector containing sqrt control vector for ensemble extended control variable -! a_en - bundle containing intermediate control variable after multiplication by sqrt(S), the +! a_en - bundle containing intermediate control variable after multiplication by sqrt(s), the ! ensemble localization correlation. ! ! output argument list: ! z - long vector containing sqrt control vector for ensemble extended control variable -! a_en - bundle containing intermediate control variable after multiplication by sqrt(S), the +! a_en - bundle containing intermediate control variable after multiplication by sqrt(s), the ! ensemble localization correlation. ! ! attributes: @@ -3772,7 +3772,7 @@ subroutine ckgcov_a_en_new_factorization_ad(z,a_en) ! Local Variables integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) +!Note: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) ! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, ! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global ! but internal array hwork always has @@ -3897,21 +3897,21 @@ subroutine hybens_grid_setup ! Initialize dual_res logical if (.not.regional) then - dual_res = (nlon /= nlon_ens .or. nlat /= nlat_ens) + dual_res = (nlon /= nlon_ens .or. nlat /= nlat_ens) else - dual_res=.false. + dual_res=.false. end if if(mype==0) write(6,*)' before compute nlat_ens,nlon_ens, nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',& nlat,nlon,nlat_ens,nlon_ens,r_e,eps -! if regional set up for possible dual-res application: +! if regional set up for possible dual-res application: if(regional) then call get_regional_dual_res_grid(eps,r_e,nlon,nlon_ens,rlon_a,rlon_e) call get_regional_dual_res_grid(eps,r_e,nlat,nlat_ens,rlat_a,rlat_e) call create_egrid2agrid(nlat,rlat_a,nlon,rlon_a,nlat_ens,rlat_e,nlon_ens,rlon_e,nord_e2a,p_e2a) dual_res=.not.p_e2a%identity -! NOTE: key dual-res on egrid2agrid parameter p_e2a%identity, not nlat_ens==nlat .or. nlon_ens==nlon +! Note: key dual-res on egrid2agrid parameter p_e2a%identity, not nlat_ens==nlat .or. nlon_ens==nlon allocate(region_lat_ens(nlat_ens,nlon_ens)) allocate(region_lon_ens(nlat_ens,nlon_ens)) allocate(region_dx_ens(nlat_ens,nlon_ens)) @@ -3924,8 +3924,8 @@ subroutine hybens_grid_setup region_lat_ens=region_lat end if end if - if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',& - dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps + if(mype==0) write(6,*)' dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps=',& + dual_res,nlat,nlon,nlat_ens,nlon_ens,r_e,eps if(nlon_ens<=0 .or. nlat_ens<=0) then nlon_ens=nlon ; nlat_ens=nlat @@ -4001,148 +4001,148 @@ subroutine hybens_localization_setup ! machine: ibm RS/6000 SP ! !$$$ - use kinds, only: r_kind,i_kind - use constants, only: one,zero - use mpimod, only: mype - use gridmod,only: regional - use gfs_stratosphere, only: use_gfs_stratosphere,blend_rm - use hybrid_ensemble_parameters, only: grd_ens,jcap_ens,n_ens,grd_loc,sp_loc,& - nval_lenz_en,regional_ensemble_option - use hybrid_ensemble_parameters, only: readin_beta,beta_s,beta_e,beta_s0,sqrt_beta_s,sqrt_beta_e - use hybrid_ensemble_parameters, only: readin_localization,create_hybens_localization_parameters, & - vvlocal,s_ens_h,s_ens_hv,s_ens_v,s_ens_vv - use gsi_io, only: verbose - - implicit none - - integer(i_kind),parameter :: lunin = 47 - character(len=40),parameter :: fname = 'hybens_info' - integer(i_kind) :: k,msig,istat,nz,kl - logical :: lexist,print_verbose - real(r_kind),allocatable:: s_ens_h_gu_x(:),s_ens_h_gu_y(:) - print_verbose=.false. .and. mype == 0 - if(verbose .and. mype == 0)print_verbose=.true. - - ! Allocate - call create_hybens_localization_parameters - - if ( readin_localization .or. readin_beta ) then ! read info from file - - inquire(file=trim(fname),exist=lexist) - if ( lexist ) then - open(lunin,file=trim(fname),form='formatted') - rewind(lunin) - read(lunin,100,iostat=istat) msig - if ( istat /= 0 ) then - write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) - write(6,*) 'HYBENS_LOCALIZATION_SETUP: error reading file, iostat = ',istat - call stop2(123) - endif - if ( msig /= grd_ens%nsig ) then - write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) - write(6,*) 'HYBENS_LOCALIZATION_SETUP: levels do not match,msig[read in],nsig[defined] = ',msig,grd_ens%nsig - close(lunin) - call stop2(123) - endif - if(mype==0) write(6,'(" LOCALIZATION, BETA_S, BETA_E VERTICAL PROFILES FOLLOW")') - do k = 1,grd_ens%nsig - read(lunin,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) - if(mype==0) write(6,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) - enddo - close(lunin) - - else - - write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** INPUT FILE MISSING -- ',trim(fname) - call stop2(999) - - endif - - if ( readin_localization ) then - vvlocal = .true. - nz = msig - kl = grd_loc%kend_alloc-grd_loc%kbegin_loc+1 - if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens)) - if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens)) - endif - - endif ! if ( readin_localization .or. readin_beta ) + use kinds, only: r_kind,i_kind + use constants, only: one,zero + use mpimod, only: mype + use gridmod,only: regional + use gfs_stratosphere, only: use_gfs_stratosphere,blend_rm + use hybrid_ensemble_parameters, only: grd_ens,jcap_ens,n_ens,grd_loc,sp_loc,& + nval_lenz_en,regional_ensemble_option + use hybrid_ensemble_parameters, only: readin_beta,beta_s,beta_e,beta_s0,sqrt_beta_s,sqrt_beta_e + use hybrid_ensemble_parameters, only: readin_localization,create_hybens_localization_parameters, & + vvlocal,s_ens_h,s_ens_hv,s_ens_v,s_ens_vv + use gsi_io, only: verbose + + implicit none + + integer(i_kind),parameter :: lunin = 47 + character(len=40),parameter :: fname = 'hybens_info' + integer(i_kind) :: k,msig,istat,nz,kl + logical :: lexist,print_verbose + real(r_kind),allocatable:: s_ens_h_gu_x(:),s_ens_h_gu_y(:) + print_verbose=.false. .and. mype == 0 + if(verbose .and. mype == 0)print_verbose=.true. + + ! Allocate + call create_hybens_localization_parameters + + if ( readin_localization .or. readin_beta ) then ! read info from file + + inquire(file=trim(fname),exist=lexist) + if ( lexist ) then + open(lunin,file=trim(fname),form='formatted') + rewind(lunin) + read(lunin,100,iostat=istat) msig + if ( istat /= 0 ) then + write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) + write(6,*) 'HYBENS_LOCALIZATION_SETUP: error reading file, iostat = ',istat + call stop2(123) + endif + if ( msig /= grd_ens%nsig ) then + write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** error in ',trim(fname) + write(6,*) 'HYBENS_LOCALIZATION_SETUP: levels do not match,msig[read in],nsig[defined] = ',msig,grd_ens%nsig + close(lunin) + call stop2(123) + endif + if(mype==0) write(6,'(" LOCALIZATION, BETA_S, BETA_E VERTICAL PROFILES FOLLOW")') + do k = 1,grd_ens%nsig + read(lunin,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) + if(mype==0) write(6,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) + enddo + close(lunin) + + else + + write(6,*) 'HYBENS_LOCALIZATION_SETUP: ***ERROR*** INPUT FILE MISSING -- ',trim(fname) + call stop2(999) + + endif + + if ( readin_localization ) then + vvlocal = .true. + nz = msig + kl = grd_loc%kend_alloc-grd_loc%kbegin_loc+1 + if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens)) + if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens)) + endif + + endif ! if ( readin_localization .or. readin_beta ) 100 format(I4) !101 format(F8.1,3x,F5.1,2(3x,F8.4)) 101 format(F8.1,3x,F8.3,F8.4,3x,F8.4) - if ( .not. readin_beta ) then ! assign all levels to same value, sum = 1.0 - beta_s = beta_s0 - beta_e = one - beta_s0 - endif - - if ( regional_ensemble_option == 2 .and. use_gfs_stratosphere .and. .not. readin_beta ) then - do k = 1,grd_ens%nsig - beta_e(k) = beta_e(k) * blend_rm(k) - beta_s(k) = one - beta_e(k) - if (print_verbose) write(6,*)'beta_s, beta_e=', & - k,beta_s(k),beta_e(k) - enddo - endif - - if ( .not. readin_localization ) then ! assign all levels to same value, s_ens_h, s_ens_v - nz = 1 - kl = 1 - if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(1)) - if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(1)) - s_ens_hv = s_ens_h - s_ens_vv = s_ens_v - endif + if ( .not. readin_beta ) then ! assign all levels to same value, sum = 1.0 + beta_s = beta_s0 + beta_e = one - beta_s0 + endif + + if ( regional_ensemble_option == 2 .and. use_gfs_stratosphere .and. .not. readin_beta ) then + do k = 1,grd_ens%nsig + beta_e(k) = beta_e(k) * blend_rm(k) + beta_s(k) = one - beta_e(k) + if (print_verbose) write(6,*)'beta_s, beta_e=', & + k,beta_s(k),beta_e(k) + enddo + endif + + if ( .not. readin_localization ) then ! assign all levels to same value, s_ens_h, s_ens_v + nz = 1 + kl = 1 + if(.not.allocated(s_ens_h_gu_x)) allocate(s_ens_h_gu_x(1)) + if(.not.allocated(s_ens_h_gu_y)) allocate(s_ens_h_gu_y(1)) + s_ens_hv = s_ens_h + s_ens_vv = s_ens_v + endif ! Set up localization filters - call init_rf_z(s_ens_vv) - call normal_new_factorization_rf_z - - if ( regional ) then ! convert s_ens_h from km to grid units. - call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) - if ( vvlocal ) then - call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc),kl) - call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc),kl) - else - call init_rf_x(s_ens_h_gu_x,kl) - call init_rf_y(s_ens_h_gu_y,kl) - endif - call normal_new_factorization_rf_x - call normal_new_factorization_rf_y - else - call init_sf_xy(jcap_ens) - endif - - !!!!!!!! setup beta_s, beta_e!!!!!!!!!!!! - ! vertical variation of static and ensemble weights - - ! Set defaults - sqrt_beta_s= sqrt(beta_s) - sqrt_beta_e= sqrt(beta_e) - - ! set value of nval_lenz_en here for now, - ! but will need to rearrange so this can be set in control_vectors - ! and triggered by lsqrtb. - if ( regional ) then - nval_lenz_en = grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) - else - nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) - endif - - ! setup vertical weighting for ensemble contribution to psfc - call setup_pwgt - - ! write out final values for s_ens_hv, s_ens_vv, beta_s, beta_e - if ( print_verbose ) then - write(6,*) 'HYBENS_LOCALIZATION_SETUP: s_ens_hv,s_ens_vv,beta_s,beta_e' - do k=1,grd_ens%nsig - write(6,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) - enddo - endif - - return + call init_rf_z(s_ens_vv) + call normal_new_factorization_rf_z + + if ( regional ) then ! convert s_ens_h from km to grid units. + call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) + if ( vvlocal ) then + call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc),kl) + call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc),kl) + else + call init_rf_x(s_ens_h_gu_x,kl) + call init_rf_y(s_ens_h_gu_y,kl) + endif + call normal_new_factorization_rf_x + call normal_new_factorization_rf_y + else + call init_sf_xy(jcap_ens) + endif + + !!!!!!!! setup beta_s, beta_e!!!!!!!!!!!! + ! vertical variation of static and ensemble weights + + ! Set defaults + sqrt_beta_s= sqrt(beta_s) + sqrt_beta_e= sqrt(beta_e) + + ! set value of nval_lenz_en here for now, + ! but will need to rearrange so this can be set in control_vectors + ! and triggered by lsqrtb. + if ( regional ) then + nval_lenz_en = grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) + else + nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) + endif + + ! setup vertical weighting for ensemble contribution to psfc + call setup_pwgt + + ! write out final values for s_ens_hv, s_ens_vv, beta_s, beta_e + if ( print_verbose ) then + write(6,*) 'HYBENS_LOCALIZATION_SETUP: s_ens_hv,s_ens_vv,beta_s,beta_e' + do k=1,grd_ens%nsig + write(6,101) s_ens_hv(k), s_ens_vv(k), beta_s(k), beta_e(k) + enddo + endif + + return end subroutine hybens_localization_setup @@ -4203,13 +4203,13 @@ subroutine convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) enddo if(nz>1)then - do n=2,n_ens - nk=(n-1)*grd_loc%nsig - do k=1,grd_loc%nsig - s_ens_h_gu_x(nk+k)=s_ens_h_gu_x(k) - s_ens_h_gu_y(nk+k)=s_ens_h_gu_y(k) + do n=2,n_ens + nk=(n-1)*grd_loc%nsig + do k=1,grd_loc%nsig + s_ens_h_gu_x(nk+k)=s_ens_h_gu_x(k) + s_ens_h_gu_y(nk+k)=s_ens_h_gu_y(k) + enddo enddo - enddo endif return @@ -4637,7 +4637,7 @@ subroutine general_sub2grid_1_ens(sub,grid,gridpe,mype,grd) implicit none type(sub2grid_info),intent(in):: grd - integer(i_kind) ,intent(in ) :: gridpe,mype + integer(i_kind),intent(in ) :: gridpe,mype real(r_kind),dimension(grd%lat2,grd%lon2),intent(in ) :: sub real(r_kind),dimension(grd%nlat,grd%nlon),intent( out) :: grid @@ -4699,7 +4699,7 @@ subroutine sub2grid_1_ens(sub,grid,gridpe,mype) use mpimod, only: mpi_comm_world,ierror,mpi_rtype implicit none - integer(i_kind) ,intent(in ) :: gridpe,mype + integer(i_kind),intent(in ) :: gridpe,mype real(r_kind),dimension(grd_ens%lat2,grd_ens%lon2),intent(in ) :: sub real(r_kind),dimension(grd_ens%nlat,grd_ens%nlon),intent( out) :: grid @@ -4786,8 +4786,8 @@ subroutine get_region_lat_lon_ens(region_lat_ens,region_lon_ens,rlat_e,rlon_e,nl enddo enddo enddo - if(mype==0) write(6,*)' min,max(region_lon_ens)=', & - rad2deg*minval(region_lon_ens),rad2deg*maxval(region_lon_ens) + if(mype==0) write(6,*)' min,max(region_lon_ens)=', & + rad2deg*minval(region_lon_ens),rad2deg*maxval(region_lon_ens) make_test_maps=.false. if(make_test_maps.and.mype==0) then @@ -4990,68 +4990,68 @@ subroutine acceptable_for_essl_fft(nin,nout) integer(i_llong) n_eleven,n_seven,n_five,n_three,n_two,n_this_try integer(i_kind),allocatable::n_acceptable_table(:) -! given desired number of points nin, find closest value nout >= nin which -! is allowed by ibm ffts. +! given desired number of points nin, find closest value nout >= nin which +! is allowed by ibm ffts. -! compute table of acceptable length for essl fft - n_acceptable_total=0 - do i_eleven=0,1 - n_eleven=11**i_eleven - do i_seven=0,1 +! compute table of acceptable length for essl fft + n_acceptable_total=0 + do i_eleven=0,1 + n_eleven=11**i_eleven + do i_seven=0,1 n_seven=7**i_seven do i_five=0,1 - n_five=5**i_five - do i_three=0,2 - n_three=3**i_three - do i_two=1,25 - n_two=2**i_two - n_this_try=n_two*n_three*n_five*n_seven*n_eleven - if(n_this_try.le.37748736_i_llong) n_acceptable_total=n_acceptable_total+1 - enddo - enddo + n_five=5**i_five + do i_three=0,2 + n_three=3**i_three + do i_two=1,25 + n_two=2**i_two + n_this_try=n_two*n_three*n_five*n_seven*n_eleven + if(n_this_try<=37748736_i_llong) n_acceptable_total=n_acceptable_total+1 + enddo + enddo enddo - enddo - enddo - allocate(n_acceptable_table(n_acceptable_total)) - i=0 - do i_eleven=0,1 - n_eleven=11**i_eleven - do i_seven=0,1 + enddo + enddo + allocate(n_acceptable_table(n_acceptable_total)) + i=0 + do i_eleven=0,1 + n_eleven=11**i_eleven + do i_seven=0,1 n_seven=7**i_seven do i_five=0,1 - n_five=5**i_five - do i_three=0,2 - n_three=3**i_three - do i_two=1,25 - n_two=2**i_two - n_this_try=n_two*n_three*n_five*n_seven*n_eleven - if(n_this_try.le.37748736_i_llong) then - i=i+1 - n_acceptable_table(i)=n_this_try - end if - enddo - enddo + n_five=5**i_five + do i_three=0,2 + n_three=3**i_three + do i_two=1,25 + n_two=2**i_two + n_this_try=n_two*n_three*n_five*n_seven*n_eleven + if(n_this_try<=37748736_i_llong) then + i=i+1 + n_acceptable_table(i)=n_this_try + end if + enddo + enddo enddo - enddo - enddo - do i=1,n_acceptable_total-1 - do j=i+1,n_acceptable_total - if(n_acceptable_table(j).lt.n_acceptable_table(i)) then + enddo + enddo + do i=1,n_acceptable_total-1 + do j=i+1,n_acceptable_total + if(n_acceptable_table(j) 0, the measure is vertical grid units. ! s_ens_v = 20 and s_ens_v = -0.44 are roughly comparable, and ! connection of .44 is .44 = (sqrt(.15)/sqrt(2))*1.6, where 1.6 is the value used -! by Jeff Whitaker for his distance in which the Gaspari-Cohn function 1st = 0. +! by jeff whitaker for his distance in which the gaspari-cohn function 1st = 0. ! 2010-09-25 parrish - add logical parameter gefs_in_regional to signal use gefs for regional hybens. ! 2010-10-13 parrish - add parameter write_ens_sprd to allow option of writing global ensemble spread ! in byte addressable format for plotting with grads. @@ -146,8 +146,8 @@ module hybrid_ensemble_parameters ! 2013-11-22 kleist - add option for q perturbations ! 2014-05-14 wu - add logical variable vvlocal for vertically verying horizontal localization length in regional ! 2015-01-22 Hu - add flag i_en_perts_io to control reading ensemble perturbation. -! 2015-02-11 Hu - add flag l_ens_in_diff_time to force GSI hybrid use ensembles not available at analysis time -! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance +! 2015-02-11 Hu - add flag l_ens_in_diff_time to force gsi hybrid use ensembles not available at analysis time +! 2015-09-18 todling - add sst_staticb to control use of ensemble sst error covariance ! ! subroutines included: @@ -158,7 +158,7 @@ module hybrid_ensemble_parameters ! def q_hyb_ens - if true, use specific humidity ! def aniso_a_en - if true, then use anisotropic rf for localization ! def generate_ens - if true, then create ensemble members internally -! using sqrt of static background error acting on N(0,1) random vectors +! using sqrt of static background error acting on n(0,1) random vectors ! def n_ens - number of ensemble members ! def nlon_ens - number of longitudes to use for ensemble members and ensemble control vector ! def nlat_ens - number of latitudes to use for ensemble members and ensemble control vector @@ -168,8 +168,8 @@ module hybrid_ensemble_parameters ! =1, then ensemble information turned off ! =0, then static background turned off ! the weights are applied per vertical level such that : -! beta_s(:) = beta_s0 , vertically varying weights given to B ; -! beta_e(:) = 1 - beta_s0 , vertically varying weights given to A. +! beta_s(:) = beta_s0 , vertically varying weights given to b ; +! beta_e(:) = 1 - beta_s0 , vertically varying weights given to a. ! If (readin_beta) then beta_s and beta_e are read from a file and beta_s0 is not used. ! def s_ens_h - homogeneous isotropic horizontal ensemble localization scale (km) ! def s_ens_v - vertical localization scale (grid units for now) @@ -197,31 +197,31 @@ module hybrid_ensemble_parameters ! def pseudo_hybens - if true, read in ensemble member from pseudo ensemble library and merge ! the pseudo ensemble perturbations with global ensemble perturbations. ! def merge_two_grid_ensperts - if true, merge ensemble perturbations from two forecast domains -! to analysis domain (one way to deal with hybrid DA for HWRF moving nest) +! to analysis domain (one way to deal with hybrid da for hwrf moving nest) ! def regional_ensemble_option - integer, used to select type of ensemble to read in for regional ! application. Currently takes values from 1 to 5. -! =1: use GEFS internally interpolated to ensemble grid. -! =2: ensembles are WRF NMM format. -! =3: ensembles are ARW netcdf format. -! =4: ensembles are NEMS NMMB format. +! =1: use gefs internally interpolated to ensemble grid. +! =2: ensembles are wrf nmm format. +! =3: ensembles are arw netcdf format. +! =4: ensembles are nems nmmb format. ! def ntlevs_ens - integer number of time levels for ensemble perturbations. Default is 1, but -! will be equal to nobs_bins (4DVAR) when running in 4d-ensemble-var mode +! will be equal to nobs_bins (4dvar) when running in 4d-ensemble-var mode ! def full_ensemble - logical switch to use ensemble perturbation on first guess or on ensemble mean ! for the first member of ensemble -! def beta_s - vertical weighting function for static B -! def beta_e - vertical weighting function for localization A +! def beta_s - vertical weighting function for static b +! def beta_e - vertical weighting function for localization a ! def sqrt_beta_s - sqrt(beta_s) ! def sqrt_beta_e - sqrt(beta_e) -! def pwgt - vertical integration function for influence of ensemble on Psfc -! def pwgtflg - logical switch to use vertical integration function for ensemble contribution on Psfc +! def pwgt - vertical integration function for influence of ensemble on psfc +! def pwgtflg - logical switch to use vertical integration function for ensemble contribution on psfc ! def grid_ratio_ens: - ratio of ensemble grid resolution to analysis resolution (default value is 1) ! def use_localization_grid - if true, then use extra lower res gaussian grid for horizontal localization ! (global runs only--allows possiblity for non-gaussian ensemble grid) ! def vvlocal - logical switch for vertically varying horizontal localization length ! def i_en_perts_io - flag to write out and read in ensemble perturbations in ensemble grid. -! This is to speed up RAP/HRRR hybrid runs because the +! This is to speed up rap/hrrr hybrid runs because the ! same ensemble perturbations are used in 6 cycles -! =0: No ensemble perturbations IO (default) +! =0: No ensemble perturbations io (default) ! =2: skip get_gefs_for_regional and read in ensemble ! perturbations from saved files. ! def l_ens_in_diff_time - if use ensembles that are available at different @@ -289,9 +289,9 @@ module hybrid_ensemble_parameters public :: region_lat_ens,region_lon_ens public :: region_dx_ens,region_dy_ens public :: ens_fast_read - public :: sst_staticB + public :: sst_staticb - logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB + logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticb logical aniso_a_en logical full_ensemble,pwgtflg logical generate_ens @@ -319,7 +319,7 @@ module hybrid_ensemble_parameters real(r_kind),allocatable,dimension(:,:,:) :: pwgt ! nval_lenz_en is total length of ensemble extended control variable for sqrt ! minimization mode -!NOTE: for sqrt minimization, nval_lenz_en = +!Note: for sqrt minimization, nval_lenz_en = !nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) ! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, ! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global @@ -380,7 +380,7 @@ subroutine init_hybrid_ensemble_parameters uv_hyb_ens=.false. q_hyb_ens=.false. oz_univ_static=.false. - sst_staticB=.true. + sst_staticb=.true. aniso_a_en=.false. generate_ens=.true. pseudo_hybens=.false. @@ -391,7 +391,7 @@ subroutine init_hybrid_ensemble_parameters readin_localization=.false. readin_beta=.false. use_localization_grid=.false. - use_gfs_ens=.true. ! when global: default is to read ensemble from GFS + use_gfs_ens=.true. ! when global: default is to read ensemble from gfs eqspace_ensgrid=.false. vvlocal=.false. l_ens_in_diff_time=.false. @@ -403,14 +403,14 @@ subroutine init_hybrid_ensemble_parameters beta_s0=one grid_ratio_ens=one s_ens_h = 2828._r_kind ! km (this was optimal value in - ! Wang, X.,D. M. Barker, C. Snyder, and T. M. Hamill, 2008: A hybrid - ! ETKF.3DVAR data assimilation scheme for the WRF Model. Part II: - ! Observing system simulation experiment. Mon. Wea. Rev., 136, 5132-5147.) + ! wang, x.,d. m. barker, c. snyder, and t. m. hamill, 2008: A hybrid + ! etkf.3dvar data assimilation scheme for the wrf model. Part II: + ! Observing system simulation experiment. mon. wea. rev., 136, 5132-5147.) s_ens_v = 30._r_kind ! grid units nval_lenz_en=-1 ! initialize dimension to absurd value ntlevs_ens=1 ! default for number of time levels for ensemble perturbations - i_en_perts_io=0 ! default for en_pert IO. 0 is no IO + i_en_perts_io=0 ! default for en_pert io. 0 is no io ensemble_path = './' ! default for path to ensemble members ens_fast_read=.false.