!------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !MODULE: gridmod --- GSI grid related variable declarations ! ! !INTERFACE: ! module gridmod ! !USES: use kinds, only: i_byte,r_kind,r_single,i_kind use general_specmod, only: spec_vars,general_init_spec_vars,general_destroy_spec_vars use general_sub2grid_mod, only: sub2grid_info,general_sub2grid_create_info implicit none ! !DESCRIPTION: module containing grid related variable declarations ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2003-xx-xx parrish,wu regional components added ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2004-12-23 treadon - add routines get_ij and get_ijk ! 2005-01-20 okamoto - add nsig5p1 ! 2005-03-04 derber - add nsig3p3,nsig3p2 ! 2005-03-07 dee - add gmao_intfc option for gmao interface ! 2005-05-24 pondeca - regional surface component added ! 2005-06-01 treadon - add variables msig and array nlayers ! 2005-09-28 derber - put grid calculations into get_ij and get_ijk ! 2006-01-09 derber - add sigsum ! 2006-02-01 parrish - correct error to dx_an, dy_an when using filled_grid ! 2006-04-14 treadon - remove global sigi,sigl; add ntracter,ncloud,ck5 ! 2006-04-17 treadon - remove regional sigi_ll,sigl_ll ! 2006-10-17 kleist - add lat dependent coriolis parameter ! 2007-05-07 treadon - add ncep_sigio, ncepgfs_head(v) ! 2007-05-08 kleist - add variables for fully generalized vertical coordinate ! 2007-10-24 parrish - fix error in wind rotation reference angle field ! 2009-01-28 todling - remove original GMAO interface ! 2009-01-09 gayno - added variables lpl_gfs and dx_gfs ! 2010-03-06 parrish - add logical flag use_gfs_ozone for option to read gfs ozone for regional run ! 2010-03-09 parrish - add logical flag check_gfs_ozone_date--if true, date check against analysis time ! 2010-03-10 lueken - remove hires_b variables, section, and subroutines ! 2010-03-15 parrish - add logical flag regional_ozone to turn on ozone in regional analysis ! 2010-03-10 zhu - make variable vlevs public and general ! 2010-03-30 treadon - move jcap, jcap_b, hires_b, and spectral transform initialization and ! destroy from specmod to gridmod; add grd_a and grd_b structures ! 2010-04-01 treadon - move routines reorder, reorder2, strip_single, strip, ! vectosub, reload, and strip_periodic from mpimod to gridmod ! ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- ! set default to private private ! set subroutines to public public :: init_grid public :: init_grid_vars public :: init_subdomain_vars public :: create_grid_vars public :: destroy_grid_vars public :: create_mapping public :: destroy_mapping public :: init_reg_glob_ll public :: init_general_transform public :: tll2xy public :: txy2ll public :: nearest_3 public :: get_xytilde_domain public :: half_nmm_grid2a public :: fill_nmm_grid2a3 public :: rotate_wind_ll2xy public :: rotate_wind_xy2ll public :: load_grid public :: fill_ns public :: filluv_ns public :: get_ij public :: get_ijk public :: check_rotate_wind public :: reorder public :: reorder2 public :: strip_single public :: strip public :: vectosub public :: reload public :: strip_periodic ! set passed variables to public public :: nnnn1o,iglobal,itotsub,ijn,ijn_s,lat2,lon2,lat1,lon1,nsig public :: ncloud,nlat,nlon,ntracer,displs_s,displs_g,ltosj_s,ltosi_s public :: ltosj,ltosi,bk5,regional,latlon11,latlon1n,twodvar_regional public :: netcdf,nems_nmmb_regional,wrf_mass_regional,wrf_nmm_regional public :: aeta2_ll,pdtop_ll,pt_ll,eta1_ll,eta2_ll,aeta1_ll,idsl5,ck5,ak5 public :: tref5,idvc5,nlayers,msig,jstart,istart,region_lat,vlevs,nsig1o,rlats public :: region_dy,region_dx,region_lon,rlat_min_dd,rlat_max_dd,rlon_max_dd public :: rlon_min_dd,coslon,sinlon,rlons,ird_s,irc_s,periodic,idthrm5 public :: cp5,idvm5,ncep_sigio,ncepgfs_head,idpsfc5,nlon_sfc,nlat_sfc public :: rlons_sfc,rlats_sfc,jlon1,ilat1,periodic_s,latlon1n1,nsig3p2 public :: nsig3p3,nsig2,nsig3p1,wgtlats,corlats,rbs2,ncepgfs_headv,regional_time public :: regional_fhr,region_dyi,coeffx,region_dxi,coeffy,nsig_hlf public :: nlat_regional,nlon_regional,update_regsfc,half_grid,gencode public :: diagnostic_reg,nmmb_reference_grid,hybrid,filled_grid public :: grid_ratio_nmmb,isd_g,isc_g,dx_gfs,lpl_gfs,nsig5,nmmb_verttype public :: nsig4,nsig3 public :: use_gfs_ozone,check_gfs_ozone_date,regional_ozone public :: jcap,jcap_b,hires_b,sp_a,sp_b,grd_a,grd_b logical regional ! .t. for regional background/analysis logical diagnostic_reg ! .t. to activate regional analysis diagnostics logical ncep_sigio ! .t. if using ncep sigio format file logical wrf_nmm_regional ! logical nems_nmmb_regional! .t. to run with NEMS NMMB model logical wrf_mass_regional ! logical twodvar_regional ! .t. to run code in regional 2D-var mode logical use_gfs_ozone ! .t. to use gfs ozone in regional analysis logical check_gfs_ozone_date ! .t. to date check gfs ozone against regional logical regional_ozone ! .t. to turn on ozone for regional analysis logical netcdf ! .t. for regional netcdf i/o logical hybrid ! .t. to set hybrid vertical coordinates logical filled_grid ! logical half_grid ! logical update_regsfc ! logical hires_b ! .t. when jcap_b requires double FFT character(1) nmmb_reference_grid ! ='H': use nmmb H grid as reference for analysis grid ! ='V': use nmmb V grid as reference for analysis grid real(r_kind) grid_ratio_nmmb ! ratio of analysis grid to nmmb model grid in nmmb model grid units. character(3) nmmb_verttype ! 'OLD' for old vertical coordinate definition ! old def: p = eta1*pdtop+eta2*(psfc-pdtop-ptop)+ptop ! 'NEW' for new vertical coordinate definition ! new def: p = eta1*pdtop+eta2*(psfc-ptop)+ptop integer(i_kind) vlevs ! no. of levels distributed on all processors integer(i_kind) nsig1o ! max no. of levels distributed on each processor integer(i_kind) nnnn1o ! actual of levels distributed on current processor integer(i_kind) nlat ! no. of latitudes integer(i_kind) nlon ! no. of longitudes integer(i_kind) nlat_sfc ! no. of latitudes surface files integer(i_kind) nlon_sfc ! no. of longitudes surface files integer(i_kind) nsig ! no. of levels integer(i_kind) idvc5 ! vertical coordinate identifier ! 1: sigma ! 2: sigma-pressure ! 3: sigma-pressure-theta integer(i_kind) idvm5 integer(i_kind) idpsfc5 ! surface pressure identifier ! 0/1: ln(ps) ! 2: ps integer(i_kind) idthrm5 ! thermodynamic variable identifier ! 0/1: virtual temperature ! 2: sensible temperature ! 3: enthalpy (CpT) integer(i_kind) idsl5 ! midlayer pressure definition ! 1: Philips ! 2: average integer(i_kind) nsig2 ! 2 times number of levels integer(i_kind) nsig3 ! 3 times number of levels integer(i_kind) nsig3p1 ! 3 times number of levels plus 1 integer(i_kind) nsig3p2 ! 3 times number of levels plus 2 integer(i_kind) nsig3p3 ! 3 times number of levels plus 3 integer(i_kind) nsig4 ! 4 times number of levels integer(i_kind) nsig5 ! 5 times number of levels integer(i_kind) nsig5p1 ! 5 times number of levels plus 1 integer(i_kind) nsig_hlf ! half number of levels integer(i_kind) ntracer ! number of tracers integer(i_kind) ncloud ! number of cloud types integer(i_kind) ns1 ! 2 times number of levels plus 1 integer(i_kind) lat1 ! no. of lats on subdomain (no buffer) integer(i_kind) lon1 ! no. of lons on subdomain (no buffer) integer(i_kind) lat2 ! no. of lats on subdomain (buffer points on ends) integer(i_kind) lon2 ! no. of lons on subdomain (buffer points on ends) integer(i_kind) latlon11 ! horizontal points in subdomain (with buffer) integer(i_kind) latlon1n ! no. of points in subdomain (with buffer) integer(i_kind) latlon1n1 ! no. of points in subdomain for 3d prs (with buffer) integer(i_kind) iglobal ! number of horizontal points on global grid integer(i_kind) itotsub ! number of horizontal points of all subdomains combined integer(i_kind) msig ! number of profile layers to use when calling RTM integer(i_kind) jcap ! spectral triangular truncation of ncep global analysis integer(i_kind) jcap_b ! spectral triangular truncation of ncep global background logical periodic ! logical flag for periodic e/w domains logical,allocatable,dimension(:):: periodic_s ! logical flag for periodic e/w subdomain (all tasks) integer(i_kind),allocatable,dimension(:):: lpl_gfs ! number grid points for each row, GFS grid integer(i_kind),allocatable,dimension(:):: jstart ! start lon of the whole array on each pe integer(i_kind),allocatable,dimension(:):: istart ! start lat of the whole array on each pe integer(i_kind),allocatable,dimension(:):: ilat1 ! no. of lats for each subdomain (no buffer) integer(i_kind),allocatable,dimension(:):: jlon1 ! no. of lons for each subdomain (no buffer) integer(i_kind),allocatable,dimension(:):: ijn_s ! no. of horiz. points for each subdomain (with buffer) integer(i_kind),allocatable,dimension(:):: ijn ! no. of horiz. points for each subdomain (no buffer) integer(i_kind),allocatable,dimension(:):: isc_g ! no. array, count for send to global; size of subdomain ! comm. array ... integer(i_kind),allocatable,dimension(:):: irc_s ! count for receive on subdomain integer(i_kind),allocatable,dimension(:):: ird_s ! displacement for receive on subdomain integer(i_kind),allocatable,dimension(:):: isd_g ! displacement for send to global integer(i_kind),allocatable,dimension(:):: displs_s ! displacement for send from subdomain integer(i_kind),allocatable,dimension(:):: displs_g ! displacement for receive on global grid ! array element indices for location of ... integer(i_kind),allocatable,dimension(:):: ltosi ! lats in iglobal array excluding buffer integer(i_kind),allocatable,dimension(:):: ltosj ! lons in iglobal array excluding buffer integer(i_kind),allocatable,dimension(:):: ltosi_s ! lats in itotsub array including buffer integer(i_kind),allocatable,dimension(:):: ltosj_s ! lons in itotsub array including buffer integer(i_kind),dimension(100):: nlayers ! number of RTM layers per model layer ! (k=1 is near surface layer), default is 1 real(r_kind) gencode real(r_kind),allocatable,dimension(:):: dx_gfs ! resolution of GFS grid in degrees real(r_kind),allocatable,dimension(:):: rlats ! grid latitudes (radians) real(r_kind),allocatable,dimension(:):: rlons ! grid longitudes (radians) real(r_kind),allocatable,dimension(:):: rlats_sfc ! grid latitudes (radians) surface real(r_kind),allocatable,dimension(:):: rlons_sfc ! grid longitudes (radians) surface real(r_kind),allocatable,dimension(:):: ak5,bk5,ck5,tref5 ! coefficients for generalized vertical coordinate real(r_kind),allocatable,dimension(:):: cp5 ! specific heat for tracers real(r_kind),allocatable,dimension(:):: coslon ! cos(grid longitudes (radians)) real(r_kind),allocatable,dimension(:):: sinlon ! sin(grid longitudes (radians)) real(r_kind),allocatable,dimension(:):: wgtlats ! gaussian integration weights real(r_kind),allocatable,dimension(:):: corlats ! coriolis parameter by latitude real(r_kind),allocatable,dimension(:):: rbs2 ! 1./sin(grid latitudes))**2 ! additional variables for regional mode real(r_kind),allocatable:: eta1_ll(:) ! real(r_kind),allocatable:: aeta1_ll(:) ! real(r_kind),allocatable:: eta2_ll(:) ! real(r_kind),allocatable:: aeta2_ll(:) ! real(r_kind),allocatable::region_lon(:,:) ! real(r_kind),allocatable::region_lat(:,:) ! real(r_kind),allocatable::region_dx(:,:) ! real(r_kind),allocatable::region_dy(:,:) ! real(r_kind),allocatable::region_dxi(:,:) ! real(r_kind),allocatable::region_dyi(:,:) ! real(r_kind),allocatable::coeffx(:,:) ! real(r_kind),allocatable::coeffy(:,:) ! real(r_kind) rlon_min_ll,rlon_max_ll,rlat_min_ll,rlat_max_ll real(r_kind) rlon_min_dd,rlon_max_dd,rlat_min_dd,rlat_max_dd real(r_kind) dt_ll,pdtop_ll,pt_ll integer(i_kind) nlon_regional,nlat_regional real(r_kind) regional_fhr integer(i_kind) regional_time(6) ! The following is for the generalized transform real(r_kind) pihalf,sign_pole,rlambda0 real(r_kind) atilde_x,btilde_x,atilde_y,btilde_y real(r_kind) btilde_xinv,btilde_yinv integer(i_kind) nxtilde,nytilde real(r_kind),allocatable::xtilde0(:,:),ytilde0(:,:) real(r_kind),allocatable::beta_ref(:,:),cos_beta_ref(:,:),sin_beta_ref(:,:) integer(i_kind),allocatable::i0_tilde(:,:),j0_tilde(:,:) integer(i_byte),allocatable::ip_tilde(:,:),jp_tilde(:,:) !----------temporary variables to keep track of number of observations falling in beta_ref jump zone real(r_kind):: count_beta_diff,count_beta_diff_gt_20 real(r_kind) beta_diff_max,beta_diff_min,beta_diff_rms real(r_kind) beta_diff_max_gt_20 ! Define structure to hold NCEP sigio/gfsio header information type:: ncepgfs_head integer(i_kind):: ivs integer(i_kind):: version real(r_single) :: fhour integer(i_kind):: idate(4) integer(i_kind):: nrec integer(i_kind):: latb integer(i_kind):: lonb integer(i_kind):: levs integer(i_kind):: jcap integer(i_kind):: itrun integer(i_kind):: iorder integer(i_kind):: irealf integer(i_kind):: igen integer(i_kind):: latf integer(i_kind):: lonf integer(i_kind):: latr integer(i_kind):: lonr integer(i_kind):: ntrac integer(i_kind):: icen2 integer(i_kind):: iens(2) integer(i_kind):: idpp integer(i_kind):: idsl integer(i_kind):: idvc integer(i_kind):: idvm integer(i_kind):: idvt integer(i_kind):: idrun integer(i_kind):: idusr real(r_single) :: pdryini integer(i_kind):: ncldt integer(i_kind):: ixgr integer(i_kind):: nvcoord integer(i_kind):: idrt end type ncepgfs_head type:: ncepgfs_headv real(r_single),allocatable:: vcoord(:,:) real(r_single),allocatable:: cpi(:) end type ncepgfs_headv type(spec_vars),save:: sp_a,sp_b type(sub2grid_info),save:: grd_a,grd_b contains !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: init_grid --- Initialize defaults for grid related variables ! ! !INTERFACE: ! subroutine init_grid ! !DESCRIPTION: initialize defaults for grid related variables ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-03-03 treadon - add implicit none ! 2005-06-01 treadon - add initialization of msig and nlayers ! 2010-03-06 parrish - add initialization of use_gfs_ozone flag ! 2010-03-09 parrish - add initialization of check_gfs_ozone_date flag ! 2010-03-15 parrish - add initialization of regional_ozone flag ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- use constants, only: izero,ione,two implicit none integer(i_kind) k nsig = 42_i_kind nsig1o = 7_i_kind nlat = 96_i_kind nlon = 384_i_kind idvc5 = ione idvm5 = izero idpsfc5 = ione idthrm5 = ione idsl5 = ione ntracer = ione ncloud = izero gencode = 80_i_kind regional = .false. ncep_sigio = .true. periodic = .false. wrf_nmm_regional = .false. wrf_mass_regional = .false. nems_nmmb_regional = .false. twodvar_regional = .false. use_gfs_ozone = .false. check_gfs_ozone_date = .false. regional_ozone = .false. netcdf = .false. hybrid = .false. filled_grid = .false. half_grid = .false. grid_ratio_nmmb = sqrt(two) nmmb_reference_grid = 'H' nmmb_verttype = 'OLD' lat1 = nlat lon1 = nlon lat2 = lat1+2_i_kind lon2 = lon1+2_i_kind diagnostic_reg = .false. update_regsfc = .false. nlon_regional = izero nlat_regional = izero msig = nsig do k=1,100 nlayers(k) = ione end do jcap=62_i_kind jcap_b=62_i_kind hires_b=.false. return end subroutine init_grid !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: init_grid_vars --- Set grid related variables ! ! !INTERFACE: ! subroutine init_grid_vars(jcap,npe,nrf3,nvars,mype) ! !USES: use constants, only: izero,ione implicit none ! !INPUT PARAMETERS: integer(i_kind),intent(in ) :: jcap ! spectral truncation integer(i_kind),intent(in ) :: npe ! number of mpi tasks integer(i_kind),intent(in ) :: nvars integer(i_kind),intent(in ) :: nrf3 integer(i_kind),intent(in ) :: mype ! mpi task id ! !DESCRIPTION: set grid related variables (post namelist read) ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-06-01 treadon - add computation of msig ! 2010-03-15 zhu - add nrf3 and nvars for generalized control variable ! ! input argument list: ! ! output argument list: ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) k,nlon_b,inner_vars,num_fields logical,allocatable,dimension(:):: vector if(jcap==62_i_kind) gencode=80.0_r_kind ns1=2*nsig+ione nsig2=2*nsig nsig3=3*nsig nsig3p1=3*nsig+ione nsig3p2=3*nsig+2_i_kind nsig3p3=3*nsig+3_i_kind nsig4=4*nsig nsig5=5*nsig nsig5p1=5*nsig+ione nsig_hlf=nsig/2 iglobal=nlat*nlon ! Initialize nsig1o to distribute levs/variables ! as evenly as possible over the tasks vlevs=(nrf3*nsig)+nvars-nrf3 nsig1o=vlevs/npe if(mod(vlevs,npe)/=izero) nsig1o=nsig1o+ione nnnn1o=nsig1o ! temporarily set the number of levels to nsig1o ! Sum total number of vertical layers for RTM call msig = izero do k=1,nsig msig = msig + nlayers(k) end do ! Initialize structure(s) for spectral <--> grid transforms if (.not.regional) then ! Call general specmod for analysis grid call general_init_spec_vars(sp_a,jcap,jcap,nlat,nlon) ! If needed, initialize for hires_b transforms nlon_b=((2*jcap_b+1)/nlon+1)*nlon if (nlon_b /= sp_a%imax) then hires_b=.true. call general_init_spec_vars(sp_b,jcap_b,jcap_b,nlat,nlon_b) endif if (mype==0) then write(6,*) 'INIT_GRID_VARS: allocate and load sp_a with jcap,imax,jmax=',& sp_a%jcap,sp_a%imax,sp_a%jmax,' nlon_b=',nlon_b,' hires_b=',hires_b if (hires_b) & write(6,*)'INIT_GRID_VARS: allocate and load sp_b with jcap,imax,jmax=',& sp_b%jcap,sp_b%imax,sp_b%jmax endif endif ! Initialize structures for grid(s) inner_vars=1 num_fields=6*nsig+2 allocate(vector(num_fields)) vector=.false. vector(1:2*nsig)=.true. ! assume here that 1st two 3d variables are either u,v or psi,chi call general_sub2grid_create_info(grd_a,inner_vars,nlat,nlon,nsig,num_fields, & regional,vector) if (hires_b) & call general_sub2grid_create_info(grd_b,inner_vars,nlat,nlon_b,nsig,num_fields, & regional,vector) deallocate(vector) return end subroutine init_grid_vars !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: init_subdomain_vars --- Initialize variables related to subdomains ! ! !INTERFACE: ! subroutine init_subdomain_vars ! !DESCRIPTION: initialize variables related to subdomains ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-03-03 treadon - add implicit none ! 2008-11-28 todling - latlon1n1 (for 3d prs) ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- implicit none lat2 = lat1+2_i_kind lon2 = lon1+2_i_kind latlon11 = lat2*lon2 latlon1n = latlon11*nsig latlon1n1= latlon1n+latlon11 return end subroutine init_subdomain_vars !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: create_grid_vars --- Allocate memory for grid related variables ! ! !INTERFACE: ! subroutine create_grid_vars ! !DESCRIPTION: allocate memory for grid related variables ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-03-03 treadon - add implicit none ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- use constants, only: ione implicit none allocate(rlats(nlat),rlons(nlon),coslon(nlon),sinlon(nlon),& wgtlats(nlat),rbs2(nlat),corlats(nlat)) allocate(ak5(nsig+ione),bk5(nsig+ione),ck5(nsig+ione),tref5(nsig)) return end subroutine create_grid_vars !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: destroy_grid_vars --- Deallocate memory for grid related variables ! ! !INTERFACE: ! subroutine destroy_grid_vars ! !DESCRIPTION: deallocate memory for grid related variables ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-03-03 treadon - add implicit none ! 2009-12-20 gayno - add variable lpl_gfs ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- implicit none deallocate(rlats,rlons,corlats,coslon,sinlon,wgtlats,rbs2) deallocate(ak5,bk5,ck5,tref5) if (allocated(cp5)) deallocate(cp5) if (allocated(dx_gfs)) deallocate(dx_gfs) if (allocated(lpl_gfs)) deallocate(lpl_gfs) call general_destroy_spec_vars(sp_a) if (hires_b) call general_destroy_spec_vars(sp_b) return end subroutine destroy_grid_vars !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: create_mapping --- Init vars mapping between global domain/subd. ! ! !INTERFACE: ! subroutine create_mapping(npe) ! !USES: use constants, only: izero implicit none ! !INPUT PARAMETERS: integer(i_kind),intent(in ) :: npe ! number of mpi tasks ! !DESCRIPTION: allocate and initialize variables that create mapping ! between global domain and subdomains ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) i allocate(periodic_s(npe),jstart(npe),istart(npe),& ilat1(npe),jlon1(npe),& ijn_s(npe),irc_s(npe),ird_s(npe),displs_s(npe),& ijn(npe),isc_g(npe),isd_g(npe),displs_g(npe)) do i=1,npe periodic_s(i)= .false. jstart(i) = izero istart(i) = izero ilat1(i) = izero jlon1(i) = izero ijn_s(i) = izero irc_s(i) = izero ird_s(i) = izero displs_s(i) = izero ijn(i) = izero isc_g(i) = izero isd_g(i) = izero displs_g(i) = izero end do return end subroutine create_mapping !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: destroy_mapping --- Dealloc global/subdomain mapping arrays ! ! !INTERFACE: ! subroutine destroy_mapping ! !DESCRIPTION: deallocate memory for global/subdomain mapping variables ! ! !REVISION HISTORY: ! 2003-09-25 kleist ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2005-03-03 treadon - add implicit none ! 2007-02-20 todling - somehow dealloc for irc_s,ird_s got lost ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! kleist org: np20 date: 2003-09-25 ! !EOP !------------------------------------------------------------------------- implicit none deallocate(ltosi,ltosj,ltosi_s,ltosj_s) deallocate(periodic_s,jstart,istart,ilat1,jlon1,& ijn_s,irc_s,ird_s,displs_s,& ijn,isc_g,isd_g,displs_g) return end subroutine destroy_mapping !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: init_reg_glob_ll --- In case regional, initialize setting ! ! !INTERFACE: ! subroutine init_reg_glob_ll(mype,lendian_in) ! !USES: use constants, only: izero,ione,zero, one, three, deg2rad,pi,half, two use mod_nmmb_to_a, only: init_nmmb_to_a,nxa,nya,nmmb_h_to_a implicit none ! !INPUT PARAMETERS: integer(i_kind), intent(in ) :: mype ! mpi task id integer(i_kind), intent(in ) :: lendian_in ! unit number reserved for ! little endian input ! !DESCRIPTION: decide if regional run or not, and initialize constants ! required for rotation transformation ! ! ! output argument list: ! ! Notes about grid definition: ! \begin{enumerate} ! \item The origin of the analysis coordinate system is always $rlon=180.$, $rlat=0.$, ! whether this is a global or regional run. The point $rlon=180$, $rlat=0$ in ! the rotated coordinate coincides with the point rlon0\_origin, rlat0\_origin ! in earth coordinates. This is why $rlon0_origin=180$. in the global case. ! ! \item For regional runs, the rotated coordinate origin and extent of the domain are read ! in from the NMM restart file. ! ! \item The reason for having the longitude of the origin = 180 is because there are ! places in the global analysis that depend on $0 < lon < 360$. So to minimize changes ! to the global code, this approach has been adopted. ! ! \item The regional analysis domain is larger than the corresponding NMM grid. A halo is included ! whose width is a function of the interpolation order for transfers between grids. ! This is so the analysis increment is always being interpolated and added on to the ! full model domain. ! \end{enumerate} ! ! !REVISION HISTORY: ! 2003-08-28 parrish ! 2004-05-13 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2004-12-15 treadon - explicity set value for inges ! 2005-05-24 pondeca - add the surface analysis option ! 2006-04-06 middlecoff - changed inges from 21 to lendian_in so it can be set to little endian. ! 2009-01-02 todling - remove unused vars ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; SGI Origin 2000; Compaq/HP ! ! !AUTHOR: ! parrish org: np22 date: 2003-08-28 ! !EOP !------------------------------------------------------------------------- logical fexist integer(i_kind) i,j,k real(r_single)pt,pdtop real(r_single),allocatable:: deta1(:),aeta1(:),eta1(:),deta2(:),aeta2(:),eta2(:) real(r_single) dlmd,dphd real(r_single),allocatable:: glat(:,:),glon(:,:) real(r_single),allocatable:: dx_nmm(:,:),dy_nmm(:,:) real(r_single),allocatable:: dx_mc(:,:),dy_mc(:,:) real(r_kind),parameter:: r0_01=0.01_r_kind real(r_kind),parameter:: r1_5=1.5_r_kind real(r_kind),parameter:: six=6.0_r_kind real(r_kind),parameter:: r90=90.0_r_kind real(r_kind),parameter:: r360=360.0_r_kind real(r_kind),allocatable::glat_an(:,:),glon_an(:,:) real(r_kind),allocatable:: dx_an(:,:),dy_an(:,:) character(6) filename integer(i_kind) ihr real(r_kind),allocatable::gxtemp(:,:),gytemp(:,:) real(r_single),allocatable::gxtemp4(:,:),gytemp4(:,:) real(r_kind),allocatable::gxtemp_an(:,:),gytemp_an(:,:) real(r_kind) rtemp if(.not.regional) then ! This is global run rlat_min_ll=-r90*deg2rad rlat_max_ll=r90*deg2rad rlon_min_ll=zero*deg2rad rlon_max_ll=r360*deg2rad rlon_min_dd=rlon_min_ll-deg2rad rlon_max_dd=rlon_max_ll+deg2rad rlat_min_dd=rlat_min_ll-deg2rad rlat_max_dd=rlat_max_ll+deg2rad dt_ll=zero end if if(wrf_nmm_regional) then ! begin wrf_nmm section ! This is a wrf_nmm regional run. if(diagnostic_reg.and.mype==izero) & write(6,*)' in init_reg_glob_ll, initializing for wrf nmm regional run' ! Get regional constants ihr=-999_i_kind do i=0,12 write(filename,'("sigf",i2.2)')i inquire(file=filename,exist=fexist) if(fexist) then ihr=i exit end if end do if(ihr north. On exit ! the order is north --> south do k=1,iglobal i=nlat-ltosi(k)+ione j=ltosj(k) grid(j,i)=grid_in(k) end do ! Transfer contents of local array to output array. nlatm1=nlat-ione do j=2,nlatm1 jj=j-ione do i=1,nlon grid_out(i,jj)=grid(i,j) end do end do return end subroutine load_grid !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: fill_ns --- add southern/northern latitude rows ! ! !INTERFACE: ! subroutine fill_ns(grid_in,grid_out) ! !USES: use constants, only: ione,zero,one implicit none ! !INPUT PARAMETERS: real(r_kind),dimension(nlon,nlat-2_i_kind),intent(in ) :: grid_in ! input grid real(r_kind),dimension(itotsub) ,intent( out) :: grid_out ! output grid ! !DESCRIPTION: This routine adds a southern and northern latitude ! row to the input grid. The southern row contains ! the longitudinal mean of the adjacent latitude row. ! The northern row contains the longitudinal mean of ! the adjacent northern row. ! ! The added rows correpsond to the south and north poles. ! ! In addition to adding latitude rows corresponding to the ! south and north poles, the routine reorder the output ! array so that it is a one-dimensional array read in ! an order consisten with that assumed for total domain ! gsi grids. ! ! The assumed order for the input grid is longitude as ! the first dimension with array index increasing from ! east to west. The second dimension is latitude with ! the index increasing from north to south. This ordering ! differs from that used in the GSI. ! ! The GSI ordering is latitude first with the index ! increasing from south to north. The second dimension is ! longitude with the index increasing from east to west. ! ! Thus, the code below also rearranges the indexing and ! order of the dimensions to make the output grid ! consistent with that which is expected in the rest of ! gsi. ! ! ! !REVISION HISTORY: ! 2004-08-27 treadon ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 ! ! !AUTHOR: ! treadon org: np23 date: 2004-08-27 ! !EOP !------------------------------------------------------------------------- ! Declare local variables integer(i_kind) i,j,k,jj,nlatm2 real(r_kind) rnlon,sumn,sums real(r_kind),dimension(nlon,nlat):: grid ! Transfer contents of input grid to local work array ! Reverse ordering in j direction from n-->s to s-->n do j=2,nlat-ione jj=nlat-j do i=1,nlon grid(i,j)=grid_in(i,jj) end do end do ! Compute mean along southern and northern latitudes sumn=zero sums=zero nlatm2=nlat-2_i_kind do i=1,nlon sumn=sumn+grid_in(i,1) sums=sums+grid_in(i,nlatm2) end do rnlon=one/float(nlon) sumn=sumn*rnlon sums=sums*rnlon ! Load means into local work array do i=1,nlon grid(i,1) =sums grid(i,nlat)=sumn end do ! Transfer local work array to output grid do k=1,itotsub i=ltosi_s(k) j=ltosj_s(k) grid_out(k)=grid(j,i) end do return end subroutine fill_ns !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: filluv_ns --- add southern/northern latitude rows ! ! !INTERFACE: ! subroutine filluv_ns(gridu_in,gridv_in,gridu_out,gridv_out) ! !USES: use constants, only: ione,zero implicit none ! !INPUT PARAMETERS: real(r_kind),dimension(nlon,nlat-2_i_kind),intent(in ) :: gridu_in,gridv_in ! input grid real(r_kind),dimension(itotsub) ,intent( out) :: gridu_out,gridv_out ! output grid ! !DESCRIPTION: This routine adds a southern and northern latitude ! row to the input grid. The southern row contains ! the longitudinal mean of the adjacent latitude row. ! The northern row contains the longitudinal mean of ! the adjacent northern row. ! ! The added rows correpsond to the south and north poles. ! ! In addition to adding latitude rows corresponding to the ! south and north poles, the routine reorder the output ! array so that it is a one-dimensional array read in ! an order consisten with that assumed for total domain ! gsi grids. ! ! The assumed order for the input grid is longitude as ! the first dimension with array index increasing from ! east to west. The second dimension is latitude with ! the index increasing from north to south. This ordering ! differs from that used in the GSI. ! ! The GSI ordering is latitude first with the index ! increasing from south to north. The second dimension is ! longitude with the index increasing from east to west. ! ! Thus, the code below also rearranges the indexing and ! order of the dimensions to make the output grid ! consistent with that which is expected in the rest of ! gsi. ! ! ! !REVISION HISTORY: ! 2004-08-27 treadon ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 ! ! !AUTHOR: ! treadon org: np23 date: 2004-08-27 ! !EOP !------------------------------------------------------------------------- ! Declare local variables integer(i_kind) i,j,k,jj real(r_kind) polnu,polnv,polsu,polsv real(r_kind),dimension(nlon,nlat):: grid,grid2 ! Transfer contents of input grid to local work array ! Reverse ordering in j direction from n-->s to s-->n do j=2,nlat-ione jj=nlat-j do i=1,nlon grid(i,j)=gridu_in(i,jj) grid2(i,j)=gridv_in(i,jj) end do end do ! Compute mean along southern and northern latitudes polnu=zero polnv=zero polsu=zero polsv=zero do i=1,nlon polnu=polnu+grid(i,nlat-ione)*coslon(i)-grid2(i,nlat-ione)*sinlon(i) polnv=polnv+grid(i,nlat-ione)*sinlon(i)+grid2(i,nlat-ione)*coslon(i) polsu=polsu+grid(i,2 )*coslon(i)+grid2(i,2 )*sinlon(i) polsv=polsv+grid(i,2 )*sinlon(i)-grid2(i,2 )*coslon(i) end do polnu=polnu/float(nlon) polnv=polnv/float(nlon) polsu=polsu/float(nlon) polsv=polsv/float(nlon) do i=1,nlon grid (i,nlat)= polnu*coslon(i)+polnv*sinlon(i) grid2(i,nlat)=-polnu*sinlon(i)+polnv*coslon(i) grid (i,1 )= polsu*coslon(i)+polsv*sinlon(i) grid2(i,1 )= polsu*sinlon(i)-polsv*coslon(i) end do ! Transfer local work array to output grid do k=1,itotsub i=ltosi_s(k) j=ltosj_s(k) gridu_out(k)=grid(j,i) gridv_out(k)=grid2(j,i) end do return end subroutine filluv_ns !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: get_ij --- get (i,j) grid indices and interpolation weights ! ! !INTERFACE: ! subroutine get_ij(mm1,obs_lat,obs_lon,jgrd,wgrd,jjlat,jjlon) ! !USES: use constants, only: izero,ione,one implicit none ! !INPUT PARAMETERS: integer(i_kind) ,intent(in ) :: mm1 integer(i_kind),dimension(4),intent( out) :: jgrd integer(i_kind),optional ,intent( out) :: jjlat,jjlon real(r_kind) ,intent(in ) :: obs_lat,obs_lon real(r_kind),dimension(4) ,intent( out) :: wgrd integer(i_kind):: jlat,jlon real(r_kind):: dx,dy,dx1,dy1 ! !DESCRIPTION: This routine returns the sub-domain grid relative ! i,j index of a given observation (lat,lon). The ! routine also returns weights needed for bilinear ! from the four surrounding analysis grid points to ! the observation location. ! ! !REVISION HISTORY: ! 2004-12-23 treadon ! 2006-01-06 treadon - add optional arguments jjlat,jjlon ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 ! ! !AUTHOR: ! treadon org: np23 date: 2004-08-27 ! !EOP !------------------------------------------------------------------------- ! Set (i,j) indices of guess gridpoint that bound obs location jlat = obs_lat jlon = obs_lon ! Compute weights for bilinear interpolation dy = obs_lat-jlat dx = obs_lon-jlon dx1 = one-dx dy1 = one-dy ! Bound lat and lon indices to fall within analysis grid limits jlat = min(max(ione ,jlat),nlat) jlon = min(max(izero,jlon),nlon) ! Handle special case of e/w periodicity if (jstart(mm1)==ione .and. jlon==nlon) jlon=izero if (jstart(mm1)+jlon1(mm1)==nlon+ione .and. jlon==izero) jlon=nlon ! Convert global (i,j) indices to sub-domain specific (i,j) indices jlat=jlat-istart(mm1)+2_i_kind jlon=jlon-jstart(mm1)+2_i_kind jgrd(1)=jlat+(jlon-ione)*lat2 jgrd(2)=jgrd(1)+ione jgrd(3)=jgrd(1)+lat2 jgrd(4)=jgrd(3)+ione wgrd(1)=dx1*dy1 wgrd(2)=dx1*dy wgrd(3)=dx *dy1 wgrd(4)=dx *dy if (present(jjlat)) jjlat=jlat if (present(jjlon)) jjlon=jlon return end subroutine get_ij !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: get_ijk --- get (i,j,k) grid indices and interpolation weights ! ! !INTERFACE: ! subroutine get_ijk(mm1,obs_lat,obs_lon,obs_sig,jgrd,wgrd) ! !USES: use constants, only: izero,ione,one implicit none ! !INPUT PARAMETERS: integer(i_kind) ,intent(in ) :: mm1 integer(i_kind),dimension(8),intent( out) :: jgrd real(r_kind) ,intent(in ) :: obs_lat,obs_lon,obs_sig real(r_kind) ,dimension(8),intent( out) :: wgrd integer(i_kind):: jlat,jlon,jsig,latlon11_l real(r_kind) :: dx,dy,dx1,dy1,ds,ds1 ! !DESCRIPTION: This routine returns the sub-domain grid relative ! i,j,k index of a given observation (lat,lon,sig). ! The routine also returns weights needed for bilinear ! from the eight surrounding analysis grid points to ! the observation location ! ! !REVISION HISTORY: ! 2004-12-23 treadon ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 ! ! !AUTHOR: ! treadon org: np23 date: 2004-08-27 ! !EOP !------------------------------------------------------------------------- ! Declare local variables real(r_kind) obs_s ! Special handling for vertical coordinate obs_s = obs_sig if (obs_s < one) obs_s = one ! Set (i,j,k) indices of guess gridpoint that bound obs location jlat = obs_lat jlon = obs_lon jsig = obs_s ! Compute weights for bilinear interpolation dy = obs_lat-jlat dx = obs_lon-jlon ds = obs_s-jsig dx1 = one-dx dy1 = one-dy ds1 = one-ds ! Bound lat and lon indices to fall within analysis grid limits jlat = min(max(ione ,jlat),nlat) jlon = min(max(izero,jlon),nlon) ! Handle special case of e/w periodicity if (jstart(mm1)==ione .and. jlon==nlon) jlon=izero if (jstart(mm1)+jlon1(mm1)==nlon+ione .and. jlon==izero) jlon=nlon ! Convert global (i,j) indices to sub-domain specific (i,j) indices jlat=jlat-istart(mm1)+2_i_kind jlon=jlon-jstart(mm1)+2_i_kind ! Set number of points on horizontal layer latlon11_l = latlon11 if(jsig==nsig) latlon11_l=izero jgrd(1)=jlat+(jlon-ione)*lat2+(jsig-ione)*latlon11 jgrd(2)=jgrd(1)+ione jgrd(3)=jgrd(1)+lat2 jgrd(4)=jgrd(3)+ione jgrd(5)=jgrd(1)+latlon11_l jgrd(6)=jgrd(5)+ione jgrd(7)=jgrd(5)+lat2 jgrd(8)=jgrd(7)+ione wgrd(1)=dx1*dy1*ds1 wgrd(2)=dx1*dy *ds1 wgrd(3)=dx *dy1*ds1 wgrd(4)=dx *dy *ds1 wgrd(5)=dx1*dy1*ds wgrd(6)=dx1*dy *ds wgrd(7)=dx *dy1*ds wgrd(8)=dx *dy *ds return end subroutine get_ijk subroutine check_rotate_wind(string) !$$$ subprogram documentation block ! . . . . ! subprogram: check_rotate_wind ! prgmmr: ! ! abstract: ! ! program history log: ! 2009-08-04 lueken - added subprogram doc block ! ! input argument list: ! string ! ! output argument list: ! ! attributes: ! language: f90 ! machine: ! !$$$ end documentation block use constants, only: zero,one,rad2deg implicit none character(len=*),intent(in ) :: string if(count_beta_diff>zero.or.count_beta_diff_gt_20>zero) then beta_diff_rms=sqrt(beta_diff_rms/(max(one,count_beta_diff))) write(6,*)'CHECK_ROTATE_WIND: called from routine ',trim(string) write(6,100) beta_diff_max*rad2deg, beta_diff_min*rad2deg, beta_diff_rms*rad2deg write(6,110) count_beta_diff, count_beta_diff_gt_20 write(6,115) beta_diff_max_gt_20*rad2deg 100 format(' beta_diff_mass,min,rms(deg) = ',3(g18.12,2x)) 110 format(' count_beta_diff,count_beta_diff_gt_20= ',2(g18.12,2x)) 115 format(' beta_diff_max_gt_20(deg) = ',g18.12) end if end subroutine check_rotate_wind !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: reorder --- reorder work array post mpi communication ! ! !INTERFACE: ! subroutine reorder(work,k_in,k_use) ! !USES: use kinds, only: r_kind use constants, only: izero,zero,ione use mpimod, only: npe implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: k_in, k_use ! number of levs in work array ! !INPUT/OUTPUT PARAMETERS: real(r_kind),dimension(max(iglobal,itotsub)*k_in), intent(inout) :: work ! array to reorder ! !OUTPUT PARAMETERS: ! !DESCRIPTION: reorder work array post mpi communication ! ! !REVISION HISTORY: ! ! 2004-01-25 kleist ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! 2004-03-30 treadon - replace itotsub with max(iglobal,itotsub) in work dimension ! ! !REMAKRS: ! ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! kleist org: np20 date: 2004-01-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) iloc,iskip,i,k,n real(r_kind),dimension(max(iglobal,itotsub),k_use):: temp ! Zero out temp array do k=1,k_use do i=1,itotsub temp(i,k)=zero end do end do ! Load temp array in desired order do k=1,k_use iskip=izero iloc=izero do n=1,npe if (n/=ione) then iskip=iskip+ijn(n-ione)*k_in end if do i=1,ijn(n) iloc=iloc+ione temp(iloc,k)=work(i + iskip + (k-ione)*ijn(n)) end do end do end do ! Load the temp array back into work iloc=izero do k=1,k_use do i=1,itotsub iloc=iloc+ione work(iloc)=temp(i,k) end do end do return end subroutine reorder !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: reorder2 --- reorder work array post mpi communication ! ! !INTERFACE: ! subroutine reorder2(work,k_in,k_use) ! !USES: use kinds, only: r_kind use constants, only: izero,ione use mpimod, only: npe implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: k_in,k_use ! number of levs in work array ! !INPUT/OUTPUT PARAMETERS: real(r_kind),dimension(itotsub,k_in), intent(inout) :: work ! !OUTPUT PARAMETERS: ! !DESCRIPTION: reorder work array pre mpi communication ! ! !REVISION HISTORY: ! ! 2004-01-25 kleist ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! kleist org: np20 date: 2004-01-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) iloc,iskip,i,k,n real(r_kind),dimension(itotsub*k_in):: temp ! Load temp array in order of subdomains iloc=izero iskip=izero do n=1,npe do k=1,k_use do i=1,ijn_s(n) temp(iloc+i)=work(iskip+i,k) end do iloc=iloc+ijn_s(n) end do iloc=iloc+(k_in-k_use)*ijn_s(n) iskip=iskip+ijn_s(n) end do ! Now load the tmp array back into work iloc=izero do k=1,k_in do i=1,itotsub iloc=iloc+ione work(i,k)=temp(iloc) end do end do return end subroutine reorder2 !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: strip_single --- strip off buffer points froms subdomains for ! mpi comm purposes (works with 4 byte reals) ! ! !INTERFACE: ! subroutine strip_single(field_in,field_out,nz) ! !USES: use kinds, only: r_single use constants, only: ione implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: nz ! number of levs in subdomain array real(r_single),dimension(lat2,lon2,nz), intent(in ) :: field_in ! full subdomain ! array containing ! buffer points ! !OUTPUT PARAMETERS: real(r_single),dimension(lat1,lon1,nz), intent( out) :: field_out ! subdomain array ! with buffer points ! stripped off ! !DESCRIPTION: strip off buffer points froms subdomains for mpi comm ! purposes ! ! !REVISION HISTORY: ! ! 2004-01-25 kleist ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! kleist org: np20 date: 2004-01-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) i,j,k,jp1 do k=1,nz do j=1,lon1 jp1 = j+ione do i=1,lat1 field_out(i,j,k)=field_in(i+ione,jp1,k) end do end do end do return end subroutine strip_single !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: strip --- strip off buffer points froms subdomains for ! mpi comm purposes ! ! !INTERFACE: ! subroutine strip(field_in,field_out,nz) ! !USES: use kinds, only: r_kind use constants, only: ione implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: nz ! number of levs in subdomain array real(r_kind),dimension(lat2,lon2,nz), intent(in ) :: field_in ! full subdomain ! array containing ! buffer points ! !OUTPUT PARAMETERS: real(r_kind),dimension(lat1,lon1,nz), intent( out) :: field_out ! subdomain array ! with buffer points ! stripped off ! !DESCRIPTION: strip off buffer points froms subdomains for mpi comm ! purposes ! ! !REVISION HISTORY: ! ! 2004-01-25 kleist ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! kleist org: np20 date: 2004-01-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) i,j,k,jp1 do k=1,nz do j=1,lon1 jp1 = j+ione do i=1,lat1 field_out(i,j,k)=field_in(i+ione,jp1,k) end do end do end do return end subroutine strip !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: vectosub --- transform vector array into three dimensional ! subdomain array ! ! !INTERFACE: ! subroutine vectosub(fld_in,npts,fld_out) use kinds, only: r_kind implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: npts ! number of levs in subdomain array real(r_kind),dimension(npts), intent(in ) :: fld_in ! subdomain array ! in vector form ! !OUTPUT PARAMETERS: real(r_kind),dimension(npts), intent( out) :: fld_out ! three dimensional ! subdomain variable array ! !DESCRIPTION: Transform vector array into three dimensional subdomain ! array ! ! !REVISION HISTORY: ! ! 2004-01-25 kleist ! 2004-05-14 kleist, documentation ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! kleist org: np20 date: 2004-01-25 ! !EOP !------------------------------------------------------------------------- integer(i_kind) k do k=1,npts fld_out(k)=fld_in(k) end do return end subroutine vectosub !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: reload --- Transfer contents of 2-d array to 3-d array ! ! !INTERFACE: ! subroutine reload(work_in,work_out) ! !USES: use kinds, only: r_kind use constants, only: izero,ione implicit none ! !INPUT PARAMETERS: real(r_kind),dimension(lat2*lon2,nsig),intent(in ) :: work_in ! 2-d array ! !OUTPUT PARAMETERS: real(r_kind),dimension(lat2,lon2,nsig),intent( out) :: work_out ! 3-d array ! !DESCRIPTION: Transfer contents of 2-d array to 3-d array ! ! !REVISION HISTORY: ! 2004-05-14 treadon ! 2004-07-15 todling, protex-compliant prologue ! ! !REMARKS: ! ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! treadon org: np23 date: 2004-05-14 ! !EOP !------------------------------------------------------------------------- integer(i_kind) i,j,k,ij do k=1,nsig ij=izero do j=1,lon2 do i=1,lat2 ij=ij+ione work_out(i,j,k)=work_in(ij,k) end do end do end do return end subroutine reload !------------------------------------------------------------------------- ! NOAA/NCEP, National Centers for Environmental Prediction GSI ! !------------------------------------------------------------------------- !BOP ! ! !IROUTINE: strip_periodic --- strip off buffer points from periodic ! subdomains for mpi comm purposes ! ! !INTERFACE: ! subroutine strip_periodic(field_in,field_out,nz) ! !USES: use kinds, only: r_kind use constants, only: ione implicit none ! !INPUT PARAMETERS: integer(i_kind) , intent(in ) :: nz ! number of levs in subdomain array real(r_kind),dimension(lat2,lon2,nz), intent(in ) :: field_in ! full subdomain ! array containing ! buffer points ! !OUTPUT PARAMETERS: real(r_kind),dimension(lat1,lon1,nz), intent( out) :: field_out ! subdomain array ! with buffer points ! stripped off ! !DESCRIPTION: strip off buffer points froms subdomains for mpi comm ! purposes ! ! !REVISION HISTORY: ! ! 2004-07-23 treadon ! 2004-08-04 treadon - protex-compliant prologue ! ! !REMARKS: ! ! language: f90 ! machine: ibm rs/6000 sp; sgi origin 2000; compaq/hp ! ! !AUTHOR: ! treadon org: np20 date: 2004-07-23 ! !EOP !------------------------------------------------------------------------- integer(i_kind) i,j,k,jp1 do k=1,nz do j=1,lon1 jp1 = j+ione do i=1,lat1 field_out(i,j,k)=field_in(i+ione,jp1,k) end do end do end do do k=1,nz do i=1,lat1 field_out(i,1,k) = field_out(i,1,k) + field_in(i+ione,lon2,k) field_out(i,lon1,k) = field_out(i,lon1,k) + field_in(i+ione,1,k) end do end do return end subroutine strip_periodic end module gridmod