From 518ea7b43d5ba9eac67a4d51e3ef91c30ff44992 Mon Sep 17 00:00:00 2001 From: xie7 Date: Sun, 6 Oct 2024 17:25:58 -0700 Subject: [PATCH 01/19] Added a new orographic drag topo file toolkit 1. A new toolkit for generation of the topographic file for new orographic drag schemes is included in code/components/eam/tools/topo_tool/. new file: orographic_drag_toolkit/Makefile new file: orographic_drag_toolkit/README new file: orographic_drag_toolkit/Tempest-remap_generation.sh new file: orographic_drag_toolkit/cube_to_target.F90 new file: orographic_drag_toolkit/make.ncl new file: orographic_drag_toolkit/ogwd_sub.F90 new file: orographic_drag_toolkit/reconstruct.F90 new file: orographic_drag_toolkit/remap.F90 new file: orographic_drag_toolkit/run.sh new file: orographic_drag_toolkit/shr_kind_mod.F90 new file: orographic_drag_toolkit/transform.F90 [BFB] --- .../orographic_drag_toolkit/Makefile | 106 + .../topo_tool/orographic_drag_toolkit/README | 18 + .../Tempest-remap_generation.sh | 13 + .../cube_to_target.F90 | 2550 ++++++++++++++++ .../orographic_drag_toolkit/make.ncl | 21 + .../orographic_drag_toolkit/ogwd_sub.F90 | 900 ++++++ .../orographic_drag_toolkit/reconstruct.F90 | 2675 +++++++++++++++++ .../orographic_drag_toolkit/remap.F90 | 1562 ++++++++++ .../topo_tool/orographic_drag_toolkit/run.sh | 6 + .../orographic_drag_toolkit/shr_kind_mod.F90 | 20 + .../orographic_drag_toolkit/transform.F90 | 351 +++ 11 files changed, 8222 insertions(+) create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/Makefile create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/README create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/Tempest-remap_generation.sh create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/cube_to_target.F90 create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/reconstruct.F90 create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/run.sh create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/shr_kind_mod.F90 create mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/transform.F90 diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/Makefile b/components/eam/tools/topo_tool/orographic_drag_toolkit/Makefile new file mode 100755 index 000000000000..ec236185cf67 --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/Makefile @@ -0,0 +1,106 @@ +EXEDIR = . +EXENAME = cube_to_target +RM = rm + +.SUFFIXES: +.SUFFIXES: .F90 .o + +FC = ifort +DEBUG = FALSE + + +# Check for the NetCDF library and include directories +ifeq ($(LIB_NETCDF),$(null)) +LIB_NETCDF := /gpfs/fs1/soft/chrysalis/spack/opt/spack/linux-centos8-x86_64/intel-20.0.4/netcdf-fortran-4.4.4-rdxohvp/lib +#/global/common/software/nersc/pm-2023q1/spack-stacks-1/views/climate-utils/lib +#/public/software/mathlib/netcdf/4.3.2/intel/lib +endif + +ifeq ($(INC_NETCDF),$(null)) +INC_NETCDF := /gpfs/fs1/soft/chrysalis/spack/opt/spack/linux-centos8-x86_64/intel-20.0.4/netcdf-fortran-4.4.4-rdxohvp/include +#/global/common/software/nersc/pm-2023q1/spack-stacks-1/views/climate-utils/include +#/public/software/mathlib/netcdf/4.3.2/intel/include +endif + +# Determine platform +UNAMES := $(shell uname -s) +UNAMEM := $(findstring CRAY,$(shell uname -m)) + +#------------------------------------------------------------------------ +# LF95 +#------------------------------------------------------------------------ +# +# setenv LD_LIBRARY_PATH ${LD_LIBRARY_PATH}:/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib +# +ifeq ($(FC),lf95) +# +# Tramhill +# + INC_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/include + LIB_NETCDF :=/usr/local/netcdf-4.1.3-gcc-4.4.4-13-lf9581/lib + + LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -lcurl -lhdf5 -lhdf5_hl -mcmodel=medium + FFLAGS := -c --trace --trap --wide -CcdRR8 -I$(INC_NETCDF) + ifeq ($(DEBUG),TRUE) +# FFLAGS += --chk aesu -Cpp --trace + FFLAGS += -g --chk a,e,s,u --pca + else + FFLAGS += -O + endif + +endif + + + +.F90.o: + $(FC) $(FFLAGS) $< + + +#------------------------------------------------------------------------ +# AIX +# #------------------------------------------------------------------------ +# + #ifeq ($(UNAMES),AIX) + FC = ifort #xlf90 + #FFLAGS = -c -I$(INC_NETCDF) -I/BIGDATA1/iapcas_mhzhang_xiejinbo/topo_tool/cube_to_target/functional/ -convert big_endian + + FFLAGS = -c -I$(INC_NETCDF) -convert big_endian -traceback + #FFLAGS := -c -I$(INC_NETCDF) -no-prec-div -traceback -convert big_endian -fp-model source -assume byterecl -ftz -m64 -mcmodel=large -safe-cray-ptr + LDFLAGS = -L$(LIB_NETCDF) -lnetcdff + #LDFLAGS = -L$(LIB_NETCDF) -lnetcdf -lnetcdff -m64 -static-intel + .F90.o: + $(FC) $(FFLAGS) -qsuffix=f=F90 $< +# #endif + + +.F90.o: + $(FC) $(FFLAGS) $< + + + + + + + + + + +#------------------------------------------------------------------------ +# Default rules and macros +#------------------------------------------------------------------------ + +#OBJS := reconstruct.o remap.o cube_to_target.o shr_kind_mod.o +OBJS := reconstruct.o remap.o shr_kind_mod.o transform.o sub_xjb.o cube_to_target.o +#OBJS := reconstruct.o remap.o cube_to_target.o sub.o shr_kind_mod.o +#sub.o shr_kind_mod.o + +$(EXEDIR)/$(EXENAME): $(OBJS) + $(FC) -o $@ $(OBJS) -I$(INC_NETCDF) $(LDFLAGS) + +clean: + $(RM) -f $(OBJS) *.mod $(EXEDIR)/$(EXENAME) + +cube_to_target.o: shr_kind_mod.o remap.o reconstruct.o sub_xjb.o transform.o +remap.o: +reconstruct.o: remap.o +#reconstruct.o : shr_kind_mod.o diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/README b/components/eam/tools/topo_tool/orographic_drag_toolkit/README new file mode 100755 index 000000000000..1675a91d5e76 --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/README @@ -0,0 +1,18 @@ +cube_to_target performs rigourous remapping of topo variables from cubed-sphere grid to +any target grid. In the process SGH is computed. + +Input files: + +1. USGS-topo-cube.nc (may be found here $CESMDATA/inputdata/atm/cam/hrtopo/USGS-topo-cube3000.nc) + + This is the topo data on a cubed-sphere (default is 3km cubed-sphere grid) + +2. target.nc (e.g., $CESMDATA/inputdata/atm/cam/grid-description/se/ne30np4_091226_pentagons.nc) + + This is a SCRIP/ESMF grid descriptor file for the target grid + +3. phis-smooth.nc + + (optional) The user may provide a smoothed PHIS field. The software then recomputes SGH to + account for the smoothing in the sub-grid-scale. + diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/Tempest-remap_generation.sh b/components/eam/tools/topo_tool/orographic_drag_toolkit/Tempest-remap_generation.sh new file mode 100755 index 000000000000..e9bb8470393d --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/Tempest-remap_generation.sh @@ -0,0 +1,13 @@ + + +source /lcrc/soft/climate/e3sm-unified/load_latest_e3sm_unified_chrysalis.sh +tempest_root=~/.conda/envs/jinbo +# Generate the element mesh. +${tempest_root}/bin/GenerateCSMesh --alt --res 30 --file topo2/ne30.g +# Generate the target physgrid mesh. +${tempest_root}/bin/GenerateVolumetricMesh --in topo2/ne30.g --out topo2/ne30pg2.g --np 2 --uniform +# Generate a high-res target physgrid mesh for cube_to_target. +${tempest_root}/bin/GenerateVolumetricMesh --in topo2/ne30.g --out topo2/ne30pg4.g --np 4 --uniform +# Generate SCRIP files for cube_to_target. +${tempest_root}/bin/ConvertMeshToSCRIP --in topo2/ne30pg4.g --out topo2/ne30pg4_scrip.nc +${tempest_root}/bin/ConvertMeshToSCRIP --in topo2/ne30pg2.g --out topo2/ne30pg2_scrip.nc diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/cube_to_target.F90 b/components/eam/tools/topo_tool/orographic_drag_toolkit/cube_to_target.F90 new file mode 100755 index 000000000000..60ce13495936 --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/cube_to_target.F90 @@ -0,0 +1,2550 @@ +! +! DATE CODED: Nov 7, 2011 to Oct 15, 2012 +! DESCRIPTION: Remap topo data from cubed-sphere grid to target grid using rigorous remapping +! (Lauritzen, Nair and Ullrich, 2010, J. Comput. Phys.) +! +! Author: Peter Hjort Lauritzen (pel@ucar.edu), AMP/CGD/NESL/NCAR +! +program convterr + use shr_kind_mod, only: r8 => shr_kind_r8 + use reconstruct + use ogwd_sub + implicit none +# include + + !************************************** + ! + ! USER SETTINGS BELOW + ! + !************************************** + ! + ! + ! if smoothed PHIS is available SGH needs to be recomputed to account for the sub-grid-scale + ! variability introduced by the smoothing + ! +logical :: lsmooth_terr = .FALSE. +!logical :: lsmooth_terr = .TRUE. + ! + ! PHIS is smoothed by other software/dynamical core + ! + logical :: lexternal_smooth_terr = .FALSE. ! lexternal_smooth_terr = .FALSE. is NOT supported currently +!logical :: lexternal_smooth_terr = .TRUE. + ! + ! set PHIS=0.0 if LANDFRAC<0.01 + ! + logical :: lzero_out_ocean_point_phis = .TRUE.!.FALSE. +!logical :: lzero_out_ocean_point_phis = .FALSE. + ! + ! For internal smoothing (experimental at this point) + ! =================================================== + ! + ! if smoothing is internal (lexternal_smooth_terr=.FALSE.) choose coarsening factor + ! + ! recommendation: 2*(target resolution)/(0.03 degree) + ! + ! factor must be an even integer + ! + integer, parameter :: factor = 60 !coarse grid = 2.25 degrees + integer, parameter :: norder = 2 + integer, parameter :: nmono = 0 + integer, parameter :: npd = 1 + ! + !********************************************************************** + ! + ! END OF USER SETTINS BELOW + ! (do not edit beyond this point unless you know what you are doing!) + ! + !********************************************************************** + ! + integer :: im, jm, ncoarse + integer :: ncube !dimension of cubed-sphere grid + + real(r8), allocatable, dimension(:) :: landm_coslat, landfrac, terr, sgh30 + real(r8), allocatable, dimension(:) :: terr_coarse !for internal smoothing + + integer :: alloc_error,dealloc_error + integer :: i,j,n,k,index + integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile + integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file + integer :: srcid,dstid, jm_dbg ! for netCDF weight file + integer, dimension(2) :: src_grid_dims ! for netCDF weight file + + integer :: dimid + + logical :: ldbg + real(r8), allocatable, dimension(:) :: lon , lat + real(r8), allocatable, dimension(:) :: lon_landm , lat_landm + real(r8), allocatable, dimension(:) :: area + integer :: im_landm, jm_landm + integer :: lonid, latid, phisid + ! + ! constants + ! + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + REAL (r8), PARAMETER :: pih = 0.50*pi + REAL (r8), PARAMETER :: deg2rad = pi/180.0 + + real(r8) :: wt,dlat + integer :: ipanel,icube,jcube + real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube + real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube + integer, allocatable, dimension(:,:) :: idx,idy,idp + integer :: npatch, isub,jsub, itmp, iplm1,jmin,jmax + real(r8) :: sum,dx,scale,dmax,arad,jof,term,s1,c1,clon,iof,dy,s2,c2,dist + ! + ! for linear interpolation + ! + real(r8) :: lambda,theta,wx,wy,offset + integer :: ilon,ilat,ip1,jp1 + ! + ! variable for regridding + ! + integer :: src_grid_dim ! for netCDF weight file + integer :: n_a,n_b,n_s,n_aid,n_bid,n_sid + integer :: count + real(r8), allocatable, dimension(:) :: landfrac_target, terr_target, sgh30_target, sgh_target + real(r8), allocatable, dimension(:) :: oc_target + real(r8), allocatable, dimension(:,:) :: oa_target,ol_target + real(r8) :: terr_if + real(r8), allocatable, dimension(:) :: lat_terr,lon_terr + integer :: nvar_dirOA,nvar_dirOL + integer,allocatable,dimension(:) :: indexb !max indice dimension + real(r8),allocatable,dimension(:,:,:) :: terrout + real(r8),allocatable,dimension(:,:) :: dxy + + real(r8), allocatable, dimension(:) :: landm_coslat_target, area_target + ! + ! this is only used if target grid is a lat-lon grid + ! + integer , parameter :: im_target = 360 , jm_target = 180 + ! + ! this is only used if target grid is not a lat-lon grid + ! + real(r8), allocatable, dimension(:) :: lon_target, lat_target + ! + ! new + ! + integer :: ntarget, ntarget_id, ncorner, ncorner_id, nrank, nrank_id + integer :: ntarget_smooth + real(r8), allocatable, dimension(:,:):: target_corner_lon, target_corner_lat + real(r8), allocatable, dimension(:) :: target_center_lon, target_center_lat, target_area +real(r8), allocatable, dimension(:,:):: target_corner_lon_deg,target_corner_lat_deg + integer :: ii,ip,jx,jy,jp + real(r8), dimension(:), allocatable :: xcell, ycell, xgno, ygno + real(r8), dimension(:), allocatable :: gauss_weights,abscissae + integer, parameter :: ngauss = 3 + integer :: jmax_segments,jall + real(r8) :: tmp + + real(r8), allocatable, dimension(:,:) :: weights_all + integer , allocatable, dimension(:,:) :: weights_eul_index_all + integer , allocatable, dimension(:) :: weights_lgr_index_all + integer :: ix,iy + ! + ! volume of topography + ! + real(r8) :: vol_target, vol_target_un, area_target_total,vol_source,vol_tmp + integer :: nlon,nlon_smooth,nlat,nlat_smooth + logical :: ltarget_latlon,lpole + real(r8), allocatable, dimension(:,:) :: terr_smooth + ! + ! for internal filtering + ! + real(r8), allocatable, dimension(:,:) :: weights_all_coarse + integer , allocatable, dimension(:,:) :: weights_eul_index_all_coarse + integer , allocatable, dimension(:) :: weights_lgr_index_all_coarse + real(r8), allocatable, dimension(:) :: area_target_coarse + real(r8), allocatable, dimension(:,:) :: da_coarse,da + real(r8), allocatable, dimension(:,:) :: recons,centroids + integer :: nreconstruction + + integer :: jmax_segments_coarse,jall_coarse,ncube_coarse + real(r8) :: all_weights + character(len=512) :: target_grid_file + character(len=512) :: input_topography_file + character(len=512) :: output_topography_file + character(len=512) :: smoothed_topography_file +real(r8) :: xxt,yyt,zzt +!real(r8),allocatable,dimension(:) :: xbar,ybar,zbar +real(r8),dimension(32768) :: xhds,yhds,zhds,hds,xbar,ybar,zbar,lon_bar,lat_bar +real(r8) :: rad,xx2,yy2,zz2,ix2,iy2,ip2 +real(r8) :: lonii,latii +character*20 :: indice + ! + nvar_dirOA=2+1!4 !2+1!4!36 + nvar_dirOL=180 + ! + ! turn extra debugging on/off + ! + ldbg = .FALSE. + + nreconstruction = 1 + ! + call parse_arguments(target_grid_file , input_topography_file , & + output_topography_file, smoothed_topography_file, & + lsmooth_terr ) + ! + !********************************************************* + ! + ! read in target grid + ! + !********************************************************* + ! + status = nf_open(trim(target_grid_file), 0, ncid) + IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) + + status = NF_INQ_DIMID(ncid, 'grid_size', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, ntarget) + WRITE(*,*) "dimension of target grid: ntarget=",ntarget + + status = NF_INQ_DIMID(ncid, 'grid_corners', ncorner_id) + status = NF_INQ_DIMLEN(ncid, ncorner_id, ncorner) + WRITE(*,*) "maximum number of corners: ncorner=",ncorner + + status = NF_INQ_DIMID(ncid, 'grid_rank', nrank_id);status = NF_INQ_DIMLEN(ncid, nrank_id, nrank) + WRITE(*,*) "grid rank: nrank=",nrank + IF (nrank==2) THEN + WRITE(*,*) "target grid is a lat-lon grid" + ltarget_latlon = .TRUE. + status = NF_INQ_DIMID(ncid, 'nlon', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon) + status = NF_INQ_DIMID(ncid, 'nlat', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat) + status = NF_INQ_DIMID(ncid, 'lpole', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, lpole) + WRITE(*,*) "nlon=",nlon,"nlat=",nlat + IF (lpole) THEN + WRITE(*,*) "center of most Northern grid cell is lat=90; similarly for South pole" + ELSE + WRITE(*,*) "center of most Northern grid cell is NOT lat=90; similarly for South pole" + END IF + ELSE IF (nrank==1) THEN + ltarget_latlon = .FALSE. + ELSE + WRITE(*,*) "nrank out of range",nrank + STOP + ENDIF + + allocate ( target_corner_lon(ncorner,ntarget),stat=alloc_error) + allocate ( target_corner_lat(ncorner,ntarget),stat=alloc_error) + allocate ( target_corner_lon_deg(ncorner,ntarget),stat=alloc_error) + allocate ( target_corner_lat_deg(ncorner,ntarget),stat=alloc_error) + status = NF_INQ_VARID(ncid, 'grid_corner_lon', lonid) + status = NF_GET_VAR_DOUBLE(ncid, lonid,target_corner_lon) + ! + target_corner_lon_deg=target_corner_lon + ! + IF (maxval(target_corner_lon)>10.0) target_corner_lon = deg2rad*target_corner_lon + + status = NF_INQ_VARID(ncid, 'grid_corner_lat', latid) + status = NF_GET_VAR_DOUBLE(ncid, latid,target_corner_lat) + ! + target_corner_lat_deg=target_corner_lat + ! + IF (maxval(target_corner_lat)>10.0) target_corner_lat = deg2rad*target_corner_lat + ! + ! for writing remapped data on file at the end of the program + ! + allocate ( target_center_lon(ntarget),stat=alloc_error) + allocate ( target_center_lat(ntarget),stat=alloc_error) + allocate ( target_area (ntarget),stat=alloc_error)!dbg + + status = NF_INQ_VARID(ncid, 'grid_center_lon', lonid) + status = NF_GET_VAR_DOUBLE(ncid, lonid,target_center_lon) + + status = NF_INQ_VARID(ncid, 'grid_center_lat', latid) + status = NF_GET_VAR_DOUBLE(ncid, latid,target_center_lat) + + status = NF_INQ_VARID(ncid, 'grid_area', latid) + status = NF_GET_VAR_DOUBLE(ncid, latid,target_area) + + status = nf_close (ncid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + !**************************************************** + ! + ! get dimension of cubed-sphere grid + ! + !**************************************************** + ! + WRITE(*,*) "get dimension of cubed-sphere data from file" + !status = nf_open('USGS-topo-cube3000.nc', 0, ncid) + status = nf_open(trim(input_topography_file), 0, ncid) + IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) + status = NF_INQ_DIMID(ncid, 'grid_size', dimid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + status = NF_INQ_DIMLEN(ncid, dimid, n) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + ncube = INT(SQRT(DBLE(n/6))) + WRITE(*,*) "cubed-sphere dimension: ncube = ",ncube + WRITE(*,*) "average grid-spacing at the Equator (degrees):" ,90.0/ncube + + status = nf_close (ncid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + !**************************************************** + ! + ! compute weights for remapping + ! + !**************************************************** + ! + jall = ncube*ncube*12*10 !anticipated number of weights (cab be tweaked) + jmax_segments = 100000 !can be tweaked + + allocate (weights_all(jall,nreconstruction),stat=alloc_error ) + allocate (weights_eul_index_all(jall,3),stat=alloc_error ) + allocate (weights_lgr_index_all(jall),stat=alloc_error ) + CALL overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& + jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) + ! + !**************************************************** + ! + ! read cubed-sphere 3km data + ! + !**************************************************** + ! + WRITE(*,*) "read cubed-sphere 3km data from file" + status = nf_open('USGS-topo-cube3000.nc', 0, ncid) + IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) + + status = NF_INQ_DIMID(ncid, 'grid_size', dimid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + status = NF_INQ_DIMLEN(ncid, dimid, n) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + ncube = INT(SQRT(DBLE(n/6))) + WRITE(*,*) "cubed-sphere dimension, ncube: ",ncube + + allocate ( landm_coslat(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac' + stop + end if + + status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat) + ! + ! read LANDFRAC + ! + allocate ( landfrac(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac' + stop + end if + + status = NF_INQ_VARID(ncid, 'LANDFRAC', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + status = NF_GET_VAR_DOUBLE(ncid, landid,landfrac) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of landfrac",MINVAL(landfrac),MAXVAL(landfrac) + ! + ! read terr + ! + allocate ( terr(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac' + stop + end if + + status = NF_INQ_VARID(ncid, 'terr', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + status = NF_GET_VAR_DOUBLE(ncid, landid,terr) + + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of terr",MINVAL(terr),MAXVAL(terr) + allocate ( lat_terr(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for lat_terr' + stop + end if + status = NF_INQ_VARID(ncid, 'lat', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + status = NF_GET_VAR_DOUBLE(ncid, landid,lat_terr) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of lat",MINVAL(lat_terr),MAXVAL(lat_terr) + + allocate ( lon_terr(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for lon_terr' + stop + end if + status = NF_INQ_VARID(ncid, 'lon', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + status = NF_GET_VAR_DOUBLE(ncid, landid,lon_terr) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of lon",MINVAL(lon_terr),MAXVAL(lon_terr) + ! + ! + ! + allocate ( sgh30(n),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac' + stop + end if + + status = NF_INQ_VARID(ncid, 'SGH30', landid) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + + status = NF_GET_VAR_DOUBLE(ncid, landid,sgh30) + IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) + WRITE(*,*) "min/max of sgh30",MINVAL(sgh30),MAXVAL(sgh30) + + print *,"close file" + status = nf_close (ncid) + if (status .ne. NF_NOERR) call handle_err(status) + + WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file' + ! + !********************************************************* + ! + ! do actual remapping + ! + !********************************************************* + ! + allocate (terr_target(ntarget),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for terr_target' + stop + end if + allocate (landfrac_target(ntarget),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac_target' + stop + end if + allocate (landm_coslat_target(ntarget),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac_target' + stop + end if + allocate (sgh30_target(ntarget),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for sgh30_target' + stop + end if + allocate (area_target(ntarget),stat=alloc_error ) + terr_target = 0.0 + landfrac_target = 0.0 + sgh30_target = 0.0 + landm_coslat_target = 0.0 + area_target = 0.0 + + tmp = 0.0 + do count=1,jall + i = weights_lgr_index_all(count) + wt = weights_all(count,1) + area_target (i) = area_target(i) + wt + end do + + + do count=1,jall + i = weights_lgr_index_all(count) + + ix = weights_eul_index_all(count,1) + iy = weights_eul_index_all(count,2) + ip = weights_eul_index_all(count,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix + + wt = weights_all(count,1) + terr_target (i) = terr_target (i) + wt*terr (ii)/area_target(i) + landfrac_target (i) = landfrac_target (i) + wt*landfrac (ii)/area_target(i) + landm_coslat_target(i) = landm_coslat_target(i) + wt*landm_coslat(ii)/area_target(i) + sgh30_target (i) = sgh30_target (i) + wt*sgh30 (ii)/area_target(i) + tmp = tmp+wt*terr(ii) + end do + ! + write(*,*) "tmp", tmp + WRITE(*,*) "max difference between target grid area and remapping software area",& + MAXVAL(target_area-area_target) + + do count=1,ntarget + if (terr_target(count)>8848.0) then + ! + ! max height is higher than Mount Everest + ! + write(*,*) "FATAL error: max height is higher than Mount Everest!" + write(*,*) "terr_target",count,terr_target(count) + write(*,*) "(lon,lat) locations of vertices of cell with excessive max height::" + do i=1,ncorner + write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) + end do + STOP + else if (terr_target(count)<-423.0) then + ! + ! min height is lower than Dead Sea + ! + write(*,*) "FATAL error: min height is lower than Dead Sea!" + write(*,*) "terr_target",count,terr_target(count) + write(*,*) "(lon,lat) locations of vertices of cell with excessive min height::" + do i=1,ncorner + write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) + end do + STOP + else + + end if + end do + WRITE(*,*) "Elevation data passed min/max consistency check!" + WRITE(*,*) + + WRITE(*,*) "min/max of unsmoothed terr_target : ",MINVAL(terr_target ),MAXVAL(terr_target ) + WRITE(*,*) "min/max of landfrac_target : ",MINVAL(landfrac_target),MAXVAL(landfrac_target) + WRITE(*,*) "min/max of landm_coslat_target : ",& + MINVAL(landm_coslat_target),MAXVAL(landm_coslat_target) + WRITE(*,*) "min/max of var30_target : ",MINVAL(sgh30_target ),MAXVAL(sgh30_target ) + ! + ! compute mean height (globally) of topography about sea-level for target grid unfiltered elevation + ! + vol_target_un = 0.0 + area_target_total = 0.0 + DO i=1,ntarget + area_target_total = area_target_total+area_target(i) + vol_target_un = vol_target_un+terr_target(i)*area_target(i) + END DO + WRITE(*,*) "mean height (globally) of topography about sea-level for target grid unfiltered elevation",& + vol_target_un/area_target_total + + ! + ! diagnostics + ! + vol_source = 0.0 + allocate ( dA(ncube,ncube),stat=alloc_error ) + CALL EquiangularAllAreas(ncube, dA) + DO jp=1,6 + DO jy=1,ncube + DO jx=1,ncube + ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx + vol_source = vol_source+terr(ii)*dA(jx,jy) + END DO + END DO + END DO + WRITE(*,*) "volume of input cubed-sphere terrain :",vol_source + WRITE(*,*) "average elevation of input cubed-sphere terrain:",vol_source/(4.0*pi) + + DEALLOCATE(dA) + ! + ! + ! + allocate (sgh_target(ntarget),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for sgh_target' + stop + end if + ! + ! compute variance with respect to cubed-sphere data + ! + WRITE(*,*) "compute variance with respect to 3km cubed-sphere data: SGH" + + IF (lsmooth_terr) THEN + WRITE(*,*) "smoothing PHIS" + IF (lexternal_smooth_terr) THEN + WRITE(*,*) "using externally generated smoothed topography" + + status = nf_open(trim(smoothed_topography_file), 0, ncid) + IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) + status = nf_close(ncid) + !status = nf_open('phis-smooth.nc', 0, ncid) + !IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) + ! + IF (.NOT.ltarget_latlon) THEN + ! + !********************************************************* + ! + ! read in smoothed topography + ! + !********************************************************* + ! + status = NF_INQ_DIMID (ncid, 'ncol', ntarget_id ) + status = NF_INQ_DIMLEN(ncid, ntarget_id , ntarget_smooth) + IF (ntarget.NE.ntarget_smooth) THEN + WRITE(*,*) "mismatch in smoothed data-set and target grid specification" + WRITE(*,*) ntarget, ntarget_smooth + STOP + END IF + status = NF_INQ_VARID(ncid, 'PHIS', phisid) + ! + ! overwrite terr_target with smoothed version + ! + status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_target) + terr_target = terr_target/9.80616 + ELSE + ! + ! read in smoothed lat-lon topography + ! + status = NF_INQ_DIMID(ncid, 'lon', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon_smooth) + status = NF_INQ_DIMID(ncid, 'lat', ntarget_id) + status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat_smooth) + IF (nlon.NE.nlon_smooth.OR.nlat.NE.nlat_smooth) THEN + WRITE(*,*) "smoothed topography dimensions do not match target grid dimensions" + WRITE(*,*) "target grid : nlon ,nlat =",nlon,nlat + WRITE(*,*) "smoothed topo: nlon_smooth,nlat_smooth =",nlon_smooth,nlat_smooth + STOP + END IF + ALLOCATE(terr_smooth(nlon_smooth,nlat_smooth),stat=alloc_error) + status = NF_INQ_VARID(ncid, 'PHIS', phisid) + status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_smooth) + ! + ! overwrite terr_target with smoothed version + ! + ii=1 + DO j=1,nlat + DO i=1,nlon + terr_target(ii) = terr_smooth(i,j)/9.80616 + ii=ii+1 + END DO + END DO + DEALLOCATE(terr_smooth) + END IF + ELSE + WRITE(*,*) "unstested software - uncomment this line of you know what you are doing!" + STOP + ! + !***************************************************** + ! + ! smoothing topography internally + ! + !***************************************************** + ! + WRITE(*,*) "internally smoothing orography" + ! CALL smooth(terr_target,ntarget,target_corner_lon,target_corner_lat) + ! + ! smooth topography internally + ! + ncoarse = n/(factor*factor) + ! + ! + ! + ncube_coarse = ncube/factor + WRITE(*,*) "resolution of coarse grid", 90.0/ncube_coarse + allocate ( terr_coarse(ncoarse),stat=alloc_error ) + if( alloc_error /= 0 ) then + print*,'Program could not allocate space for landfrac' + stop + end if + WRITE(*,*) "coarsening" + allocate ( dA_coarse(ncube_coarse,ncube_coarse),stat=alloc_error ) + CALL coarsen(terr,terr_coarse,factor,n,dA_coarse) + ! + ! + ! + vol_tmp = 0.0 + DO jp=1,6 + DO jy=1,ncube_coarse + DO jx=1,ncube_coarse + ii = (jp-1)*ncube_coarse*ncube_coarse+(jy-1)*ncube_coarse+jx + vol_tmp = vol_tmp+terr_coarse(ii)*dA_coarse(jx,jy) + END DO + END DO + END DO + WRITE(*,*) "volume of coarsened cubed-sphere terrain :",vol_source + WRITE(*,*) "difference between coarsened cubed-sphere data and input cubed-sphere data",& + vol_tmp-vol_source + + + + WRITE(*,*) "done coarsening" + + nreconstruction = 1 + IF (norder>1) THEN + IF (norder == 2) THEN + nreconstruction = 3 + ELSEIF (norder == 3) THEN + nreconstruction = 6 + END IF + ALLOCATE(recons (nreconstruction, ncoarse), STAT=status) + ALLOCATE(centroids(nreconstruction, ncoarse), STAT=status) + CALL get_reconstruction(terr_coarse,norder, nmono, recons, npd,da_coarse,& + ncube_coarse+1,nreconstruction,centroids) + SELECT CASE (nmono) + CASE (0) + WRITE(*,*) "coarse grid reconstructions are not filtered with shape-preesrving filter" + CASE (1) + WRITE(*,*) "coarse grid reconstructions are filtered with shape-preserving filter" + CASE DEFAULT + WRITE(*,*) "nmono out of range: ",nmono + STOP + END SELECT + SELECT CASE (0) + CASE (0) + WRITE(*,*) "coarse grid reconstructions are not filtered with positive definite filter" + CASE (1) + WRITE(*,*) "coarse grid reconstructions filtered with positive definite filter" + CASE DEFAULT + WRITE(*,*) "npd out of range: ",npd + STOP + END SELECT + END IF + + jall_coarse = (ncube*ncube*12) !anticipated number of weights + jmax_segments_coarse = jmax_segments!/factor ! + WRITE(*,*) "anticipated",jall_coarse + allocate (weights_all_coarse(jall_coarse,nreconstruction),stat=alloc_error ) + allocate (weights_eul_index_all_coarse(jall_coarse,3),stat=alloc_error ) + allocate (weights_lgr_index_all_coarse(jall_coarse),stat=alloc_error ) + ! + ! + ! + CALL overlap_weights(weights_lgr_index_all_coarse,weights_eul_index_all_coarse,weights_all_coarse,& + jall_coarse,ncube_coarse,ngauss,ntarget,ncorner,jmax_segments_coarse,target_corner_lon,& + target_corner_lat,nreconstruction) + + WRITE(*,*) "MIN/MAX of area-weight [0:1]: ",& + MINVAL(weights_all_coarse(:,1)),MAXVAL(weights_all_coarse(:,1)) + ! + ! compute new weights + ! + + ! + ! do mapping + ! + terr_target = 0.0 + tmp = 0.0 + allocate ( area_target_coarse(ntarget),stat=alloc_error) + all_weights = 0.0 + area_target_coarse = 0.0 + do count=1,jall_coarse + i = weights_lgr_index_all_coarse(count) + wt = weights_all_coarse(count,1) + area_target_coarse (i) = area_target_coarse(i) + wt + all_weights = all_weights+wt + end do + WRITE(*,*) "sum of all weights (coarse to target) minus area of sphere : ",all_weights-4.0*pi + WRITE(*,*) "MIN/MAX of area_target_coarse [0:1]:",& + MINVAL(area_target_coarse),MAXVAL(area_target_coarse) + IF (norder==1) THEN + do count=1,jall_coarse + i = weights_lgr_index_all_coarse(count) + + ix = weights_eul_index_all_coarse(count,1) + iy = weights_eul_index_all_coarse(count,2) + ip = weights_eul_index_all_coarse(count,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix + + wt = weights_all_coarse(count,1) + + terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) + tmp = tmp+wt*terr_coarse(ii) + end do + ELSE IF (norder==2) THEN + do count=1,jall_coarse + i = weights_lgr_index_all_coarse(count) + IF (i>jall_coarse.OR.i<1) THEN + WRITE(*,*) i,jall_coarse + STOP + END IF + ix = weights_eul_index_all_coarse(count,1) + iy = weights_eul_index_all_coarse(count,2) + ip = weights_eul_index_all_coarse(count,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix + + terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& + ! + ! all constant terms + ! + terr_coarse(ii) & + - recons(1,ii)*centroids(1,ii) & + - recons(2,ii)*centroids(2,ii) & + ! + ! + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& + ! + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& + ! + ! + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& + )+& + ! + ! linear terms + ! + weights_all_coarse(count,2)*(& + + recons(1,ii)& + + ! - recons(3,ii)*2.0*centroids(1,ii)& + ! - recons(5,ii)* centroids(2,ii)& + )+& + ! + weights_all_coarse(count,3)*(& + recons(2,ii)& + ! + ! - recons(4,ii)*2.0*centroids(2,ii)& + ! - recons(5,ii)* centroids(1,ii)& + )& + ! + ! quadratic terms + ! + ! weights_all_coarse(count,4)*recons(3,ii)+& + ! weights_all_coarse(count,5)*recons(4,ii)+& + ! weights_all_coarse(count,6)*recons(5,ii) + )/area_target_coarse(i) + end do + DEALLOCATE(centroids) + DEALLOCATE(recons) + DEALLOCATE(weights_all_coarse) + + ELSE IF (norder==3) THEN + ! recons(4,:) = 0.0 + ! recons(5,:) = 0.0 + do count=1,jall_coarse + i = weights_lgr_index_all_coarse(count) + IF (i>jall_coarse.OR.i<1) THEN + WRITE(*,*) i,jall_coarse + STOP + END IF + ix = weights_eul_index_all_coarse(count,1) + iy = weights_eul_index_all_coarse(count,2) + ip = weights_eul_index_all_coarse(count,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix + + ! terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) + + ! WRITE(*,*) count,area_target_coarse(i) + ! terr_target(i) = terr_target(i) + area_target_coarse(i) + ! + terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& + + + ! centroids(5,ii))/area_target_coarse(i)) + ! centroids(1,ii)/area_target_coarse(i)) + ! /area_target_coarse(i)) + + + + + ! + ! all constant terms + ! + terr_coarse(ii) & + - recons(1,ii)*centroids(1,ii) & + - recons(2,ii)*centroids(2,ii) & + ! + + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& + + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& + ! + + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& + )+& + ! + ! linear terms + ! + weights_all_coarse(count,2)*(& + + recons(1,ii)& + + - recons(3,ii)*2.0*centroids(1,ii)& + - recons(5,ii)* centroids(2,ii)& + )+& + ! + weights_all_coarse(count,3)*(& + recons(2,ii)& + ! + - recons(4,ii)*2.0*centroids(2,ii)& + - recons(5,ii)* centroids(1,ii)& + )+& + ! + ! quadratic terms + ! + weights_all_coarse(count,4)*recons(3,ii)+& + weights_all_coarse(count,5)*recons(4,ii)+& + weights_all_coarse(count,6)*recons(5,ii))/area_target_coarse(i) + end do + DEALLOCATE(centroids) + DEALLOCATE(recons) + DEALLOCATE(weights_all_coarse) + END IF + DEALLOCATE(area_target_coarse) + WRITE(*,*) "done smoothing" + END IF + ! + ! compute mean height (globally) of topography about sea-level for target grid filtered elevation + ! + vol_target = 0.0 + DO i=1,ntarget + vol_target = vol_target+terr_target(i)*area_target(i) + ! if (ABS(area_target(i)-area_target_coarse(i))>0.000001) THEN + ! WRITE(*,*) "xxx",area_target(i),area_target_coarse(i),area_target(i)-area_target_coarse(i) + ! STOP + ! END IF + END DO + WRITE(*,*) "mean height (globally) of topography about sea-level for target grid filtered elevation",& + vol_target/area_target_total + WRITE(*,*) "percentage change in mean height between filtered and unfiltered elevations",& + 100.0*(vol_target-vol_target_un)/vol_target_un + WRITE(*,*) "percentage change in mean height between input cubed-sphere and unfiltered elevations",& + 100.0*(vol_source-vol_target_un)/vol_source + + END IF + ! + ! Done internal smoothing + ! + WRITE(*,*) "min/max of terr_target : ",MINVAL(terr_target),MAXVAL(terr_target) + + if (lzero_out_ocean_point_phis) then + WRITE(*,*) "if ocean mask PHIS=0.0" + end if + + + sgh_target=0.0 + do count=1,jall + i = weights_lgr_index_all(count)!! + ! + ix = weights_eul_index_all(count,1) + iy = weights_eul_index_all(count,2) + ip = weights_eul_index_all(count,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + + wt = weights_all(count,1) + + if (lzero_out_ocean_point_phis.AND.landfrac_target(i).lt.0.01_r8) then + terr_target(i) = 0.0_r8 !5*terr_target(i) + end if + sgh_target(i) = sgh_target(i)+wt*((terr_target(i)-terr(ii))**2)/area_target(i) + end do + + + + + ! + ! zero out small values + ! + DO i=1,ntarget + IF (landfrac_target(i)<.001_r8) landfrac_target(i) = 0.0 + IF (sgh_target(i)<0.5) sgh_target(i) = 0.0 + IF (sgh30_target(i)<0.5) sgh30_target(i) = 0.0 + END DO + sgh_target = SQRT(sgh_target) + sgh30_target = SQRT(sgh30_target) + +!for centroid of mass +!wt is useful proxy for dA +print*,"cal oa" +allocate(oa_target(ntarget,nvar_dirOA),stat=alloc_error) +call OAdir(terr,ntarget,ncube,n,nvar_dirOA,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,target_center_lon,target_center_lat,lon_terr,lat_terr,area_target,oa_target)!OAx,OAy) +!call OAorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,lon_terr,lat_terr,area_target,oa_target) +!par +!OC + print*,"cal oc" + allocate(oc_target(ntarget),stat=alloc_error) + oc_target=0.0_r8 + call OC(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,area_target,sgh_target,terr_target,oc_target) + +!OL + print*,"cal ol" + allocate(ol_target(ntarget,nvar_dirOL),stat=alloc_error) + ol_target=0.0_r8 + !call OLorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,lon_terr,lat_terr,area_target,sgh_target,target_center_lat,target_center_lon,target_corner_lat_deg,target_corner_lon_deg,ol_target) + allocate(indexb(ntarget),stat=alloc_error) + indexb=0.0_r8 + do count=1,jall + i = weights_lgr_index_all(count) + indexb(i)=indexb(i)+1 + enddo + allocate(terrout(4,ntarget,maxval(indexb)),stat=alloc_error) + allocate(dxy(ntarget,nvar_dirOL),stat=alloc_error) + call OLdir(terr,ntarget,ncube,n,jall,nlon,nlat,maxval(indexb),nvar_dirOL,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,target_center_lon,target_center_lat,target_corner_lon_deg,target_corner_lat_deg,lon_terr,lat_terr,sgh_target,area_target,ol_target,terrout,dxy) +!par + + WRITE(*,*) "min/max of sgh_target : ",MINVAL(sgh_target),MAXVAL(sgh_target) + WRITE(*,*) "min/max of sgh30_target : ",MINVAL(sgh30_target),MAXVAL(sgh30_target) + + DEALLOCATE(terr,weights_all,weights_eul_index_all,landfrac,landm_coslat) + + + + IF (ltarget_latlon) THEN +!#if 0 +! CALL wrtncdf_rll(nlon,nlat,lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& +! landm_coslat_target,target_center_lon,target_center_lat,.true.) +!#endif +print*,"output rll" + CALL wrtncdf_rll(nlon,nlat,nvar_dirOA,nvar_dirOL,maxval(indexb),lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target, oc_target,oa_target,ol_target,terrout,dxy,& + landm_coslat_target,target_center_lon,target_center_lat,.false.,output_topography_file) + + ELSE +!#if 0 +! CALL wrtncdf_unstructured(ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& +! landm_coslat_target,target_center_lon,target_center_lat) +!#endif + print*,"output unstructure" + CALL wrtncdf_unstructured(nvar_dirOA,nvar_dirOL,maxval(indexb),ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,oc_target,oa_target,ol_target,terrout,dxy,landm_coslat_target,target_center_lon,target_center_lat,output_topography_file) + END IF + + DEALLOCATE(terr_target,landfrac_target,sgh30_target,sgh_target,landm_coslat_target) +DEALLOCATE(oc_target) + +end program convterr + +! +! +! +!#if 0 +!subroutine wrtncdf_unstructured(n,terr,landfrac,sgh,sgh30,landm_coslat,lon,lat) +!#endif +subroutine wrtncdf_unstructured(nvar_dirOA,nvar_dirOL,indexb,n,terr,landfrac,sgh,sgh30,oc_in,oa_in,ol_in,terrout,dxy_in,landm_coslat,lon,lat,output) + + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + +# include + + ! + ! Dummy arguments + ! + integer, intent(in) :: n + real(r8),dimension(n) , intent(in) :: terr, landfrac,sgh,sgh30,lon, lat, landm_coslat + ! + ! Local variables + ! + character (len=512) :: fout ! NetCDF output file + + integer :: foutid ! Output file id + integer :: lonid, lonvid + integer :: latid, latvid + integer :: terrid,nid + integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid + integer :: status ! return value for error control of netcdf routin + integer :: i,j + integer, dimension(2) :: nc_lat_vid,nc_lon_vid + character (len=8) :: datestring + integer :: nc_gridcorn_id, lat_vid, lon_vid + + real(r8), parameter :: fillvalue = 1.d36 + integer, intent(in) :: nvar_dirOA,nvar_dirOL,indexb + character(len=512) :: output + integer :: ocid,varid,var2id,indexbid,terroutid(4) + integer :: oaid,olid,dxyid + integer :: oa1id,oa2id,oa3id,oa4id + integer :: ol1id,ol2id,ol3id,ol4id + integer, dimension(2) :: ocdim + integer, dimension(3) :: oadim,oldim,terroutdim + real(r8),dimension(n) , intent(in) :: oc_in + real(r8),dimension(n,nvar_dirOA) , intent(in) :: oa_in + real(r8),dimension(n,nvar_dirOL) , intent(in) :: ol_in + real(r8),dimension(4,n,indexb),intent(in) :: terrout + real(r8),dimension(n,nvar_dirOL),intent(in) :: dxy_in + character*20,dimension(4) :: terroutchar + real(r8),dimension(n) :: oc + real(r8),dimension(n,nvar_dirOA) :: oa + real(r8),dimension(n,nvar_dirOL) :: ol + real(r8),dimension(n,nvar_dirOL) :: dxy + character*20 :: numb + write(numb,"(i0.1)") nvar_dirOL + print*,"dir number", nvar_dirOL + !fout='final-'//adjustl(trim(numb))//'.nc' + fout=output + oc=oc_in + oa=oa_in + ol=ol_in + dxy=dxy_in + ! + ! Create NetCDF file for output + ! + print *,"Create NetCDF file for output" + status = nf_create (fout, NF_64BIT_OFFSET , foutid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Create dimensions for output + ! + status = nf_def_dim (foutid, 'ncol', n, nid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'nvar_dirOA', nvar_dirOA, varid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'nvar_dirOL', nvar_dirOL, var2id) + if (status .ne. NF_NOERR) call handle_err(status) + !status = nf_def_dim (foutid, 'indexb',23, indexbid) + status = nf_def_dim (foutid, 'indexb', indexb, indexbid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Create variable for output + ! + print *,"Create variable for output" + status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 1, nid, terrid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 1, nid, landfracid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'SGH', NF_DOUBLE, 1, nid, sghid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 1, nid, sgh30id) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 1, nid, landm_coslatid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, nid, latvid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, nid, lonvid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_var (foutid,'OC', NF_DOUBLE, 1, nid, ocid) + oadim(1)=nid + oadim(2)=varid + status = nf_def_var (foutid,'OA', NF_DOUBLE, 2, oadim, oaid) + oldim(1)=nid + oldim(2)=var2id + status = nf_def_var (foutid,'OL', NF_DOUBLE, 2, oldim, olid) +!#if 0 +! terroutdim(1)=nid +! terroutdim(2)=indexbid +! !name +! terroutchar(1)="terr" +! terroutchar(2)="terrx" +! terroutchar(3)="terry" +! terroutchar(4)="wt" +! do i=1,4 +! status = nf_def_var (foutid, terroutchar(i), NF_DOUBLE, 2, & +! terroutdim, terroutid(i)) +! enddo +! !dxy +! status = nf_def_var (foutid,'dxy', NF_DOUBLE, 2, oldim, dxyid) +!#endif + ! + ! Create attributes for output variables + ! + status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') + status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') + status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) + ! status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from USGS 30-sec data') + + status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & + 'standard deviation of 3km cubed-sphere elevation and target grid elevation') + status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') + ! status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & + 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') + status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') + ! status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') + status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') + ! status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') + + + status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') + if (status .ne. NF_NOERR) call handle_err(status) + ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') + ! if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') + if (status .ne. NF_NOERR) call handle_err(status) + ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') + ! if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_put_att_text (foutid,NF_GLOBAL,'source', 50, 'USGS 30-sec dataset binned to ncube3000 (cube-sphere) grid') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') + if (status .ne. NF_NOERR) call handle_err(status) + call DATE_AND_TIME(DATE=datestring) + status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,oaid,'note', 40, '(2)+1 in nvar_dirOA to avoid bug in io') +!#if 0 +! do i=1,4 +! status = nf_put_att_double (foutid, terroutid(i),& +! 'missing_value', nf_double, 1,fillvalue) +! status = nf_put_att_double (foutid, terroutid(i),& +! '_FillValue' , nf_double, 1,fillvalue) +! enddo +!#endif + ! + ! End define mode for output file + ! + status = nf_enddef (foutid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Write variable for output + ! + print*,"writing oc data",MINVAL(oc),MAXVAL(oc) + status = nf_put_var_double (foutid, ocid, oc) + if (status .ne. NF_NOERR) call handle_err(status) + !oa,ol + print*,"writing oa data",MINVAL(oa),MAXVAL(oa) + status = nf_put_var_double (foutid, oaid, oa) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"writing ol data",MINVAL(ol),MAXVAL(ol) + status = nf_put_var_double (foutid, olid, ol) + if (status .ne. NF_NOERR) call handle_err(status) +!#if 0 +! do i=1,4 +! status = nf_put_att_double (foutid, terroutid(i),& +! 'missing_value', nf_double, 1,fillvalue) +! status = nf_put_att_double (foutid, terroutid(i),& +! '_FillValue' , nf_double, 1,fillvalue) +! print*,"writing"//terroutchar(i)//" data",& +! MINVAL(terrout(i,:,:)),MAXVAL(terrout(i,:,:)) +! status = nf_put_var_double (foutid, terroutid(i), terrout(i,:,:)) +! if (status .ne. NF_NOERR) call handle_err(status) +! enddo +!#endif +!#if 0 +! print*,"writing dxy data",MINVAL(dxy),MAXVAL(dxy) +! status = nf_put_var_double (foutid, dxyid, dxy) +! if (status .ne. NF_NOERR) call handle_err(status) +!#endif + print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) + status = nf_put_var_double (foutid, terrid, terr*9.80616) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing terrain data" + + print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) + status = nf_put_var_double (foutid, landfracid, landfrac) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing landfrac data" + + print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) + status = nf_put_var_double (foutid, sghid, sgh) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh data" + + print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) + status = nf_put_var_double (foutid, sgh30id, sgh30) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh30 data" + + print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) + status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh30 data" + ! + print*,"writing lat data" + status = nf_put_var_double (foutid, latvid, lat) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing lat data" + + print*,"writing lon data" + status = nf_put_var_double (foutid, lonvid, lon) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing lon data" + ! + ! Close output file + ! + print *,"close file" + status = nf_close (foutid) + if (status .ne. NF_NOERR) call handle_err(status) +end subroutine wrtncdf_unstructured +! +!************************************************************** +! +! if target grid is lat-lon output structured +! +!************************************************************** +! + +!#if 0 +!subroutine wrtncdf_rll(nlon,nlat,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine) +!#endif +subroutine wrtncdf_rll(nlon,nlat,nvar_dirOA,nvar_dirOL,indexb,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,oc_in,oa_in,ol_in,terrout,dxy_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine,output) + + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + +# include + + ! + ! Dummy arguments + ! + integer, intent(in) :: n,nlon,nlat,nvar_dirOA,nvar_dirOL,indexb + ! + ! lprepare_fv_smoothing_routine is to make a NetCDF file that can be used with the CAM-FV smoothing software + ! + logical , intent(in) :: lpole,lprepare_fv_smoothing_routine + real(r8),dimension(n) , intent(in) :: terr_in, landfrac_in,sgh_in,sgh30_in,lon, lat, landm_coslat_in + real(r8),dimension(n) , intent(in) :: oc_in + real(r8),dimension(n,nvar_dirOA) , intent(in) :: oa_in + real(r8),dimension(n,nvar_dirOL) , intent(in) :: ol_in + real(r8),dimension(4,n,indexb),intent(in) :: terrout + real(r8),dimension(n,nvar_dirOL),intent(in) :: dxy_in + character*20,dimension(4) :: terroutchar + character(len=512),intent(in) :: output + ! + ! Local variables + ! + character (len=512):: fout ! NetCDF output file + integer :: foutid ! Output file id + integer :: lonid, lonvid + integer :: latid, latvid + integer :: terrid,nid + integer :: ocid,varid,var2id,indexbid,terroutid(4) + integer :: oaid,olid,dxyid + integer :: oa1id,oa2id,oa3id,oa4id + integer :: ol1id,ol2id,ol3id,ol4id + integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid + integer :: status ! return value for error control of netcdf routin + integer :: i,j + integer, dimension(2) :: nc_lat_vid,nc_lon_vid + character (len=8) :: datestring + integer :: nc_gridcorn_id, lat_vid, lon_vid + real(r8), parameter :: fillvalue = 1.d36 + real(r8) :: ave + + real(r8),dimension(nlon) :: lonar ! longitude array + real(r8),dimension(nlat) :: latar ! latitude array + + integer, dimension(2) :: htopodim,landfdim,sghdim,sgh30dim,landmcoslatdim +integer, dimension(2) :: ocdim +integer, dimension(3) :: oadim,oldim,terroutdim + real(r8),dimension(n) :: terr, landfrac,sgh,sgh30,landm_coslat + real(r8),dimension(n) :: oc + real(r8),dimension(n,nvar_dirOA) :: oa + real(r8),dimension(n,nvar_dirOL) :: ol + real(r8),dimension(n,nvar_dirOL) :: dxy + character*20 :: numb +!print*,"nlon nlat n",nlon, nlat, n + IF (nlon*nlat.NE.n) THEN + WRITE(*,*) "inconsistent input for wrtncdf_rll" + STOP + END IF + ! + ! we assume that the unstructured layout of the lat-lon grid is ordered in latitude rows, that is, + ! unstructured index n is given by + ! + ! n = (j-1)*nlon+i + ! + ! where j is latitude index and i longitude index + ! + do i = 1,nlon + lonar(i)= lon(i) + enddo + do j = 1,nlat + latar(j)= lat((j-1)*nlon+1) + enddo + + terr = terr_in + sgh=sgh_in + sgh30 =sgh30_in + landfrac = landfrac_in + landm_coslat = landm_coslat_in + oc=oc_in + oa=oa_in + ol=ol_in + dxy=dxy_in + + if (lpole) then + write(*,*) "average pole control volume" + ! + ! North pole - terr + ! + ave = 0.0 + do i=1,nlon + ave = ave + terr_in(i) + end do + terr(1:nlon) = ave/DBLE(nlon) + ! + ! South pole + ! + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + terr_in(i) + end do + terr(n-(nlon+1):n) = ave/DBLE(nlon) + !oc + ! North pole - terr + ave = 0.0 + do i=1,nlon + ave = ave + oc_in(i) + end do + oc(1:nlon) = ave/DBLE(nlon) + ! South pole + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + oc_in(i) + end do + oc(n-(nlon+1):n) = ave/DBLE(nlon) + !oa + ! North pole - terr +do j =1,nvar_dirOA + ave = 0.0 + do i=1,nlon + ave = ave + oa_in(i,j) + end do + oa(1:nlon,j) = ave/DBLE(nlon) + ! South pole + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + oa_in(i,j) + end do + oa(n-(nlon+1):n,j) = ave/DBLE(nlon) +enddo + !ol +!#if 0 +! North pole - terr +do j =1,nvar_dirOL + ave = 0.0 + do i=1,nlon + ave = ave + ol_in(i,j) + end do + ol(1:nlon,j) = ave/DBLE(nlon) + ! South pole + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + ol_in(j,i) + end do + ol(n-(nlon+1):n,j) = ave/DBLE(nlon) +enddo +!#endif + + ! + ! North pole - sgh + ! + ave = 0.0 + do i=1,nlon + ave = ave + sgh_in(i) + end do + sgh(1:nlon) = ave/DBLE(nlon) + ! + ! South pole + ! + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + sgh_in(i) + end do + sgh(n-(nlon+1):n) = ave/DBLE(nlon) + + ! + ! North pole - sgh30 + ! + ave = 0.0 + do i=1,nlon + ave = ave + sgh30_in(i) + end do + sgh30(1:nlon) = ave/DBLE(nlon) + ! + ! South pole + ! + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + sgh30_in(i) + end do + sgh30(n-(nlon+1):n) = ave/DBLE(nlon) + + ! + ! North pole - landfrac + ! + ave = 0.0 + do i=1,nlon + ave = ave + landfrac_in(i) + end do + landfrac(1:nlon) = ave/DBLE(nlon) + ! + ! South pole + ! + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + landfrac_in(i) + end do + landfrac(n-(nlon+1):n) = ave/DBLE(nlon) + + ! + ! North pole - landm_coslat + ! + ave = 0.0 + do i=1,nlon + ave = ave + landm_coslat_in(i) + end do + landm_coslat(1:nlon) = ave/DBLE(nlon) + ! + ! South pole + ! + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + landm_coslat_in(i) + end do + landm_coslat(n-(nlon+1):n) = ave/DBLE(nlon) + +!dxy + do j=1,4 + ave = 0.0 + do i=n-(nlon+1),n + ave = ave + dxy(j,i) + end do + dxy(j,n-(nlon+1):n) = ave/DBLE(nlon) + enddo +!dxy + end if + ! + write(numb,"(i0.1)") nvar_dirOL + print*,"dir number", nvar_dirOL + + + !fout='final-'//adjustl(trim(numb))//'.nc' + fout=output + ! + ! Create NetCDF file for output + ! + print *,"Create NetCDF file for output" + status = nf_create (fout, NF_64BIT_OFFSET , foutid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Create dimensions for output + ! + print *,"Create dimensions for output" + status = nf_def_dim (foutid, 'lon', nlon, lonid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'lat', nlat, latid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'nvar_dirOA', nvar_dirOA, varid) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'nvar_dirOL', nvar_dirOL, var2id) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_def_dim (foutid, 'indexb', indexb, indexbid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Create variable for output + ! + print *,"Create variable for output" + ocdim(1)=lonid + ocdim(2)=latid + status = nf_def_var (foutid,'OC', NF_DOUBLE, 2, ocdim, ocid) + oadim(1)=lonid + oadim(2)=latid + oadim(3)=varid + status = nf_def_var (foutid,'OA', NF_DOUBLE, 3, oadim, oaid) + oldim(1)=lonid + oldim(2)=latid + oldim(3)=var2id + status = nf_def_var (foutid,'OL', NF_DOUBLE, 3, oldim, olid) + terroutdim(1)=lonid + terroutdim(2)=latid + terroutdim(3)=indexbid + !name + terroutchar(1)="terr" + terroutchar(2)="terrx" + terroutchar(3)="terry" + terroutchar(4)="wt" +!#if 0 + do i=1,4 + status = nf_def_var (foutid, terroutchar(i), NF_DOUBLE, 3, & + terroutdim, terroutid(i)) + enddo +!#endif + !dxy + status = nf_def_var (foutid,'dxy', NF_DOUBLE, 3, oldim, dxyid) +!#endif + +!#if 0 +! status = nf_def_var (foutid,'OL1', NF_DOUBLE, 2, ocdim, ol1id) +! status = nf_def_var (foutid,'OL2', NF_DOUBLE, 2, ocdim, ol2id) +! status = nf_def_var (foutid,'OL3', NF_DOUBLE, 2, ocdim, ol3id) +! status = nf_def_var (foutid,'OL4', NF_DOUBLE, 2, ocdim, ol4id) +! status = nf_def_var (foutid,'OA1', NF_DOUBLE, 2, ocdim, oa1id) +! status = nf_def_var (foutid,'OA2', NF_DOUBLE, 2, ocdim, oa2id) +! status = nf_def_var (foutid,'OA3', NF_DOUBLE, 2, ocdim, oa3id) +! status = nf_def_var (foutid,'OA4', NF_DOUBLE, 2, ocdim, oa4id) +!#endif + + htopodim(1)=lonid + htopodim(2)=latid + + if (lprepare_fv_smoothing_routine) then + status = nf_def_var (foutid,'htopo', NF_DOUBLE, 2, htopodim, terrid) + else + status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 2, htopodim, terrid) + end if + if (status .ne. NF_NOERR) call handle_err(status) + + landfdim(1)=lonid + landfdim(2)=latid + + if (lprepare_fv_smoothing_routine) then + status = nf_def_var (foutid,'ftopo', NF_DOUBLE, 2, landfdim, landfracid) + else + status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 2, landfdim, landfracid) + end if + + if (status .ne. NF_NOERR) call handle_err(status) + + sghdim(1)=lonid + sghdim(2)=latid + + status = nf_def_var (foutid,'SGH', NF_DOUBLE, 2, sghdim, sghid) + if (status .ne. NF_NOERR) call handle_err(status) + + sgh30dim(1)=lonid + sgh30dim(2)=latid + + status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 2, sgh30dim, sgh30id) + if (status .ne. NF_NOERR) call handle_err(status) + + landmcoslatdim(1)=lonid + landmcoslatdim(2)=latid + + status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, landmcoslatdim, landm_coslatid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) + if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) + if (status .ne. NF_NOERR) call handle_err(status) + + ! + ! Create attributes for output variables + ! + status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') + status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') + status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from ncube3000 data') + status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) + + + status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & + 'standard deviation of 3km cubed-sphere elevation and target grid elevation') + status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') + status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & + 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') + status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') + status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') + status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') + + status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) + status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) + status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') + status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') + + + status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') + if (status .ne. NF_NOERR) call handle_err(status) + ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') + ! if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') + if (status .ne. NF_NOERR) call handle_err(status) + ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') + ! if (status .ne. NF_NOERR) call handle_err(status) + + status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') + if (status .ne. NF_NOERR) call handle_err(status) + call DATE_AND_TIME(DATE=datestring) + status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) + if (status .ne. NF_NOERR) call handle_err(status) + status = nf_put_att_text (foutid,oaid,'note', 40, '(2)+1 in nvar_dirOA to avoid bug in io') + do i=1,4 + status = nf_put_att_double (foutid, terroutid(i),& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, terroutid(i),& + '_FillValue' , nf_double, 1,fillvalue) + enddo + + status = nf_put_att_double (foutid, oa1id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa1id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa2id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa2id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa3id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa3id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa4id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, oa4id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol1id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol1id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol2id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol2id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol3id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol3id,& + '_FillValue' , nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol4id,& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, ol4id,& + '_FillValue' , nf_double, 1,fillvalue) + ! + ! End define mode for output file + ! + status = nf_enddef (foutid) + if (status .ne. NF_NOERR) call handle_err(status) + ! + ! Write variable for output +print*,"writing oc data",MINVAL(oc),MAXVAL(oc) +status = nf_put_var_double (foutid, ocid, oc) +if (status .ne. NF_NOERR) call handle_err(status) +!oa,ol +print*,"writing oa data",MINVAL(oa),MAXVAL(oa) +status = nf_put_var_double (foutid, oaid, oa) +if (status .ne. NF_NOERR) call handle_err(status) +print*,"writing ol data",MINVAL(ol),MAXVAL(ol) +status = nf_put_var_double (foutid, olid, ol) + +!============ +#if 0 +print*,"writing oa1 data",MINVAL(oa),MAXVAL(oa) +status = nf_put_var_double (foutid, oa1id, oa(:,1)) +if (status .ne. NF_NOERR) call handle_err(status) +print*,"writing ol1 data",MINVAL(ol),MAXVAL(ol) +status = nf_put_var_double (foutid, ol1id, ol(:,1)) +print*,"writing oa2 data",MINVAL(oa),MAXVAL(oa) +status = nf_put_var_double (foutid, oa2id, oa(:,2)) +if (status .ne. NF_NOERR) call handle_err(status) +print*,"writing ol2 data",MINVAL(ol),MAXVAL(ol) +status = nf_put_var_double (foutid, ol2id, ol(:,2)) +print*,"writing oa3 data",MINVAL(oa),MAXVAL(oa) +status = nf_put_var_double (foutid, oa3id, oa(:,3)) +if (status .ne. NF_NOERR) call handle_err(status) +print*,"writing ol3 data",MINVAL(ol),MAXVAL(ol) +status = nf_put_var_double (foutid, ol3id, ol(:,3)) +print*,"writing oa4 data",MINVAL(oa),MAXVAL(oa) +status = nf_put_var_double (foutid, oa4id, oa(:,4)) +if (status .ne. NF_NOERR) call handle_err(status) +print*,"writing ol4 data",MINVAL(ol),MAXVAL(ol) +status = nf_put_var_double (foutid, ol4id, ol(:,4)) +#endif +!=========== + + +if (status .ne. NF_NOERR) call handle_err(status) +!#if 0 + do i=1,4 + status = nf_put_att_double (foutid, terroutid(i),& + 'missing_value', nf_double, 1,fillvalue) + status = nf_put_att_double (foutid, terroutid(i),& + '_FillValue' , nf_double, 1,fillvalue) + print*,"writing"//terroutchar(i)//" data",& + MINVAL(terrout(i,:,:)),MAXVAL(terrout(i,:,:)) + status = nf_put_var_double (foutid, terroutid(i), terrout(i,:,:)) + if (status .ne. NF_NOERR) call handle_err(status) + enddo +!#endif + +!#if 0 + print*,"writing dxy data",MINVAL(dxy),MAXVAL(dxy) + status = nf_put_var_double (foutid, dxyid, dxy) + if (status .ne. NF_NOERR) call handle_err(status) +!#endif + ! + print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) + if (lprepare_fv_smoothing_routine) then + status = nf_put_var_double (foutid, terrid, terr) + else + status = nf_put_var_double (foutid, terrid, terr*9.80616) + end if + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing terrain data" + + print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) + status = nf_put_var_double (foutid, landfracid, landfrac) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing landfrac data" + + print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) + status = nf_put_var_double (foutid, sghid, sgh) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh data" + + print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) + status = nf_put_var_double (foutid, sgh30id, sgh30) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh30 data" + + print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) + status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing sgh30 data" + ! + print*,"writing lat data" + status = nf_put_var_double (foutid, latvid, latar) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing lat data" + + print*,"writing lon data" + status = nf_put_var_double (foutid, lonvid, lonar) + if (status .ne. NF_NOERR) call handle_err(status) + print*,"done writing lon data" + ! + ! Close output file + ! + print *,"close file" + status = nf_close (foutid) + if (status .ne. NF_NOERR) call handle_err(status) +end subroutine wrtncdf_rll +!************************************************************************ +!!handle_err +!************************************************************************ +! +!!ROUTINE: handle_err +!!DESCRIPTION: error handler +!-------------------------------------------------------------------------- + +subroutine handle_err(status) + + implicit none + +# include + + integer status + + if (status .ne. nf_noerr) then + print *, nf_strerror(status) + stop 'Stopped' + endif + +end subroutine handle_err + + +SUBROUTINE coarsen(f,fcoarse,nf,n,dA_coarse) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + REAL (R8), DIMENSION(n) , INTENT(IN) :: f + REAL (R8), DIMENSION(n/nf), INTENT(OUT) :: fcoarse + INTEGER, INTENT(in) :: n,nf + REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf),INTENT(OUT) :: dA_coarse + !must be an even number + ! + ! local workspace + ! + ! ncube = INT(SQRT(DBLE(n/6))) + + REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6))),INT(SQRT(DBLE(n/6)))):: dA + REAL (R8) :: sum, sum_area,tmp + INTEGER :: jx,jy,jp,ii,ii_coarse,coarse_ncube,ncube + INTEGER :: jx_coarse,jy_coarse,jx_s,jy_s + + + ! REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf) :: dAtmp + + ncube = INT(SQRT(DBLE(n/6))) + coarse_ncube = ncube/nf + + IF (ABS(DBLE(ncube)/DBLE(nf)-coarse_ncube)>0.000001) THEN + WRITE(*,*) "ncube/nf must be an integer" + WRITE(*,*) "ncube and nf: ",ncube,nf + STOP + END IF + + da_coarse = 0.0 + + WRITE(*,*) "compute all areas" + CALL EquiangularAllAreas(ncube, dA) + ! CALL EquiangularAllAreas(coarse_ncube, dAtmp)!dbg + tmp = 0.0 + DO jp=1,6 + DO jy_coarse=1,coarse_ncube + DO jx_coarse=1,coarse_ncube + ! + ! inner loop + ! + sum = 0.0 + sum_area = 0.0 + DO jy_s=1,nf + jy = (jy_coarse-1)*nf+jy_s + DO jx_s=1,nf + jx = (jx_coarse-1)*nf+jx_s + ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx + sum = sum +f(ii)*dA(jx,jy) + sum_area = sum_area+dA(jx,jy) + ! WRITE(*,*) "jx,jy",jx,jy + END DO + END DO + tmp = tmp+sum_area + da_coarse(jx_coarse,jy_coarse) = sum_area + ! WRITE(*,*) "jx_coarse,jy_coarse",jx_coarse,jy_coarse,& + ! da_coarse(jx_coarse,jy_coarse)-datmp(jx_coarse,jy_coarse) + ii_coarse = (jp-1)*coarse_ncube*coarse_ncube+(jy_coarse-1)*coarse_ncube+jx_coarse + fcoarse(ii_coarse) = sum/sum_area + END DO + END DO + END DO + WRITE(*,*) "coarsened surface area",tmp-4.0*3.141592654 +END SUBROUTINE COARSEN + +SUBROUTINE overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& + jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) + use shr_kind_mod, only: r8 => shr_kind_r8 + use remap + IMPLICIT NONE + + + INTEGER, INTENT(INOUT) :: jall !anticipated number of weights + INTEGER, INTENT(IN) :: ncube, ngauss, ntarget, jmax_segments, ncorner, nreconstruction + + INTEGER, DIMENSION(jall,3), INTENT(OUT) :: weights_eul_index_all + REAL(R8), DIMENSION(jall,nreconstruction) , INTENT(OUT) :: weights_all + INTEGER, DIMENSION(jall) , INTENT(OUT) :: weights_lgr_index_all + + REAL(R8), DIMENSION(ncorner,ntarget), INTENT(IN) :: target_corner_lon, target_corner_lat + + INTEGER, DIMENSION(ncorner+1) :: ipanel_array, ipanel_tmp + REAL(R8), DIMENSION(ncorner) :: lat, lon + REAL(R8), DIMENSION(0:ncube+2):: xgno, ygno + REAL(R8), DIMENSION(0:ncorner+1) :: xcell, ycell + + REAL(R8), DIMENSION(ngauss) :: gauss_weights, abscissae + + REAL(R8) :: da, tmp, alpha, beta + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + REAL (r8), PARAMETER :: pih = 0.50*pi + INTEGER :: i, j,ncorner_this_cell,k,ip,ipanel,ii,jx,jy,jcollect + integer :: alloc_error + + REAL (r8), PARAMETER :: rad2deg = 180.0/pi + + real(r8), allocatable, dimension(:,:) :: weights + integer , allocatable, dimension(:,:) :: weights_eul_index + + + LOGICAL:: ldbg = .FAlSE. + + INTEGER :: jall_anticipated + + jall_anticipated = jall + + ipanel_array = -99 + ! + da = pih/DBLE(ncube) + xgno(0) = -bignum + DO i=1,ncube+1 + xgno(i) = TAN(-piq+(i-1)*da) + END DO + xgno(ncube+2) = bignum + ygno = xgno + + CALL glwp(ngauss,gauss_weights,abscissae) + + + allocate (weights(jmax_segments,nreconstruction),stat=alloc_error ) + allocate (weights_eul_index(jmax_segments,2),stat=alloc_error ) + + tmp = 0.0 + jall = 1 + DO i=1,ntarget + WRITE(*,*) "cell",i," ",100.0*DBLE(i)/DBLE(ntarget),"% done" + ! + !--------------------------------------------------- + ! + ! determine how many vertices the cell has + ! + !--------------------------------------------------- + ! + CALL remove_duplicates_latlon(ncorner,target_corner_lon(:,i),target_corner_lat(:,i),& + ncorner_this_cell,lon,lat,1.0E-10,ldbg) + + IF (ldbg) THEN + WRITE(*,*) "number of vertices ",ncorner_this_cell + WRITE(*,*) "vertices locations lon,",lon(1:ncorner_this_cell)*rad2deg + WRITE(*,*) "vertices locations lat,",lat(1:ncorner_this_cell)*rad2deg + DO j=1,ncorner_this_cell + WRITE(*,*) lon(j)*rad2deg, lat(j)*rad2deg + END DO + WRITE(*,*) " " + END IF + ! + !--------------------------------------------------- + ! + ! determine how many and which panels the cell spans + ! + !--------------------------------------------------- + ! + DO j=1,ncorner_this_cell + CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ipanel_tmp(j), .TRUE.) + IF (ldbg) WRITE(*,*) "ipanel for corner ",j," is ",ipanel_tmp(j) + END DO + ipanel_tmp(ncorner_this_cell+1) = ipanel_tmp(1) + ! make sure to include possible overlap areas not on the face the vertices are located + IF (MINVAL(lat(1:ncorner_this_cell))<-pi/6.0) THEN + ! include South-pole panel in search + ipanel_tmp(ncorner_this_cell+1) = 5 + IF (ldbg) WRITE(*,*) "add panel 5 to search" + END IF + IF (MAXVAL(lat(1:ncorner_this_cell))>pi/6.0) THEN + ! include North-pole panel in search + ipanel_tmp(ncorner_this_cell+1) = 6 + IF (ldbg) WRITE(*,*) "add panel 6 to search" + END IF + ! + ! remove duplicates in ipanel_tmp + ! + CALL remove_duplicates_integer(ncorner_this_cell+1,ipanel_tmp(1:ncorner_this_cell+1),& + k,ipanel_array(1:ncorner_this_cell+1)) + ! + !--------------------------------------------------- + ! + ! loop over panels with possible overlap areas + ! + !--------------------------------------------------- + ! + DO ip = 1,k + ipanel = ipanel_array(ip) + DO j=1,ncorner_this_cell + ii = ipanel + CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ii,.FALSE.) + IF (j==1) THEN + jx = CEILING((alpha + piq) / da) + jy = CEILING((beta + piq) / da) + END IF + xcell(ncorner_this_cell+1-j) = TAN(alpha) + ycell(ncorner_this_cell+1-j) = TAN(beta) + END DO + xcell(0) = xcell(ncorner_this_cell) + ycell(0) = ycell(ncorner_this_cell) + xcell(ncorner_this_cell+1) = xcell(1) + ycell(ncorner_this_cell+1) = ycell(1) + + jx = MAX(MIN(jx,ncube+1),0) + jy = MAX(MIN(jy,ncube+1),0) + + CALL compute_weights_cell(xcell(0:ncorner_this_cell+1),ycell(0:ncorner_this_cell+1),& + jx,jy,nreconstruction,xgno,ygno,& + 1, ncube+1, 1,ncube+1, tmp,& + ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& + ncube,0,ncorner_this_cell,ldbg) + + weights_all(jall:jall+jcollect-1,1:nreconstruction) = weights(1:jcollect,1:nreconstruction) + + weights_eul_index_all(jall:jall+jcollect-1,1:2) = weights_eul_index(1:jcollect,:) + weights_eul_index_all(jall:jall+jcollect-1, 3) = ipanel + weights_lgr_index_all(jall:jall+jcollect-1 ) = i + + jall = jall+jcollect + IF (jall>jall_anticipated) THEN + WRITE(*,*) "more weights than anticipated" + WRITE(*,*) "increase jall" + STOP + END IF + IF (ldbg) WRITE(*,*) "jcollect",jcollect + END DO + END DO + jall = jall-1 + WRITE(*,*) "sum of all weights divided by surface area of sphere =",tmp/(4.0*pi) + WRITE(*,*) "actual number of weights",jall + WRITE(*,*) "anticipated number of weights",jall_anticipated + IF (jall>jall_anticipated) THEN + WRITE(*,*) "anticipated number of weights < actual number of weights" + WRITE(*,*) "increase jall!" + STOP + END IF + WRITE(*,*) MINVAL(weights_all(1:jall,1)),MAXVAL(weights_all(1:jall,1)) + IF (ABS(tmp/(4.0*pi))-1.0>0.001) THEN + WRITE(*,*) "sum of all weights does not match the surface area of the sphere" + WRITE(*,*) "sum of all weights is : ",tmp + WRITE(*,*) "surface area of sphere: ",4.0*pi + STOP + END IF +END SUBROUTINE overlap_weights + + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereABPFromRLL +! +! Description: +! Determine the (alpha,beta,panel) coordinate of a point on the sphere from +! a given regular lat lon coordinate. +! +! Parameters: +! lon - Coordinate longitude +! lat - Coordinate latitude +! alpha (OUT) - Alpha coordinate +! beta (OUT) - Beta coordinate +! ipanel (OUT) - Face panel +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + REAL (R8), INTENT(IN) :: lon, lat + REAL (R8), INTENT(OUT) :: alpha, beta + INTEGER :: ipanel + LOGICAL, INTENT(IN) :: ldetermine_panel + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + REAL (r8), PARAMETER :: rotate_cube = 0.0 + + ! Local variables + REAL (R8) :: xx, yy, zz, pm + REAL (R8) :: sx, sy, sz + INTEGER :: ix, iy, iz + + ! Translate to (x,y,z) space + xx = COS(lon-rotate_cube) * COS(lat) + yy = SIN(lon-rotate_cube) * COS(lat) + zz = SIN(lat) + + pm = MAX(ABS(xx), ABS(yy), ABS(zz)) + + ! Check maximality of the x coordinate + IF (pm == ABS(xx)) THEN + IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF + ELSE + ix = 0 + ENDIF + + ! Check maximality of the y coordinate + IF (pm == ABS(yy)) THEN + IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF + ELSE + iy = 0 + ENDIF + + ! Check maximality of the z coordinate + IF (pm == ABS(zz)) THEN + IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF + ELSE + iz = 0 + ENDIF + + ! Panel assignments + IF (ldetermine_panel) THEN + IF (iz == 1) THEN + ipanel = 6; sx = yy; sy = -xx; sz = zz + + ELSEIF (iz == -1) THEN + ipanel = 5; sx = yy; sy = xx; sz = -zz + + ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN + ipanel = 1; sx = yy; sy = zz; sz = xx + + ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN + ipanel = 3; sx = -yy; sy = zz; sz = -xx + + ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN + ipanel = 2; sx = -xx; sy = zz; sz = yy + + ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN + ipanel = 4; sx = xx; sy = zz; sz = -yy + + ELSE + WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' + WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' + WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' + STOP + ENDIF + ELSE + IF (ipanel == 6) THEN + sx = yy; sy = -xx; sz = zz + ELSEIF (ipanel == 5) THEN + sx = yy; sy = xx; sz = -zz + ELSEIF (ipanel == 1) THEN + sx = yy; sy = zz; sz = xx + ELSEIF (ipanel == 3) THEN + sx = -yy; sy = zz; sz = -xx + ELSEIF (ipanel == 2) THEN + sx = -xx; sy = zz; sz = yy + ELSEIF (ipanel == 4) THEN + sx = xx; sy = zz; sz = -yy + ELSE + WRITE(*,*) "ipanel out of range",ipanel + STOP + END IF + END IF + + ! Use panel information to calculate (alpha, beta) coords + alpha = ATAN(sx / sz) + beta = ATAN(sy / sz) + +END SUBROUTINE CubedSphereABPFromRLL + +!------------------------------------------------------------------------------ +! SUBROUTINE EquiangularAllAreas +! +! Description: +! Compute the area of all cubed sphere grid cells, storing the results in +! a two dimensional array. +! +! Parameters: +! icube - Resolution of the cubed sphere +! dA (OUT) - Output array containing the area of all cubed sphere grid cells +!------------------------------------------------------------------------------ +SUBROUTINE EquiangularAllAreas(icube, dA) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + INTEGER, INTENT(IN) :: icube + REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA + + ! Local variables + INTEGER :: k, k1, k2 + REAL (r8) :: a1, a2, a3, a4 + REAL (r8), DIMENSION(icube+1,icube+1) :: ang + REAL (r8), DIMENSION(icube+1) :: gp + + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + + + !#ifdef DBG + REAL (r8) :: dbg1 !DBG + !#endif + + ! Recall that we are using equi-angular spherical gridding + ! Compute the angle between equiangular cubed sphere projection grid lines. + DO k = 1, icube+1 + gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) + ENDDO + + DO k2=1,icube+1 + DO k1=1,icube+1 + ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) + ENDDO + ENDDO + + DO k2=1,icube + DO k1=1,icube + a1 = ang(k1 , k2 ) + a2 = pi - ang(k1+1, k2 ) + a3 = pi - ang(k1 , k2+1) + a4 = ang(k1+1, k2+1) + ! area = r*r*(-2*pi+sum(interior angles)) + DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 + ENDDO + ENDDO + + !#ifdef DBG + ! Only for debugging - test consistency + dbg1 = 0.0 !DBG + DO k2=1,icube + DO k1=1,icube + dbg1 = dbg1 + DA(k1,k2) !DBG + ENDDO + ENDDO + write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG + !#endif +END SUBROUTINE EquiangularAllAreas + + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereRLLFromABP +! +! Description: +! Determine the lat lon coordinate of a point on a sphere given its +! (alpha,beta,panel) coordinate. +! +! Parameters: +! alpha - Alpha coordinate +! beta - Beta coordinate +! panel - Cubed sphere panel id +! lon (OUT) - Calculated longitude +! lat (OUT) - Calculated latitude +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + REAL (r8), INTENT(IN) :: alpha, beta + INTEGER , INTENT(IN) :: ipanel + REAL (r8), INTENT(OUT) :: lon, lat + ! Local variables + REAL (r8) :: xx, yy, zz, rotate_cube + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + + rotate_cube = 0.0 + ! Convert to cartesian coordinates + CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) + ! Convert back to lat lon + lat = ASIN(zz) + if (xx==0.0.and.yy==0.0) THEN + lon = 0.0 + else + lon = ATAN2(yy, xx) +rotate_cube + IF (lon<0.0) lon=lon+2.0*pi + IF (lon>2.0*pi) lon=lon-2.0*pi + end if +END SUBROUTINE CubedSphereRLLFromABP + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereXYZFromABP +! +! Description: +! Determine the Cartesian coordinate of a point on a sphere given its +! (alpha,beta,panel) coordinate. +! +! Parameters: +! alpha - Alpha coordinate +! beta - Beta coordinate +! panel - Cubed sphere panel id +! xx (OUT) - Calculated x coordinate +! yy (OUT) - Calculated y coordinate +! zz (OUT) - Calculated z coordinate +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + REAL (r8), INTENT(IN) :: alpha, beta + INTEGER , INTENT(IN) :: ipanel + REAL (r8), INTENT(OUT) :: xx, yy, zz + ! Local variables + REAL (r8) :: a1, b1, pm + REAL (r8) :: sx, sy, sz + + ! Convert to Cartesian coordinates + a1 = TAN(alpha) + b1 = TAN(beta) + + sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) + sx = sz * a1 + sy = sz * b1 + ! Panel assignments + IF (ipanel == 6) THEN + yy = sx; xx = -sy; zz = sz + ELSEIF (ipanel == 5) THEN + yy = sx; xx = sy; zz = -sz + ELSEIF (ipanel == 1) THEN + yy = sx; zz = sy; xx = sz + ELSEIF (ipanel == 3) THEN + yy = -sx; zz = sy; xx = -sz + ELSEIF (ipanel == 2) THEN + xx = -sx; zz = sy; yy = sz + ELSEIF (ipanel == 4) THEN + xx = sx; zz = sy; yy = -sz + ELSE + WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' + WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' + STOP + ENDIF +END SUBROUTINE CubedSphereXYZFromABP + + +SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out) + use shr_kind_mod, only: r8 => shr_kind_r8 + integer, intent(in) :: n_in + integer,dimension(n_in), intent(in) :: f_in + integer, intent(out) :: n_out + integer,dimension(n_in), intent(out) :: f_out + ! + ! local work space + ! + integer :: k,i,j + ! + ! remove duplicates in ipanel_tmp + ! + k = 1 + f_out(1) = f_in(1) + outer: do i=2,n_in + do j=1,k + ! if (f_out(j) == f_in(i)) then + if (ABS(f_out(j)-f_in(i))<1.0E-10) then + ! Found a match so start looking again + cycle outer + end if + end do + ! No match found so add it to the output + k = k + 1 + f_out(k) = f_in(i) + end do outer + n_out = k +END SUBROUTINE remove_duplicates_integer + +SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg) + use shr_kind_mod, only: r8 => shr_kind_r8 + integer, intent(in) :: n_in + real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in + real, intent(in) :: tiny + integer, intent(out) :: n_out + real(r8),dimension(n_in), intent(out) :: lon_out,lat_out + logical :: ldbg + ! + ! local work space + ! + integer :: k,i,j + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: pih = 0.50*pi + ! + ! for pole points: make sure the longitudes are identical so that algorithm below works properly + ! + do i=2,n_in + if (abs(lat_in(i)-pih) ' + print *, ' ' + print *, 'REQUIRED ARGUMENTS: ' + print *, ' --target-grid Target grid descriptor in SCRIP format ' + print *, ' --input-topography Input USGS topography on cube sphere ' + print *, ' --output-topography Output topography on target grid ' + print *, ' ' + print *, 'OPTIONAL ARGUMENTS: ' + print *, ' --smoothed-topography Input smoothed topography (for surface ' + print *, ' roughness calculation). If present, ' + print *, ' output will contain estimate of subgrid' + print *, ' surface roughness (SGH). Note that the ' + print *, ' variance in elevation from the 30s to ' + print *, ' 3km grid (SGH30) is also downscaled, ' + print *, ' but does not depend on the smoothing. ' + print *, ' ' + print *, 'DESCRIPTION: ' + print *, 'This code performs rigorous remapping of topography variables on a cubed- ' + print *, 'sphere grid to any target grid. The code is documented in: ' + print *, ' ' + print *, ' Lauritzen, Nair and Ullrich, 2010, J. Comput. Phys. ' + print *, ' ' + print *, 'AUTHOR: ' + print *, ' Peter Hjort Lauritzen (pel@ucar.edu), AMP/CGD/NESL/NCAR ' + print *, ' ' +end subroutine usage diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl b/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl new file mode 100755 index 000000000000..d79fc234bebf --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl @@ -0,0 +1,21 @@ +load "/lcrc/group/e3sm/ac.xie7/Analysis/NCLep/self.ncl" +begin +vars=(/"PHIS","SGH","SGH30","LANDFRAC","LANDM_COSLAT"/) +;; +fil1="final-180-ne30pg2-mod-v3.nc" +;fil2="USGS-gtopo30_ne30np4pg2_16xdel2.c20200108.nc" +;fil3="final-180-ne30pg2.nc" +fil2="USGS-gtopo30_ne30np4pg2_x6t-SGH.c20210614.nc" +fil3="final-180-ne30pg2-v3.nc" +system("rm -r "+fil1) +system("cp -r "+fil3+" "+fil1) +;; +ff1=addfile(fil1,"w") +ff2=addfile(fil2,"r") +;; +do i=0,4 +ff1->$vars(i)$=ff2->$vars(i)$ +end do + + +end diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 b/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 new file mode 100755 index 000000000000..0ffb3c0bfec9 --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 @@ -0,0 +1,900 @@ +Module ogwd_sub +use shr_kind_mod, only: r8 => shr_kind_r8 +!use transform + +contains +!#if 0 +subroutine OAdir(terr,ntarget,ncube,n,nvar_dir,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_cen,lat_cen,lon_terr,lat_terr,area_target,oa_target) +!use shr_kind_mod, only: r8 => shr_kind_r8 +IMPLICIT NONE +integer ,intent(in) :: ncube,ntarget,n,nvar_dir,jall,weights_lgr_index_all(jall) +integer ,intent(in) :: weights_eul_index_all1(jall),& + weights_eul_index_all2(jall),& + weights_eul_index_all3(jall) +real(r8),intent(in) :: weights_all(jall,1),landfrac_target(ntarget) +real(r8),intent(in) :: terr(n) +!real(r8),intent(in) :: lon_cen(ntarget),& +real(r8),intent(inout) :: lon_cen(ntarget),& + lat_cen(ntarget),& + area_target(ntarget) +real(r8),intent(in) :: lon_terr(n),lat_terr(n) +real(r8),intent(out) :: oa_target(ntarget,nvar_dir) +!local +integer :: count,i,ix,iy,ip,ii,ip2,ip3 +real(r8) :: xxterr,yyterr,zzterr,ix2,iy2,xx3,yy3,zz3,ix3,iy3 +real(r8) :: wt,xhds(ntarget),yhds(ntarget),zhds(ntarget),hds(ntarget),OAx_var(ntarget),OAy_var(ntarget),OAz_var(ntarget),OA_var(ntarget) +real(r8) :: xbar(ntarget),ybar(ntarget),zbar(ntarget),lon_bar(ntarget),lat_bar(ntarget) +real(r8) :: rad,theta1 +real(r8) :: OAlon(ntarget),OAlat(ntarget),OArad(ntarget),OAx1,OAy1,OAz1 + +real(r8) :: terr_anom(n),terr_avg(ntarget),weights_ano(jall),area_target_ano(ntarget) + +xhds=0.0_r8 +yhds=0.0_r8 +zhds=0.0_r8 +hds=0.0_r8 + +xbar=0.0_r8 +ybar=0.0_r8 +zbar=0.0_r8 +lon_bar=0.0_r8 +lat_bar=0.0_r8 +OA_var=0.0_r8 +OAx_var=0.0_r8 +OAy_var=0.0_r8 +OAz_var=0.0_r8 + + +!#if 0 +terr_anom=0.0_r8 +terr_avg=0.0_r8 +do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count) + ! convert to 1D indexing of cubed-sphere + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + ! + terr_avg(i)=terr_avg(i)+(wt/area_target(i))*terr(ii) + !terr(ii)*wt!(wt/area_target(i))*terr(ii) +enddo + +do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count) + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix + terr_anom(ii)=terr(ii)-terr_avg(i) +! +enddo +where(terr_anom.le.0) terr_anom=0.0_r8 + +do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count)!,3) + ! + ! convert to 1D indexing of cubed-sphere + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + rad=4.0_r8*atan(1.0_r8)/180.0_r8 + call CubedSphereABPFromRLL(lon_terr(ii)*rad,lat_terr(ii)*rad,ix2,iy2,ip2,.true.) + call CubedSphereXYZFromABP(ix2,iy2,ip2,xxterr,yyterr,zzterr) +!#if 0 + xhds(i)=xhds(i)+xxterr*terr_anom(ii)*wt + yhds(i)=yhds(i)+yyterr*terr_anom(ii)*wt + zhds(i)=zhds(i)+zzterr*terr_anom(ii)*wt + hds(i) =hds(i)+terr_anom(ii)*wt + + !masscenter for every coarse grid + !on Cartesian coord + !looking the h as ro + xbar(i)=xhds(i)/hds(i) + ybar(i)=yhds(i)/hds(i) + zbar(i)=zhds(i)/hds(i) + + call CubedSphereABPFromRLL(lon_cen(i)*rad,lat_cen(i)*rad,& + ix3,iy3,ip3,.true.) + call CubedSphereXYZFromABP(ix3,iy3,ip3,xx3,yy3,zz3) + !under Cartesian, the variability of the scale in the wind + !direction is the sqrt(x^2+y^2+z^2), the scale of the orthogonal + !3 directions + !then it is only a matter of using the original formula + !in the single direction + OA_var(i)=OA_var(i)+wt/area_target(i)& + *((xxterr-xx3)**2+(yyterr-yy3)**2+(zzterr-zz3)**2) + OAx_var(i)=OAx_var(i)+(wt/area_target(i))*(xxterr-xx3)**2 + OAy_var(i)=OAy_var(i)+(wt/area_target(i))*(yyterr-yy3)**2 + OAz_var(i)=OAz_var(i)+(wt/area_target(i))*(zzterr-zz3)**2 + OAx1=(xx3-xbar(i))/sqrt(OAx_var(i))!OA_var(i)) + OAy1=(yy3-ybar(i))/sqrt(OAy_var(i))!OA_var(i)) + OAz1=(zz3-zbar(i))/sqrt(OAz_var(i))!OA_var(i)) + !assuming a small change in lon_cen to lon_bar + !so it does not matter whether lon_cen or lon_bar + !thus we change onto lat-lon grid vector in target gridcell +#if 0 + OArad(i)= OAx1*sin(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& + +OAy1*sin(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& + +OAz1*cos(lat_cen(i)*rad) + OAlat(i)= OAx1*cos(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& + +OAy1*cos(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& + -OAz1*sin(lat_cen(i)*rad) + OAlon(i)=-OAx1*sin(lon_cen(i)*rad)& + +OAy1*cos(lon_cen(i)*rad) +#endif + !all lat_cen must use (90-lat_cen) since we only have + !latitude rather than colatitude + !this is equivalent to using induction formula sin(90-lat)=cos(lat) + !latitude is opposite of colatitude, thus OAlat is negative + OAlat(i)=-(OAx1*sin(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& + +OAy1*sin(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& + -OAz1*cos(lat_cen(i)*rad)) + OAlon(i)= -OAx1*sin(lon_cen(i)*rad)& + +OAy1*cos(lon_cen(i)*rad) +#if 0 + theta1=0. + oa_target(i,1) = OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) + theta1=90. + oa_target(i,2) = OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) + theta1=45. + oa_target(i,3)= OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) + theta1=360.-45. + oa_target(i,4)= OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) +#endif +!#if 0 + !reverse in order to be + !(2,ntarget),OAx,OAy + oa_target(i,1) = OAlon(i) + oa_target(i,2) = OAlat(i) + +!#endif + !landfrac may cause coastal area par to diminish + !oa_target(i,:) = oa_target(i,:)*landfrac_target(i) +enddo + !takeout abnormal values +!#if 0 + where(abs(oa_target)<.001_r8.or.& + abs(oa_target).gt.1e+7) oa_target=0.0_r8 + !where(abs(oa_target).gt.1) oa_target=1.0_r8 + where(oa_target.ne.oa_target) oa_target=0.0_r8 + +!#endif +end subroutine OAdir +!============================================================ +subroutine OAorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_terr,lat_terr,area_target,oa_target) +!use shr_kind_mod, only: r8 => shr_kind_r8 +IMPLICIT NONE +integer ,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) +real(r8),intent(in) :: weights_all(jall,1),terr(n) +real(r8),intent(in) :: landfrac_target(ntarget),lon_terr(n),lat_terr(n),area_target(ntarget) +real(r8),intent(out) :: oa_target(ntarget,4) +!local +real(r8) :: xh(ntarget),yh(ntarget),height(ntarget),modexcoords(ntarget),modeycoords(ntarget),avgx(ntarget),avgy(ntarget),varx(ntarget),vary(ntarget),OAx,OAy,theta1,rad +integer(r8) :: count,i,ix,iy,ip,ii +real(r8) :: wt + + xh=0.0_r8 + yh=0.0_r8 + height=0.0_r8 + modexcoords=0.0_r8 + modeycoords=0.0_r8 + avgx=0.0_r8 + avgy=0.0_r8 + varx=0.0_r8 + vary=0.0_r8 + OAx=0.0_r8 + OAy=0.0_r8 + theta1=0.0_r8 + rad=0.0_r8 + +do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count)!,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + !for OA + avgx(i)=avgx(i)+wt/area_target(i)*lon_terr(ii) + avgy(i)=avgy(i)+wt/area_target(i)*lat_terr(ii) +enddo + + +do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count)!,3) + ! + ! convert to 1D indexing of cubed-sphere + ! + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + !mode for both dim + xh(i)=xh(i)+wt/area_target(i)*lon_terr(ii)*terr(ii) + yh(i)=yh(i)+wt/area_target(i)*lat_terr(ii)*terr(ii) + height(i)=height(i)+wt/area_target(i)*terr(ii) + modexcoords(i)=xh(i)/(height(i))!+1e-14) + modeycoords(i)=yh(i)/(height(i))!+1e-14) + + varx(i)=varx(i)+(wt/area_target(i))*(lon_terr(ii)-avgx(i))**2 + vary(i)=vary(i)+(wt/area_target(i))*(lat_terr(ii)-avgy(i))**2 + !OAx,OAy + OAx=landfrac_target(i)*(avgx(i)-modexcoords(i))/sqrt(varx(i)) + OAy=landfrac_target(i)*(avgy(i)-modeycoords(i))/sqrt(vary(i)) + + rad=4.0*atan(1.0)/180.0 + theta1=0. + oa_target(i,1) = OAx*cos(theta1*rad)+OAy*sin(theta1*rad) + theta1=90. + oa_target(i,2) = OAx*cos(theta1*rad)+OAy*sin(theta1*rad) + theta1=45. + oa_target(i,3)= OAx*cos(theta1*rad)+OAy*sin(theta1*rad) + theta1=360.-45. + oa_target(i,4)= OAx*cos(theta1*rad)+OAy*sin(theta1*rad) + oa_target(i,:)= oa_target(i,:)*landfrac_target(i) +enddo + !takeout abnormal values + where(abs(oa_target)<.001_r8.or.abs(oa_target).gt.1e+7) oa_target=0.0 + where(abs(oa_target).gt.1) oa_target=0.0 + where(oa_target.ne.oa_target) oa_target=0.0 +end subroutine OAorig +!#endif +!=================================== +subroutine OC(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,area_target,sgh_target,terr_target,oc_target) +!use shr_kind_mod, only: r8 => shr_kind_r8 +IMPLICIT NONE +integer ,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) +real(r8),intent(in) :: weights_all(jall,1) +real(r8),intent(in) :: landfrac_target(ntarget),area_target(ntarget),sgh_target(ntarget),terr_target(ntarget),terr(n) +real(r8),intent(out) :: oc_target(ntarget) +!local +integer :: count,i,ix,iy,ip,ii +real(r8) :: wt + + oc_target=0.0_r8 + do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count)!,3) + ! convert to 1D indexing of cubed-sphere + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + oc_target(i) = oc_target(i)+(wt/area_target(i))*((terr_target(i)-terr(ii))**4)/(sgh_target(i)**4) + oc_target(i) = oc_target(i) * landfrac_target(i) + enddo + + where(abs(oc_target)<.001_r8.or.abs(oc_target).gt.1e+7) oc_target=0.0_r8 + where(abs(sgh_target).eq.0.0_r8) oc_target=0.0_r8 + where(oc_target<0.0_r8) oc_target=0.0_r8 +end subroutine OC +!======================== +subroutine OLorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_terr,lat_terr,area_target,sgh_target,target_center_lat,target_center_lon,target_corner_lat_deg,target_corner_lon_deg,ol_target) +!use shr_kind_mod, only: r8 => shr_kind_r8 +IMPLICIT NONE +integer,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) +real(r8),intent(in) :: weights_all(jall,1) +real(r8),intent(in) :: landfrac_target(ntarget),area_target(ntarget),sgh_target(ntarget),terr(n),lon_terr(n),lat_terr(n) +real(r8),intent(in) :: target_center_lat(ntarget),target_center_lon(ntarget),target_corner_lat_deg(4,ntarget),target_corner_lon_deg(4,ntarget) +real(r8),intent(out) :: ol_target(ntarget,4) +!local +integer :: count,i,ix,iy,ip,ii +real(r8) :: wt,terr_if,Nw(4,ntarget),area_target_par(4,ntarget),j + + + ol_target=0.0_r8 + Nw=0.0_r8 + area_target_par=0.0_r8 + + do count=1,jall + i = weights_lgr_index_all(count) + ix = weights_eul_index_all1(count)!,1) + iy = weights_eul_index_all2(count)!,2) + ip = weights_eul_index_all3(count)!,3) + ! convert to 1D indexing of cubed-sphere + ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! + wt = weights_all(count,1) + !determine terr_if + terr_if=0._r8 + if (terr(ii).GT.(1116.2-0.878*sgh_target(i))) terr_if=1. + ! (1): the lower left corner + ! (2): the lower right corner + ! (3): the upper right corner + ! (4): the upper left corner + !OL1 + if (lat_terr(ii) &!(ii)& + .GT.(target_corner_lat_deg(1,i)+target_center_lat(i))/2..and. & + lat_terr(ii) &!(ii)& + .LT.(target_corner_lat_deg(4,i)+target_center_lat(i))/2.) then + Nw(1,i)=Nw(1,i)+wt*terr_if + area_target_par(1,i)=area_target_par(1,i)+wt + endif + + !OL2 + if (lon_terr(ii) &!(ii)& + .GT.(target_corner_lon_deg(1,i)+target_center_lon(i))/2..and. & + lon_terr(ii) &!(ii)& + .LT.(target_corner_lon_deg(3,i)+target_center_lon(i))/2.) then + Nw(2,i)=Nw(2,i)+wt*terr_if + area_target_par(2,i)=area_target_par(2,i)+wt + end if + + + !OL3 + if (lon_terr(ii) &!(ii)& + .LT.target_center_lon(i).and. & + lat_terr(ii) &!(ii)& + .LT.target_center_lat(i).or. & + lon_terr(ii) &!(ii)& + .GT.target_center_lon(i).and. & + lat_terr(ii) &!(ii)& + .GT.target_center_lat(i)) then + Nw(3,i)=Nw(3,i)+wt*terr_if + area_target_par(3,i)=area_target_par(3,i)+wt + end if + + + !OL4 + if (lat_terr(ii) & !(ii)& + .GT.target_center_lat(i).and. & + lon_terr(ii) & !(ii)& + .LT.target_center_lon(i).or. & + lat_terr(ii) & !(ii)& + .LT.target_center_lat(i).and. & + lon_terr(ii) & !(ii)& + .GT.target_center_lon(i)) then + Nw(4,i)=Nw(4,i)+wt*terr_if + area_target_par(4,i)=area_target_par(4,i)+wt + end if + + !Nw(4,i)=Nw(4,i)+wt*terr_if + !area_target_par(4,i)=area_target_par(4,i)+wt + + + + do j=1,4 + ol_target(i,j)=Nw(j,i)/(area_target_par(j,i)+1e-14)!Nt(i)!/2.) + enddo + ol_target(i,:)=ol_target(i,:)*landfrac_target(i) + end do + where(abs(ol_target)<.001_r8.or.abs(ol_target).gt.1e+7) ol_target=0.0_r8 +end subroutine OLorig +!#endif +!===================== +!=================================================================== +!===================== +!#if 0 +subroutine OLgrid(terr,terrx,terry,wt,b,a,n,theta_in,hc,OLout) +!use physconst, only: rh2o,zvir,pi,rearth +!use abortutils +!Xie add +IMPLICIT NONE +integer,intent(in) :: n +real(r8),intent(in) :: hc,wt(n),terr(n),a,b,theta_in!a dy,b dx +real(r8),intent(in) :: terrx(n),terry(n) +real(r8),intent(out) :: OLout +real(r8) :: theta,theta1,theta2,rad,interval +real(r8) :: terr_count(n),terr_whole_count(n),cx(n),c1,c2 +!local +integer :: i +real(r8) :: j + terr_count=0.0_r8 + terr_whole_count=0.0_r8 + c1=0.0_r8 + c2=0.0_r8 + cx=0.0_r8 + !determine an acute theta in the triangle + !or minus 180 equilvalent acute angle + !then turn into radian + rad=4.0_r8*atan(1.0_r8)/180.0_r8 + interval=0.0_r8 + + !initialize + theta1=0.0_r8 + theta2=0.0_r8 + !set inside -360~360 + !this adds robustness of the scheme to different angle + theta1=MOD(theta_in,360._r8) + !set negative axis into 0~360 + if (theta1.ge.-360._r8.and.theta1.lt.0._r8) then + theta1=theta1+360._r8 + endif + !now we have only 0~360 angle + if (theta1.ge. 0._r8.and.theta1.le. 90._r8) then + theta=theta1*rad + theta2=theta1 + else if (theta1.gt. 90._r8.and.theta1.le. 180._r8) then + theta=(180._r8-theta1)*rad + theta2=180._r8-theta1 + else if (theta1.gt. 180._r8.and.theta1.le. 270._r8) then + theta=(theta1-180._r8)*rad + theta2=theta1-180._r8 + !we only use 0~180, so this makes similar to 1st and 2nd quadrant + else if (theta1.gt. 270._r8.and.theta1.le. 360._r8) then + theta=(360._r8-theta1)*rad + theta2=360._r8-theta1 + !we only use 0~180, so this makes similar to 1st and 2nd quadrant + endif + !we use theta2 to judge instead + !theta2=theta1 + !theta1=theta2 + !we restrict the angle in the first and second quadrant + !the third and fourth for OL are similar when theta is + !transformed by minus pi(180) + !two parallel lines are included + !xsin(theta)-ycos(theta)=c1 + !xsin(theta)-ycos(theta)=c2 + !xsin(theta)-ycos(theta)=cx,min(c1,c2) 0) .AND. (j < ncube_reconstruct)) THEN + beta = gp(j) + beta_next = gp(j+1) + ELSEIF (j == -1) THEN + beta = -piq - (gp(3) + piq) + beta_next = -piq - (gp(2) + piq) + ELSEIF (j == 0) THEN + beta = -piq - (gp(2) + piq) + beta_next = -piq + ELSEIF (j == ncube_reconstruct) THEN + beta = piq + beta_next = piq + (piq - gp(ncube_reconstruct-1)) + ELSEIF (j == ncube_reconstruct+1) THEN + beta = piq + (piq - gp(ncube_reconstruct-1)) + beta_next = piq + (piq - gp(ncube_reconstruct-2)) + ENDIF + + DO i = -1, ncube_reconstruct+1 + IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN + alpha = gp(i) + alpha_next = gp(i+1) + ELSEIF (i == -1) THEN + alpha = -piq - (gp(3) + piq) + alpha_next = -piq - (gp(2) + piq) + ELSEIF (i == 0) THEN + alpha = -piq - (gp(2) + piq) + alpha_next = -piq + ELSEIF (i == ncube_reconstruct) THEN + alpha = piq + alpha_next = piq + (piq - gp(ncube_reconstruct-1)) + ELSEIF (i == ncube_reconstruct+1) THEN + alpha = piq + (piq - gp(ncube_reconstruct-1)) + alpha_next = piq + (piq - gp(ncube_reconstruct-2)) + ENDIF + abp_centroid(1,i,j) = & + I_10_ab(alpha_next,beta_next)-I_10_ab(alpha ,beta_next)+& + I_10_ab(alpha ,beta )-I_10_ab(alpha_next,beta ) +! - ASINH(COS(alpha_next) * TAN(beta_next)) & +! + ASINH(COS(alpha_next) * TAN(beta)) & +! + ASINH(COS(alpha) * TAN(beta_next)) & +! - ASINH(COS(alpha) * TAN(beta)) + + abp_centroid(2,i,j) = & + I_01_ab(alpha_next,beta_next)-I_01_ab(alpha ,beta_next)+& + I_01_ab(alpha ,beta )-I_01_ab(alpha_next,beta ) +! - ASINH(TAN(alpha_next) * COS(beta_next)) & +! + ASINH(TAN(alpha_next) * COS(beta)) & +! + ASINH(TAN(alpha) * COS(beta_next)) & +! - ASINH(TAN(alpha) * COS(beta)) + + !ADD PHL START + IF (order>2) THEN + ! TAN(alpha)^2 component + abp_centroid(3,i,j) =& + I_20_ab(alpha_next,beta_next)-I_20_ab(alpha ,beta_next)+& + I_20_ab(alpha ,beta )-I_20_ab(alpha_next,beta ) + + ! TAN(beta)^2 component + abp_centroid(4,i,j) = & + I_02_ab(alpha_next,beta_next)-I_02_ab(alpha ,beta_next)+& + I_02_ab(alpha ,beta )-I_02_ab(alpha_next,beta ) + + ! TAN(alpha) TAN(beta) component + abp_centroid(5,i,j) = & + I_11_ab(alpha_next,beta_next)-I_11_ab(alpha ,beta_next)+& + I_11_ab(alpha ,beta )-I_11_ab(alpha_next,beta ) + ENDIF + !ADD PHL END + ENDDO + ENDDO + +! +! PHL outcommented below +! + ! High order calculations +! IF (order > 2) THEN +! DO k = 1, nlon +! DO i = 1, int_nx(nlat,k)-1 +! IF ((int_itype(i,k) > 4) .AND. (int_np(1,i,k) == 1)) THEN +! abp_centroid(3, int_a(i,k), int_b(i,k)) = & +! abp_centroid(3, int_a(i,k), int_b(i,k)) + int_wt_2a(i,k) +! abp_centroid(4, int_a(i,k), int_b(i,k)) = & +! abp_centroid(4, int_a(i,k), int_b(i,k)) + int_wt_2b(i,k) +! abp_centroid(5, int_a(i,k), int_b(i,k)) = & +! abp_centroid(5, int_a(i,k), int_b(i,k)) + int_wt_2c(i,k) +! ENDIF +! ENDDO +! ENDDO +! ENDIF + + ! Normalize with element areas + DO j = -1, ncube_reconstruct+1 + IF ((j > 0) .AND. (j < ncube_reconstruct)) THEN + beta = gp(j) + beta_next = gp(j+1) + ELSEIF (j == -1) THEN + beta = -piq - (gp(3) + piq) + beta_next = -piq - (gp(2) + piq) + ELSEIF (j == 0) THEN + beta = -piq - (gp(2) + piq) + beta_next = -piq + ELSEIF (j == ncube_reconstruct) THEN + beta = piq + beta_next = piq + (piq - gp(ncube_reconstruct-1)) + ELSEIF (j == ncube_reconstruct+1) THEN + beta = piq + (piq - gp(ncube_reconstruct-1)) + beta_next = piq + (piq - gp(ncube_reconstruct-2)) + ENDIF + DO i = -1, ncube_reconstruct+1 + IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN + alpha = gp(i) + alpha_next = gp(i+1) + ELSEIF (i == -1) THEN + alpha = -piq - (gp(3) + piq) + alpha_next = -piq - (gp(2) + piq) + ELSEIF (i == 0) THEN + alpha = -piq - (gp(2) + piq) + alpha_next = -piq + ELSEIF (i == ncube_reconstruct) THEN + alpha = piq + alpha_next = piq + (piq - gp(ncube_reconstruct-1)) + ELSEIF (i == ncube_reconstruct+1) THEN + alpha = piq + (piq - gp(ncube_reconstruct-1)) + alpha_next = piq + (piq - gp(ncube_reconstruct-2)) + ENDIF + + IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN + area = DAcube(i,j) + ELSE + area = EquiangularElementArea(alpha, alpha_next - alpha, & + beta, beta_next - beta) + ENDIF + + abp_centroid(1,i,j) = abp_centroid(1,i,j) / area + abp_centroid(2,i,j) = abp_centroid(2,i,j) / area + + IF (order > 2) THEN + IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN + abp_centroid(3,i,j) = abp_centroid(3,i,j) / area + abp_centroid(4,i,j) = abp_centroid(4,i,j) / area + abp_centroid(5,i,j) = abp_centroid(5,i,j) / area + ENDIF + ENDIF + ENDDO + ENDDO + + WRITE(*,*) '...Done computing ABP element centroids' + + END SUBROUTINE ComputeABPElementCentroids + +!------------------------------------------------------------------------------ +! FUNCTION EvaluateABPReconstruction +! +! Description: +! Evaluate the sub-grid scale reconstruction at the given point. +! +! Parameters: +! fcubehalo - Array of element values +! recons - Array of reconstruction coefficients +! a - Index of element in alpha direction (1 <= a <= ncube_reconstruct-1) +! b - Index of element in beta direction (1 <= b <= ncube_reconstruct-1) +! p - Panel index of element +! alpha - Alpha coordinate of evaluation point +! beta - Beta coordinate of evaluation point +! order - Order of the reconstruction +! value (OUT) - Result of function evaluation at given point +!------------------------------------------------------------------------------ + SUBROUTINE EvaluateABPReconstruction( & + fcubehalo, recons, a, b, p, alpha, beta, order, value) + IMPLICIT NONE + + ! Dummy variables + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(IN) :: recons + INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p + REAL (KIND=dbl_kind), INTENT(IN) :: alpha, beta + INTEGER (KIND=int_kind), INTENT(IN) :: order + + REAL (KIND=dbl_kind), INTENT(OUT) :: value + + ! Evaluate constant order terms + value = fcubehalo(a,b,p) + + ! Evaluate linear order terms + IF (order > 1) THEN + value = value + recons(1,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) + value = value + recons(2,a,b,p) * (TAN(beta) - abp_centroid(2,a,b)) + ENDIF + + ! Evaluate second order terms + IF (order > 2) THEN + value = value + recons(3,a,b,p) * & + (abp_centroid(1,a,b)**2 - abp_centroid(3,a,b)) + value = value + recons(4,a,b,p) * & + (abp_centroid(2,a,b)**2 - abp_centroid(4,a,b)) + value = value + recons(5,a,b,p) * & + (abp_centroid(1,a,b) * abp_centroid(2,a,b) - & + abp_centroid(5,a,b)) + + value = value + recons(3,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b))**2 + value = value + recons(4,a,b,p) * (TAN(beta) - abp_centroid(2,a,b))**2 + value = value + recons(5,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) & + * (TAN(beta) - abp_centroid(2,a,b)) + ENDIF + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ABPHaloMinMax +! +! Description: +! Calculate the minimum and maximum values of the cell-averaged function +! around the given element. +! +! Parameters: +! fcubehalo - Cell-averages for the cubed sphere +! a - Local element alpha index +! b - Local element beta index +! p - Local element panel index +! min_val (OUT) - Minimum value in the halo +! max_val (OUT) - Maximum value in the halo +! nomiddle - whether to not include the middle cell (index a,b) in the search. +! +! NOTE: Since this routine is not vectorized, it will likely be called MANY times. +! To speed things up, make sure to pass the first argument as the ENTIRE original +! array, not as a subset of it, since repeatedly cutting up that array and creating +! an array temporary (on some compilers) is VERY slow. +! ex: +! CALL APBHaloMinMax(zarg, a, ...) !YES +! CALL ABPHaloMinMax(zarg(-1:ncube_reconstruct+1,-1:ncube_reconstruct+1,:)) !NO -- slow +!------------------------------------------------------------------------------ + SUBROUTINE ABPHaloMinMax(fcubehalo, a, b, p, min_val, max_val, nomiddle) + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p + REAL (KIND=dbl_kind), INTENT(OUT) :: min_val, max_val + LOGICAL, INTENT(IN) :: nomiddle + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, il, jl, inew, jnew + REAL (KIND=dbl_kind) :: value + + min_val = fcubehalo(a,b,p) + max_val = fcubehalo(a,b,p) + value = fcubehalo(a,b,p) + + DO il = a-1,a+1 + DO jl = b-1,b+1 + + i = il + j = jl + + inew = i + jnew = j + + IF (nomiddle .AND. i==a .AND. j==b) CYCLE + + !Interior + IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN + value = fcubehalo(i,j,p) + + ELSE + + + !The next 4.0 regions are cases in which a,b themselves lie in the panel's halo, and the cell's "halo" (in this usage the 8.0 cells surrounding it) might wrap around into another part of the halo. This happens for (a,b) = {(1,:0),(ncube_reconstruct-1,:0),(1,ncube_reconstruct:),(ncube_reconstruct-1,ncube_reconstruct:)} and for the transposes thereof ({(:0,1), etc.}). In these cases (i,j) could lie in the "Corners" where nothing should lie. We correct this by moving i,j to its appropriate position on the "facing" halo, and then the remainder of the routine then moves it onto the correct face. + +101 FORMAT("ERROR cannot find (i,j) = (", I4, ", ", I4, ") for (a,b,p) = ", I4, ",", I4, ",", I4, ")") +102 FORMAT("i,j,p = ", 3I4, " moved to " 2I4, " (CASE ", I1, ")") + !NOTE: we need the general case to be able to properly handle (0,0), (ncube_reconstruct,0), etc. Note that we don't need to bother with (0,0), etc. when a, b lie in the interior, since both sides of the (0,0) cell are already accounted for by this routine. + !LOWER LEFT + IF (i < 1 .AND. j < 1) THEN + IF (a < 1) THEN !(a,b) centered on left halo, cross to lower halo + inew = 1-j + jnew = i + ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to left halo + jnew = 1-i + inew = j + END IF +! WRITE(*,102) i, j, p, inew, jnew, 1 + !LOWER RIGHT + ELSE IF (i > ncube_reconstruct-1 .AND. j < 1) THEN + IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to lower halo + inew = ncube_reconstruct-1+j + jnew = ncube_reconstruct-i + ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to right halo + jnew = 1+(i-ncube_reconstruct) + inew = ncube_reconstruct-j + END IF +! WRITE(*,102) i, j, p, inew, jnew, 2 + !UPPER LEFT + ELSE IF (i < 1 .AND. j > ncube_reconstruct-1) THEN + IF (a < 1) THEN! (a,b) centered on left halo, cross to upper halo + inew = 1-(j-ncube_reconstruct) + jnew = ncube_reconstruct-i + ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to left halo + inew = ncube_reconstruct-j + jnew = ncube_reconstruct-1-i + END IF +! WRITE(*,102) i, j, p, inew, jnew, 3 + !UPPER RIGHT + ELSE IF (i > ncube_reconstruct-1 .AND. j > ncube_reconstruct-1) THEN + IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to upper halo + inew = ncube_reconstruct-1-(ncube_reconstruct-j) + jnew = i + ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to right halo + inew = j + jnew = ncube_reconstruct-1-(ncube_reconstruct-i) + END IF +! WRITE(*,102) i, j, p, inew, jnew, 4 + END IF + + i = inew + j = jnew + + + !Lower halo ("halo" meaning the panel's halo, not the nine-cell halo + IF ((i < 1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN + IF (p == 1) THEN + value = fcubehalo(ncube_reconstruct-1+i,j,4) + ELSEIF (p == 2) THEN + value = fcubehalo(ncube_reconstruct-1+i,j,1) + ELSEIF (p == 3) THEN + value = fcubehalo(ncube_reconstruct-1+i,j,2) + ELSEIF (p == 4) THEN + value = fcubehalo(ncube_reconstruct-1+i,j,3) + ELSEIF (p == 5) THEN + value = fcubehalo(j,1-i,4) + ELSEIF (p == 6) THEN + value = fcubehalo(ncube_reconstruct-j,ncube_reconstruct-1+i,4) + ENDIF + + !Upper halo + ELSEIF ((i > ncube_reconstruct-1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN + IF (p == 1) THEN + value = fcubehalo(i-ncube_reconstruct+1,j,2) + ELSEIF (p == 2) THEN + value = fcubehalo(i-ncube_reconstruct+1,j,3) + ELSEIF (p == 3) THEN + value = fcubehalo(i-ncube_reconstruct+1,j,4) + ELSEIF (p == 4) THEN + value = fcubehalo(i-ncube_reconstruct+1,j,1) + ELSEIF (p == 5) THEN + value = fcubehalo(ncube_reconstruct-j,i-ncube_reconstruct+1,2) + ELSEIF (p == 6) THEN + value = fcubehalo(j,2*ncube_reconstruct-i-1,2) + ENDIF + + !Left halo + ELSEIF ((j < 1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN + IF (p == 1) THEN + value = fcubehalo(i,ncube_reconstruct-1+j,5) + ELSEIF (p == 2) THEN + value = fcubehalo(ncube_reconstruct-1+j,ncube_reconstruct-i,5) + ELSEIF (p == 3) THEN + value = fcubehalo(ncube_reconstruct-i,1-j,5) + ELSEIF (p == 4) THEN + value = fcubehalo(1-j,i,5) + ELSEIF (p == 5) THEN + value = fcubehalo(ncube_reconstruct-i,1-j,3) + ELSEIF (p == 6) THEN + value = fcubehalo(i,ncube_reconstruct-1+j,1) + ENDIF + + !Right halo + ELSEIF ((j > ncube_reconstruct-1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN + IF (p == 1) THEN + value = fcubehalo(i,j-ncube_reconstruct+1,6) + ELSEIF (p == 2) THEN + value = fcubehalo(2*ncube_reconstruct-j-1,i,6) + ELSEIF (p == 3) THEN + value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,6) + ELSEIF (p == 4) THEN + value = fcubehalo(j-ncube_reconstruct+1,ncube_reconstruct-i,6) + ELSEIF (p == 5) THEN + value = fcubehalo(i,j-ncube_reconstruct+1,1) + ELSEIF (p == 6) THEN + value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,3) + ENDIF + + ENDIF + + END IF + min_val = MIN(min_val, value) + max_val = MAX(max_val, value) + ENDDO + ENDDO + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE MonotonizeABPGradient +! +! Description: +! Apply a monotonic filter to the calculated ABP gradient. +! +! Parameters: +! fcubehalo - Scalar field on the cubed sphere to use in reconstruction +! order - Order of the reconstruction +! recons (INOUT) - Array of reconstructed coefficients +! selective - whether to apply a simple form of selective limiting, + !which assumes that if a point is larger/smaller than ALL of its + !surrounding points, that the extremum is physical, and that + !filtering should not be applied to it. +! +! Remarks: +! This monotonizing scheme is based on the monotone scheme for unstructured +! grids of Barth and Jespersen (1989). +!------------------------------------------------------------------------------ + SUBROUTINE MonotonizeABPGradient(fcubehalo, order, recons, selective) + +! USE selective_limiting + + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + LOGICAL, INTENT(IN) :: selective + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, k, m, n, skip + + REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi + REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & + gamma + + ! The first-order piecewise constant scheme is monotone by construction + IF (order == 1) THEN + RETURN + ENDIF + +! +! xxxxx +! +! IF (selective) THEN +! CALL smoothness2D(fcubehalo, gamma, 2) +! WRITE(*,*) 'gamma range: max ', MAXVAL(gamma), " min ", MINVAL(gamma) +! DO i=1,ncube_reconstruct-1 +! WRITE(*,*) gamma(i, i, 3) +! ENDDO +! skip = 0 +! END IF + + + ! Apply monotone limiting + DO k = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + + + IF (selective) THEN + + CALL ABPHaloMinMax(gamma, i, j, k, gamma_min, gamma_max, .FALSE.) + + IF (gamma_max/(gamma_min + tiny) < lammax) THEN + skip = skip + 1 + CYCLE + END IF + + END IF + + CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) + + + ! Initialize the limiter + min_phi = one + + ! For the second-order calculation, the minima and maxima will occur + ! at the corner points of the element + DO m = i, i+1 + DO n = j, j+1 + + ! Evaluate the function at each corner point + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), local_min, local_max, min_phi) + ENDDO + ENDDO + + ! For the third order method, the minima and maxima may occur along + ! the line segments given by du/dx = 0 and du/dy = 0. Also check + ! for the presence of a maxima / minima of the quadratic within + ! the domain. + IF (order == 3) THEN + disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) + + ! Check if the quadratic is minimized within the element + IF (ABS(disc) > tiny) THEN + mx = - recons(5,i,j,k) * recons(2,i,j,k) & + + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) + my = - recons(5,i,j,k) * recons(1,i,j,k) & + + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) + + mx = mx / disc + abp_centroid(1,i,j) + my = my / disc + abp_centroid(2,i,j) + + IF ((mx - TAN(gp(i)) > -tiny) .AND. & + (mx - TAN(gp(i+1)) < tiny) .AND. & + (my - TAN(gp(j)) > -tiny) .AND. & + (my - TAN(gp(j+1)) < tiny) & + ) THEN + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDIF + ENDIF + + ! Check all potential minimizer points along element boundaries + IF (ABS(recons(5,i,j,k)) > tiny) THEN + + ! Left/right edge, intercept with du/dx = 0 + DO m = i, i+1 + my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / recons(5,i,j,k) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + + ! Top/bottom edge, intercept with du/dy = 0 + DO n = j, j+1 + mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Top/bottom edge, intercept with du/dx = 0 + IF (ABS(recons(3,i,j,k)) > tiny) THEN + DO n = j, j+1 + mx = - recons(1,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Left/right edge, intercept with du/dy = 0 + IF (ABS(recons(4,i,j,k)) > tiny) THEN + DO m = i, i+1 + my = - recons(2,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + ENDIF + + IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN + WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' + WRITE (*,*) 'Slope limiter out of range: ', min_phi + STOP + ENDIF + + ! Apply monotone limiter to all reconstruction coefficients + recons(1,i,j,k) = min_phi * recons(1,i,j,k) + recons(2,i,j,k) = min_phi * recons(2,i,j,k) + + IF (order > 2) THEN + recons(3,i,j,k) = min_phi * recons(3,i,j,k) + recons(4,i,j,k) = min_phi * recons(4,i,j,k) + recons(5,i,j,k) = min_phi * recons(5,i,j,k) + ENDIF + ENDDO + ENDDO + ENDDO + + IF (selective) WRITE(*,*) 'skipped ', skip, ' points out of ', 6*(ncube_reconstruct-1)**2 + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE PosDefABPGradient +! +! Description: +! Scale the reconstructions so they are positive definite +! +! Parameters: +! fcubehalo - Scalar field on the cubed sphere to use in reconstruction +! order - Order of the reconstruction +! recons (INOUT) - Array of reconstructed coefficients +! +! Remarks: +! This monotonizing scheme is based on the monotone scheme for unstructured +! grids of Barth and Jespersen (1989), but simpler. This simply finds the +! minimum and then scales the reconstruction so that it is 0. +!------------------------------------------------------------------------------ + SUBROUTINE PosDefABPGradient(fcubehalo, order, recons) + + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, k, m, n + + REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi + REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & + gamma + + ! The first-order piecewise constant scheme is monotone by construction + IF (order == 1) THEN + RETURN + ENDIF + + + ! Apply monotone limiting + DO k = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + + !If the average value in the cell is 0.0, then we should skip + !all of the scaling and just set the reconstruction to 0.0 +! IF (ABS(fcubehalo(i,j,k)) < tiny) THEN +! recons(:,i,j,k) = 0.0 +! CYCLE +! END IF + CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) + + + !This allowance for miniscule negative values appearing around the cell being + !filtered/limited. Before this, negative values would be caught in adjust_limiter + !and would stop the model. Doing this only causes minor negative values; no blowing + !up is observed. The rationale is the same as for the monotone filter, which does + !allow miniscule negative values due to roundoff error --- of the order E-10 --- + !in flux-form methods (and E-17 in the s-L method, indicating that roundoff error + !is more severe in the flux-form method, as we expect since we are often subtracting + !2.0 values which are very close together. + local_min = MIN(0.0,local_min) + local_max = bignum !prevents scaling upward; for positive + !definite limiting we don't care about the upper bound + + ! Initialize the limiter + min_phi = one + + ! For the second-order calculation, the minima and maxima will occur + ! at the corner points of the element + DO m = i, i+1 + DO n = j, j+1 + + ! Evaluate the function at each corner point + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), local_min, local_max, min_phi) + ENDDO + ENDDO + + ! For the third order method, the minima and maxima may occur along + ! the line segments given by du/dx = 0 and du/dy = 0. Also check + ! for the presence of a maxima / minima of the quadratic within + ! the domain. + IF (order == 3) THEN + disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) + + ! Check if the quadratic is minimized within the element + IF (ABS(disc) > tiny) THEN + mx = - recons(5,i,j,k) * recons(2,i,j,k) & + + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) + my = - recons(5,i,j,k) * recons(1,i,j,k) & + + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) + + mx = mx / disc + abp_centroid(1,i,j) + my = my / disc + abp_centroid(2,i,j) + + IF ((mx - TAN(gp(i)) > -tiny) .AND. & + (mx - TAN(gp(i+1)) < tiny) .AND. & + (my - TAN(gp(j)) > -tiny) .AND. & + (my - TAN(gp(j+1)) < tiny) & + ) THEN + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDIF + ENDIF + + ! Check all potential minimizer points along element boundaries + IF (ABS(recons(5,i,j,k)) > tiny) THEN + + ! Left/right edge, intercept with du/dx = 0 + DO m = i, i+1 + my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / recons(5,i,j,k) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + + ! Top/bottom edge, intercept with du/dy = 0 + DO n = j, j+1 + mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Top/bottom edge, intercept with du/dx = 0 + IF (ABS(recons(3,i,j,k)) > tiny) THEN + DO n = j, j+1 + mx = - recons(1,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Left/right edge, intercept with du/dy = 0 + IF (ABS(recons(4,i,j,k)) > tiny) THEN + DO m = i, i+1 + my = - recons(2,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), & + local_min, local_max, min_phi) + ENDDO + ENDIF + ENDIF + + IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN + WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' + WRITE (*,*) 'Slope limiter out of range: ', min_phi + STOP + ENDIF + + ! Apply monotone limiter to all reconstruction coefficients + recons(1,i,j,k) = min_phi * recons(1,i,j,k) + recons(2,i,j,k) = min_phi * recons(2,i,j,k) + + IF (order > 2) THEN + recons(3,i,j,k) = min_phi * recons(3,i,j,k) + recons(4,i,j,k) = min_phi * recons(4,i,j,k) + recons(5,i,j,k) = min_phi * recons(5,i,j,k) + ENDIF + + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE PosDefABPGradient + +!------------------------------------------------------------------------------ +! SUBROUTINE MonotonizeABPGradient_New +! +! Description: +! Apply a monotonic filter to the calculated ABP gradient. +! +! Parameters: +! fcubehalo - Scalar field on the cubed sphere to use in reconstruction +! order - Order of the reconstruction +! recons (INOUT) - Array of reconstructed coefficients +! +! Remarks: +! This monotonizing scheme is similar to the one in MonotonizeABPGradient, +! except the second order derivatives are limited after the first order +! derivatives. +!------------------------------------------------------------------------------ + SUBROUTINE MonotonizeABPGradient_New(fcubehalo, order, recons) + + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, k, m, n + + REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, linval + REAL (KIND=dbl_kind) :: disc, mx, my + + ! The first-order piecewise constant scheme is monotone by construction + IF (order == 1) THEN + RETURN + ENDIF + + ! Apply monotone limiting + DO k = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max, .FALSE.) + + ! Initialize the limiter + min_phi = one + + ! For the second-order calculation, the minima and maxima will occur + ! at the corner points of the element + DO m = i, i+1 + DO n = j, j+1 + + ! Evaluate the function at each corner point, only taking into + ! account the linear component of the reconstruction. + value = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) + + CALL AdjustLimiter( & + value, fcubehalo(i,j,k), local_min, local_max, min_phi) + ENDDO + ENDDO + + ! Apply monotone limiter to all reconstruction coefficients + IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN + WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' + WRITE (*,*) 'Slope limiter out of range: ', min_phi + STOP + ENDIF + + recons(1,i,j,k) = min_phi * recons(1,i,j,k) + recons(2,i,j,k) = min_phi * recons(2,i,j,k) + + ! For the third order method, the minima and maxima may occur along + ! the line segments given by du/dx = 0 and du/dy = 0. Also check + ! for the presence of a maxima / minima of the quadratic within + ! the domain. + IF (order == 3) THEN + ! Reset the limiter + min_phi = one + + ! Calculate discriminant, which we use to determine the absolute + ! minima/maxima of the paraboloid + disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) + + ! Check if the quadratic is minimized within the element + IF (ABS(disc) > tiny) THEN + mx = - recons(5,i,j,k) * recons(2,i,j,k) & + + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) + my = - recons(5,i,j,k) * recons(1,i,j,k) & + + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) + + mx = mx / disc + abp_centroid(1,i,j) + my = my / disc + abp_centroid(2,i,j) + + IF ((mx - TAN(gp(i)) > -tiny) .AND. & + (mx - TAN(gp(i+1)) < tiny) .AND. & + (my - TAN(gp(j)) > -tiny) .AND. & + (my - TAN(gp(j+1)) < tiny) & + ) THEN + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDIF + ENDIF + + ! Check all potential minimizer points along element boundaries + IF (ABS(recons(5,i,j,k)) > tiny) THEN + + ! Left/right edge, intercept with du/dx = 0 + DO m = i, i+1 + my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / recons(5,i,j,k) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDDO + + ! Top/bottom edge, intercept with du/dy = 0 + DO n = j, j+1 + mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Top/bottom edge, intercept with du/dx = 0 + IF (ABS(recons(3,i,j,k)) > tiny) THEN + DO n = j, j+1 + mx = - recons(1,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(n)) - abp_centroid(2,i,j)) + + mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) + + IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDDO + ENDIF + + ! Left/right edge, intercept with du/dy = 0 + IF (ABS(recons(4,i,j,k)) > tiny) THEN + DO m = i, i+1 + my = - recons(2,i,j,k) - recons(5,i,j,k) * & + (TAN(gp(m)) - abp_centroid(1,i,j)) + + my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) + + IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN + CYCLE + ENDIF + + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), ATAN(my), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDDO + ENDIF + + ! For the second-order calculation, the minima and maxima will occur + ! at the corner points of the element + DO m = i, i+1 + DO n = j, j+1 + + ! Evaluate the function at each corner point + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), gp(n), & + order, value) + + linval = & + fcubehalo(i,j,k) & + + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & + + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) + + IF (linval < local_min) THEN + linval = local_min + ENDIF + IF (linval > local_max) THEN + linval = local_max + ENDIF + + CALL AdjustLimiter( & + value, linval, local_min, local_max, min_phi) + ENDDO + ENDDO + + IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN + WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' + WRITE (*,*) 'Slope limiter out of range: ', min_phi + STOP + ENDIF + + WRITE (*,*) '2: ', min_phi + + recons(1,i,j,k) = min_phi * recons(1,i,j,k) + recons(2,i,j,k) = min_phi * recons(2,i,j,k) + recons(3,i,j,k) = min_phi * recons(3,i,j,k) + recons(4,i,j,k) = min_phi * recons(4,i,j,k) + recons(5,i,j,k) = min_phi * recons(5,i,j,k) + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ReconstructABPGradient_NEL +! +! Description: +! Construct a non-equidistant linear reconstruction of the gradient +! within each element on an ABP grid. +! +! Parameters: +! fcubehalo - Scalar field on the ABP grid to use in reconstruction +! recons (OUT) - Array of reconstructed coefficients for total elements +! order - Order of the scheme (2 or 3) +!------------------------------------------------------------------------------ + SUBROUTINE ReconstructABPGradient_NEL(fcubehalo, recons, order) + +! USE CubedSphereTrans +! USE InterpolateCSLL_Utils + + IMPLICIT NONE + + REAL (KIND=dbl_kind), & + DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, p + + REAL (KIND=dbl_kind) :: alpha1, alpha2, beta1, beta2 + REAL (KIND=dbl_kind) :: dx_left, dx_right, top_value, bot_value + + DO p = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) + dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) + + recons(1,i,j,p) = & + (+ fcubehalo(i-1,j,p) * dx_right**2 & + - fcubehalo(i+1,j,p) * dx_left**2 & + - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & + (dx_right * dx_left * (dx_right - dx_left)) + + dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) + dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) + + recons(2,i,j,p) = & + (+ fcubehalo(i,j-1,p) * dx_right**2 & + - fcubehalo(i,j+1,p) * dx_left**2 & + - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & + (dx_right * dx_left * (dx_right - dx_left)) + + IF (order > 2) THEN + dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) + dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) + + recons(3,i,j,p) = & + (+ fcubehalo(i-1,j,p) * dx_right & + - fcubehalo(i+1,j,p) * dx_left & + - fcubehalo(i,j,p) * (dx_right - dx_left)) / & + (dx_right * dx_left * (dx_left - dx_right)) + + dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) + dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) + + recons(4,i,j,p) = & + (+ fcubehalo(i,j-1,p) * dx_right & + - fcubehalo(i,j+1,p) * dx_left & + - fcubehalo(i,j,p) * (dx_right - dx_left)) / & + (dx_right * dx_left * (dx_left - dx_right)) + ENDIF + ENDDO + ENDDO + + IF (order > 2) THEN + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + dx_left = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) + dx_right = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) + + top_value = & + (+ fcubehalo(i-1,j+1,p) * dx_right**2 & + - fcubehalo(i+1,j+1,p) * dx_left**2 & + - fcubehalo(i,j+1,p) * (dx_right**2 - dx_left**2)) / & + (dx_right * dx_left * (dx_right - dx_left)) + + dx_left = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) + dx_right = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) + + bot_value = & + (+ fcubehalo(i-1,j-1,p) * dx_right**2 & + - fcubehalo(i+1,j-1,p) * dx_left**2 & + - fcubehalo(i,j-1,p) * (dx_right**2 - dx_left**2)) / & + (dx_right * dx_left * (dx_right - dx_left)) + + dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) + dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) + + recons(5,i,j,p) = & + (+ bot_value * dx_right**2 & + - top_value * dx_left**2 & + - recons(1,i,j,p) * (dx_right**2 - dx_left**2)) / & + (dx_right * dx_left * (dx_right - dx_left)) + + ENDDO + ENDDO + ENDIF + ENDDO + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ReconstructABPGradient_NEP +! +! Description: +! Construct a non-equidistant parabolic reconstruction of the gradient +! within each element on an ABP grid. +! +! Parameters: +! fcubehalo - Scalar field on the ABP grid to use in reconstruction +! recons (OUT) - Array of reconstructed coefficients for total elements +! order - Order of the scheme (2 or 3) +!------------------------------------------------------------------------------ + SUBROUTINE ReconstructABPGradient_NEP(fcubehalo, recons, order) + + +! USE CubedSphereTrans +! USE InterpolateCSLL_Utils + + IMPLICIT NONE + + REAL (KIND=dbl_kind), & + DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, p + + REAL (KIND=dbl_kind) :: x1, x2, x4, x5, y1, y2, y3, y4, y5 + + REAL (KIND=dbl_kind), DIMENSION(5) :: t, pa, denom + + DO p = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + ! X-direction reconstruction + x1 = abp_centroid(1,i-2,j) - abp_centroid(1,i,j) + x2 = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) + x4 = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) + x5 = abp_centroid(1,i+2,j) - abp_centroid(1,i,j) + + !IF (i == 1) THEN + ! x1 = piq + !ELSEIF (i == ncube_reconstruct-1) THEN + ! x5 = -piq + !ENDIF + + y1 = fcubehalo(i-2,j,p) + y2 = fcubehalo(i-1,j,p) + y3 = fcubehalo(i,j,p) + y4 = fcubehalo(i+1,j,p) + y5 = fcubehalo(i+2,j,p) + + denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 + denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 + denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 + denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 + + t(1) = x5 * x4 * x2 + t(2) = x5 * x4 * x1 + t(4) = x5 * x2 * x1 + t(5) = x4 * x2 * x1 + t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) + + pa(1) = x2 * x4 + x2 * x5 + x4 * x5 + pa(2) = x1 * x4 + x1 * x5 + x4 * x5 + pa(4) = x1 * x2 + x1 * x5 + x2 * x5 + pa(5) = x1 * x2 + x1 * x4 + x2 * x4 + pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) + + recons(1,i,j,p) = & + + y1 * t(1) / denom(1) & + + y2 * t(2) / denom(2) & + - y3 * t(3) & + + y4 * t(4) / denom(4) & + + y5 * t(5) / denom(5) + + IF (order > 2) THEN + recons(3,i,j,p) = & + - y1 * pa(1) / denom(1) & + - y2 * pa(2) / denom(2) & + + y3 * pa(3) & + - y4 * pa(4) / denom(4) & + - y5 * pa(5) / denom(5) + ENDIF + + ! Y-direction reconstruction + x1 = abp_centroid(2,i,j-2) - abp_centroid(2,i,j) + x2 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) + x4 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) + x5 = abp_centroid(2,i,j+2) - abp_centroid(2,i,j) + + !IF (j == 1) THEN + ! x1 = piq + !ELSEIF (j == ncube_reconstruct-1) THEN + ! x5 = -piq + !ENDIF + + y1 = fcubehalo(i,j-2,p) + y2 = fcubehalo(i,j-1,p) + y3 = fcubehalo(i,j,p) + y4 = fcubehalo(i,j+1,p) + y5 = fcubehalo(i,j+2,p) + + denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 + denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 + denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 + denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 + + t(1) = x5 * x4 * x2 + t(2) = x5 * x4 * x1 + t(4) = x5 * x2 * x1 + t(5) = x4 * x2 * x1 + t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) + + pa(1) = x2 * x4 + x2 * x5 + x4 * x5 + pa(2) = x1 * x4 + x1 * x5 + x4 * x5 + pa(4) = x1 * x2 + x1 * x5 + x2 * x5 + pa(5) = x1 * x2 + x1 * x4 + x2 * x4 + pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) + + recons(2,i,j,p) = & + + y1 * t(1) / denom(1) & + + y2 * t(2) / denom(2) & + - y3 * t(3) & + + y4 * t(4) / denom(4) & + + y5 * t(5) / denom(5) + + IF (order > 2) THEN + recons(4,i,j,p) = & + - y1 * pa(1) / denom(1) & + - y2 * pa(2) / denom(2) & + + y3 * pa(3) & + - y4 * pa(4) / denom(4) & + - y5 * pa(5) / denom(5) + recons(5,i,j,p) = 0.0 + ENDIF + + ENDDO + ENDDO + IF (order > 2) THEN + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + x1 = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) + x2 = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) + + y2 = (+ fcubehalo(i-1,j+1,p) * x2**2 & + - fcubehalo(i+1,j+1,p) * x1**2 & + - fcubehalo(i,j+1,p) * (x2**2 - x1**2)) / & + (x2 * x1 * (x2 - x1)) + + x1 = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) + x2 = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) + + y1 = (+ fcubehalo(i-1,j-1,p) * x2**2 & + - fcubehalo(i+1,j-1,p) * x1**2 & + - fcubehalo(i,j-1,p) * (x2**2 - x1**2)) / & + (x2 * x1 * (x2 - x1)) + + x1 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) + x2 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) + + recons(5,i,j,p) = & + (+ y1 * x2**2 & + - y2 * x1**2 & + - recons(1,i,j,p) * (x2**2 - x1**2)) / & + (x2 * x1 * (x2 - x1)) + + ENDDO + ENDDO + ENDIF + ENDDO + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ReconstructABPGradient_PLM +! +! Description: +! Construct a piecewise linear reconstruction of the gradient within +! each element on an ABP grid. +! +! Parameters: +! fcubehalo - Scalar field on the ABP grid to use in reconstruction +! recons (OUT) - Array of reconstructed coefficients for total elements +! order - Order of the scheme (2 or 3) +!------------------------------------------------------------------------------ + SUBROUTINE ReconstructABPGradient_PLM(fcubehalo, recons, order) + +! USE CubedSphereTrans +! USE InterpolateCSLL_Utils + + IMPLICIT NONE + + REAL (KIND=dbl_kind), & + DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, p + + REAL (KIND=dbl_kind) :: width + + ! ABP width between elements + width = pih / DBLE(ncube_reconstruct-1) + + DO p = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + ! df/dx + recons(1,i,j,p) = (fcubehalo(i+1,j,p) - fcubehalo(i-1,j,p)) / & + (2.0 * width) + + ! df/dy + recons(2,i,j,p) = (fcubehalo(i,j+1,p) - fcubehalo(i,j-1,p)) / & + (2.0 * width) + + ! Stretching + recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) + recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) + + ! Third order scheme + IF (order > 2) THEN + ! d^2f/dx^2 + recons(3,i,j,p) = & + (fcubehalo(i+1,j,p) - 2.0 * fcubehalo(i,j,p) & + + fcubehalo(i-1,j,p)) / (width * width) + + ! d^2f/dy^2 + recons(4,i,j,p) = & + (fcubehalo(i,j+1,p) - 2.0 * fcubehalo(i,j,p) & + + fcubehalo(i,j-1,p)) / (width * width) + + ! d^2f/dxdy + recons(5,i,j,p) = & + (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & + - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & + ) / (4.0 * width * width) + + ! Stretching + recons(3,i,j,p) = & + (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & + + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 + + recons(4,i,j,p) = & + (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & + + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 + + recons(5,i,j,p) = recons(5,i,j,p) / & + ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) + + ! Scaling + recons(3,i,j,p) = 0.5 * recons(3,i,j,p) + recons(4,i,j,p) = 0.5 * recons(4,i,j,p) + + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ReconstructABPGradient_PPM +! +! Description: +! Construct a piecewise parabolic reconstruction of the gradient within +! each element on an ABP grid. +! +! Parameters: +! fcubehalo - Scalar field on the ABP grid to use in reconstruction +! recons (OUT) - Array of reconstructed coefficients for total elements +! order - Order of the scheme (2 or 3) +!------------------------------------------------------------------------------ + SUBROUTINE ReconstructABPGradient_PPM(fcubehalo, recons, order) + + +! USE CubedSphereTrans +! USE InterpolateCSLL_Utils + + IMPLICIT NONE + + REAL (KIND=dbl_kind), & + DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, p + + REAL (KIND=dbl_kind) :: width + + ! ABP width between elements + width = pih / DBLE(ncube_reconstruct-1) + + DO p = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + ! df/dalfa + recons(1,i,j,p) = & + (+ fcubehalo(i+2,j,p) - 8.0 * fcubehalo(i+1,j,p) & + + 8.0 * fcubehalo(i-1,j,p) - fcubehalo(i-2,j,p)) / & + (- 12.0 * width) + + ! df/dbeta + recons(2,i,j,p) = & + (+ fcubehalo(i,j+2,p) - 8.0 * fcubehalo(i,j+1,p) & + + 8.0 * fcubehalo(i,j-1,p) - fcubehalo(i,j-2,p)) / & + (- 12.0 * width) + + ! Stretching + recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) + recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) + + ! Third order scheme + IF (order > 2) THEN + ! d^2f/dx^2 + recons(3,i,j,p) = (- fcubehalo(i+2,j,p) & + + 16_dbl_kind * fcubehalo(i+1,j,p) & + - 30_dbl_kind * fcubehalo(i,j,p) & + + 16_dbl_kind * fcubehalo(i-1,j,p) & + - fcubehalo(i-2,j,p) & + ) / (12_dbl_kind * width**2) + + ! d^2f/dy^2 + recons(4,i,j,p) = (- fcubehalo(i,j+2,p) & + + 16_dbl_kind * fcubehalo(i,j+1,p) & + - 30_dbl_kind * fcubehalo(i,j,p) & + + 16_dbl_kind * fcubehalo(i,j-1,p) & + - fcubehalo(i,j-2,p) & + ) / (12_dbl_kind * width**2) + + ! d^2f/dxdy + recons(5,i,j,p) = & + (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & + - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & + ) / (4.0 * width * width) + + ! Stretching + recons(3,i,j,p) = & + (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & + + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 + + recons(4,i,j,p) = & + (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & + + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 + + recons(5,i,j,p) = recons(5,i,j,p) / & + ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) + + ! Scaling + recons(3,i,j,p) = 0.5 * recons(3,i,j,p) + recons(4,i,j,p) = 0.5 * recons(4,i,j,p) + ENDIF + ENDDO + ENDDO + ENDDO + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE ReconstructABPGradient +! +! Description: +! Compute the reconstructed gradient in gnomonic coordinates for each +! ABP element. +! +! Parameters: +! fcube - Scalar field on the cubed sphere to use in reconstruction +! halomethod - Method for computing halo elements +! (0) Piecewise constant +! (1) Piecewise linear +! (3) Piecewise cubic +! recons_method - Method for computing the sub-grid scale gradient +! (0) Non-equidistant linear reconstruction +! (1) Non-equidistant parabolic reconstruction +! (2) Piecewise linear reconstruction with stretching +! (3) Piecewise parabolic reconstruction with stretching +! order - Order of the method being applied +! kmono - Apply monotone limiting (1) or not (0) +! recons (INOUT) - Array of reconstructed coefficients +!------------------------------------------------------------------------------ + SUBROUTINE ReconstructABPGradient( & + fcube, halomethod, recons_method, order, kmono, recons, kpd, kscheme) + +! USE InterpolateCSLL_Utils + + IMPLICIT NONE + + REAL (KIND=dbl_kind), & + DIMENSION(1:ncube_reconstruct-1, 1:ncube_reconstruct-1, 6), INTENT(IN) :: fcube + + INTEGER (KIND=int_kind), INTENT(IN) :: halomethod, recons_method + INTEGER (KIND=int_kind), INTENT(IN) :: order, kmono, kpd, kscheme + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, p + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: fcubehalo + + ! Report status + WRITE (*,*) '...Performing sub-grid scale reconstruction on ABP grid' + + ! Compute element haloes + WRITE(*,*) "fill cubed-sphere halo for reconstruction" + DO p = 1, 6 + IF (halomethod == 0) THEN + CALL CubedSphereFillHalo(fcube, fcubehalo, p, ncube_reconstruct, 2) + + ELSEIF (halomethod == 1) THEN + CALL CubedSphereFillHalo_Linear(fcube, fcubehalo, p, ncube_reconstruct) + + ELSEIF (halomethod == 3) THEN + !halomethod is always 3 in the standard CSLAM setup + CALL CubedSphereFillHalo_Cubic(fcube, fcubehalo, p, ncube_reconstruct) + ELSE + WRITE (*,*) 'Fatal Error: In ReconstructABPGradient' + WRITE (*,*) 'Invalid halo method: ', halomethod + WRITE (*,*) 'Halo method must be 0, 1 or 3.' + STOP + ENDIF + ENDDO + + ! Nonequidistant linear reconstruction + IF (recons_method == 1) THEN + CALL ReconstructABPGradient_NEL(fcubehalo, recons, order) + + ! Nonequidistant parabolic reconstruction (JCP paper) + ELSEIF (recons_method == 2) THEN + WRITE(*,*) "Nonequidistant parabolic reconstruction" + CALL ReconstructABPGradient_NEP(fcubehalo, recons, order) + + ! Piecewise linear reconstruction with rotation + ELSEIF (recons_method == 3) THEN + CALL ReconstructABPGradient_PLM(fcubehalo, recons, order) + + ! Piecewise parabolic reconstruction with rotation + ELSEIF (recons_method == 4) THEN + CALL ReconstructABPGradient_PPM(fcubehalo, recons, order) + + ELSE + WRITE(*,*) 'Fatal Error: In ReconstructABPGradient' + WRITE(*,*) 'Specified recons_method out of range. Given: ', recons_method + WRITE(*,*) 'Valid values: 1, 2, 3, 4' + STOP + ENDIF + + ! Apply monotone filtering + SELECT CASE (kmono) + CASE (0) !Do nothing + WRITE(*,*) "no filter applied to the reconstruction" + CASE (1) + + !Simplest filter: just scales the recon so it's extreme value + !is no bigger than the original values of this point and its neighbors + CALL MonotonizeABPGradient(fcubehalo, order, recons, .FALSE.) + + CASE (2) + + !Applies a more sophisticated Van Leer limiter (or, to be consistent, a filter) + CALL VanLeerLimit(fcubehalo, order, recons) + + CASE (3) + + !Applies a selective filter + CALL MonotonizeABPGradient(fcubehalo, order, recons, .TRUE.) + + CASE (4) + + !A filter that filters the linear part first + CALL MonotonizeABPGradient_New(fcubehalo, order, recons) + + CASE DEFAULT + WRITE(*,*) "Limiter kmono = ", kmono, " does not exist." + STOP 1201 + + END SELECT + + !Apply positive-definite filtering, if desired. This should + !ONLY be applied to the S-L method, since the flux-form + !method needs something different done. (In particular, using + !positive-definite reconstructions does not ensure that a flux- + !form scheme is positive definite, since we could get negatives + !when subtracting the resulting fluxes.) + !HOWEVER...we will allow this to be enabled, for testing purposes + IF ( (kpd > 0 .AND. kscheme == 2) .OR. (kpd == 2 .AND. kscheme == 4) ) THEN + WRITE(*,*) "applying positive deifnite constraint" + CALL PosDefABPGradient(fcubehalo, order, recons) + END IF + + + END SUBROUTINE + + + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! SUBROUTINE AdjustLimiter +! +! Description: +! Adjust the slope limiter based on new point values. +! +! Parameters: +! value - Point value +! element_value - Value at the center of the element +! local_max - Local maximum value of the function (from neighbours) +! local_min - Local minimum value of the function (to neighbours) +! min_phi (INOUT) - Slope limiter +!------------------------------------------------------------------------------ + SUBROUTINE AdjustLimiter(value, element_value, local_min, local_max, min_phi) + + IMPLICIT NONE + + REAL (KIND=dbl_kind), INTENT(IN) :: value, element_value + REAL (KIND=dbl_kind), INTENT(IN) :: local_min, local_max + REAL (KIND=dbl_kind), INTENT(INOUT) :: min_phi + + ! Local variables + REAL (KIND=dbl_kind) :: phi = 0.0 + + IF ((local_min > element_value ) .OR. (local_max < element_value )) THEN + WRITE (*,*) 'Fatal Error: In AdjustLimiter' + WRITE (*,*) 'Local min: ', local_min, ' max: ', local_max + WRITE (*,*) 'Elemn: ', element_value + STOP + ENDIF + + ! Check against the minimum bound on the reconstruction + IF (value - element_value > tiny * value) THEN + phi = (local_max - element_value) / & + (value - element_value) + + min_phi = MIN(min_phi, phi) + + ! Check against the maximum bound on the reconstruction + ELSEIF (value - element_value < -tiny * value) THEN + phi = (local_min - element_value) / & + (value - element_value) + + min_phi = MIN(min_phi, phi) + + ENDIF + + IF (min_phi < 0.0) THEN + WRITE (*,*) 'Fatal Error: In AdjustLimiter' + WRITE (*,*) 'Min_Phi: ', min_phi + WRITE (*,*) 'Phi: ', phi + WRITE (*,*) 'Value: ', value + WRITE (*,*) 'Elemn: ', element_value + WRITE (*,*) 'Val-E: ', value - element_value + STOP + ENDIF + + END SUBROUTINE + +!------------------------------------------------------------------------------ +! SUBROUTINE VanLeerLimit +! +! Description: +! Apply a 2D Van Leer-type limiter to a reconstruction. This acts ONLY +! on the linear part of the reconstruction , if any. If passed a PCoM +! reconstruction, this just returns without altering the recon. +! +! Parameters: +! fcubehalo - Scalar field on the cubed sphere to use in reconstruction +! order - Order of the reconstruction +! recons (INOUT) - Array of reconstructed coefficients +! +! Remarks: +! The Van Leer Limiter described here is given on pages 328--329 +! of Dukowicz and Baumgardner (2000). There are no guarantees +! on what it will do to PPM. +!------------------------------------------------------------------------------ + SUBROUTINE VanLeerLimit(fcubehalo, order, recons) + + + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & + INTENT(IN) :: fcubehalo + + INTEGER (KIND=int_kind), INTENT(IN) :: order + + REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons + + ! Local variables + INTEGER (KIND=int_kind) :: i, j, k, m, n + + REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, & + recon_min, recon_max + + ! The first-order piecewise constant scheme is monotone by construction + IF (order == 1) THEN + RETURN + ENDIF + + ! Apply monotone limiting + DO k = 1, 6 + DO j = 1, ncube_reconstruct-1 + DO i = 1, ncube_reconstruct-1 + CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) + + ! Initialize the limiter + min_phi = one + + ! For the second-order calculation, the minima and maxima will occur + ! at the corner points of the element. For the Van Leer limiter, we + !wish to find BOTH of the reconstruction extrema. + recon_min = bignum + recon_max = -bignum + + DO m = i, i+1 + DO n = j, j+1 + + ! Evaluate the function at each corner point + CALL EvaluateABPReconstruction( & + fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) + recon_min = MIN(recon_min, value) + recon_max = MAX(recon_max, value) + + ENDDO + ENDDO + + !This is equation 27 in Dukowicz and Baumgardner 2000 + min_phi = MIN(one, MAX(0.0, (local_min - fcubehalo(i,j,k))/(recon_min - fcubehalo(i,j,k))), & + MAX(0.0, (local_max - fcubehalo(i,j,k))/(recon_max - fcubehalo(i,j,k))) ) + + IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN + WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' + WRITE (*,*) 'Slope limiter out of range: ', min_phi + STOP + ENDIF + + ! Apply monotone limiter to all reconstruction coefficients + recons(1,i,j,k) = min_phi * recons(1,i,j,k) + recons(2,i,j,k) = min_phi * recons(2,i,j,k) + + END DO + END DO + END DO + + + + + END SUBROUTINE VanLeerLimit + + !------------------------------------------------------------------------------ + ! SUBROUTINE EquiangularElementArea + ! + ! Description: + ! Compute the area of a single equiangular cubed sphere grid cell. + ! + ! Parameters: + ! alpha - Alpha coordinate of lower-left corner of grid cell + ! da - Delta alpha + ! beta - Beta coordinate of lower-left corner of grid cell + ! db - Delta beta + !------------------------------------------------------------------------------ + REAL(KIND=dbl_kind) FUNCTION EquiangularElementArea(alpha, da, beta, db) + + IMPLICIT NONE + +! REAL (kind=dbl_kind) :: EquiangularElementArea + REAL (kind=dbl_kind) :: alpha, da, beta, db + REAL (kind=dbl_kind) :: a1, a2, a3, a4 + + ! Calculate interior grid angles + a1 = EquiangularGridAngle(alpha , beta ) + a2 = pi - EquiangularGridAngle(alpha+da, beta ) + a3 = pi - EquiangularGridAngle(alpha , beta+db) + a4 = EquiangularGridAngle(alpha+da, beta+db) + + ! Area = r*r*(-2*pi+sum(interior angles)) + EquiangularElementArea = -pi2 + a1 + a2 + a3 + a4 + + END FUNCTION EquiangularElementArea + + !------------------------------------------------------------------------------ + ! FUNCTION EquiangularGridAngle + ! + ! Description: + ! Compute the angle between equiangular cubed sphere projection grid lines. + ! + ! Parameters: + ! alpha - Alpha coordinate of evaluation point + ! beta - Beta coordinate of evaluation point + !------------------------------------------------------------------------------ + REAL(KIND=dbl_kind) FUNCTION EquiangularGridAngle(alpha, beta) + IMPLICIT NONE + REAL (kind=dbl_kind) :: alpha, beta + EquiangularGridAngle = ACOS(-SIN(alpha) * SIN(beta)) + END FUNCTION EquiangularGridAngle + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereFillHalo +! +! Description: +! Recompute the cubed sphere data storage array, with the addition of a +! halo region around the specified panel. +! +! Parameters: +! parg - Current panel values +! zarg (OUT) - Calculated panel values with halo/ghost region +! np - Panel number +! ncube - Dimension of the cubed sphere (# of grid lines) +! nhalo - Number of halo/ghost elements around each panel +!------------------------------------------------------------------------------ + SUBROUTINE CubedSphereFillHalo(parg, zarg, np, ncube, nhalo) + + IMPLICIT NONE + + REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg + + REAL (KIND=dbl_kind), & + DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & + INTENT(OUT) :: zarg + + INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube,nhalo + + ! Local variables + INTEGER (KIND=int_kind) :: jh,jhy + + !zarg = 0.0 !DBG + zarg(1:ncube-1,1:ncube-1,np) = parg(1:ncube-1,1:ncube-1,np) + + zarg(1-nhalo:0,1-nhalo:0,np) = 0.0 + zarg(1-nhalo:0,ncube:ncube+nhalo-1,np) = 0.0 + zarg(ncube:ncube+nhalo-1,1-nhalo:0,np) = 0.0 + zarg(ncube:ncube+nhalo-1,ncube:ncube+nhalo-1,np) = 0.0 + + ! Equatorial panels + IF (np==1) THEN + DO jh=1,nhalo + zarg(ncube+jh-1,1:ncube-1 ,1) = parg(jh ,1:ncube-1 ,2) !exchange right + zarg(1-jh ,1:ncube-1 ,1) = parg(ncube-jh ,1:ncube-1 ,4) !exchange left + zarg(1:ncube-1 ,1-jh ,1) = parg(1:ncube-1 ,ncube-jh ,5) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,1) = parg(1:ncube-1 ,jh ,6) !exchange over + ENDDO + + ELSE IF (np==2) THEN + DO jh=1,nhalo + zarg(1-jh ,1:ncube-1 ,2) = parg(ncube-jh,1:ncube-1 ,1) !exchange left + zarg(ncube+jh-1,1:ncube-1 ,2) = parg(jh ,1:ncube-1 ,3) !exchange right + zarg(1:ncube-1 ,1-jh ,2) = parg(ncube-jh,ncube-1:1:-1,5) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,2) = parg(ncube-jh,1:ncube-1 ,6) !exchange over + ENDDO + + ELSE IF (np==3) THEN + DO jh=1,nhalo + zarg(ncube+jh-1,1:ncube-1 ,3) = parg(jh ,1:ncube-1,4) !exchange right + zarg(1-jh ,1:ncube-1 ,3) = parg(ncube-jh ,1:ncube-1,2) !exchange left + zarg(1:ncube-1 ,1-jh ,3) = parg(ncube-1:1:-1,jh ,5) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,3) = parg(ncube-1:1:-1,ncube-jh ,6) !exchange over + ENDDO + + ELSE IF (np==4) THEN + DO jh=1,nhalo + zarg(1-jh ,1:ncube-1 ,4) = parg(ncube-jh,1:ncube-1 ,3) !exchange left + zarg(ncube+jh-1,1:ncube-1 ,4) = parg(jh ,1:ncube-1 ,1) !exchange right + zarg(1:ncube-1 ,1-jh ,4) = parg(jh ,1:ncube-1 ,5) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,4) = parg(jh ,ncube-1:1:-1,6) !exchange over + ENDDO + + ! Bottom panel + ELSE IF (np==5) THEN + DO jh=1,nhalo + zarg(1-jh ,1:ncube-1 ,5) = parg(1:ncube-1 ,jh ,4) !exchange left + zarg(ncube+jh-1,1:ncube-1 ,5) = parg(ncube-1:1:-1,jh ,2) !exchange right + zarg(1:ncube-1 ,1-jh ,5) = parg(ncube-1:1:-1,jh ,3) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,5) = parg(1:ncube-1 ,jh ,1) !exchange over + ENDDO + + ! Top panel + ELSE IF (np==6) THEN + DO jh=1,nhalo + zarg(1-jh ,1:ncube-1 ,6) = parg(ncube-1:1:-1,ncube-jh,4) !exchange left + zarg(ncube+jh-1,1:ncube-1 ,6) = parg(1:ncube-1 ,ncube-jh,2) !exchange right + zarg(1:ncube-1 ,1-jh ,6) = parg(1:ncube-1 ,ncube-jh,1) !exchange below + zarg(1:ncube-1 ,ncube+jh-1,6) = parg(ncube-1:1:-1,ncube-jh,3) !exchange over + ENDDO + + ELSE + WRITE (*,*) 'Fatal error: In CubedSphereFillHalo' + WRITE (*,*) 'Invalid panel id ', np + STOP + ENDIF + + END SUBROUTINE CubedSphereFillHalo + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereFillHalo_Linear +! +! Description: +! Recompute the cubed sphere data storage array, with the addition of a +! 2-element halo region around the specified panel. Use linear order +! interpolation to translate between panels. +! +! Parameters: +! parg - Current panel values +! zarg (OUT) - Calculated panel values with halo/ghost region +! np - Panel number +! ncube - Dimension of the cubed sphere (# of grid lines) +!------------------------------------------------------------------------------ + SUBROUTINE CubedSphereFillHalo_Linear(parg, zarg, np, ncube) + +! USE CubedSphereTrans ! Cubed sphere transforms + + IMPLICIT NONE + + INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 + + REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg + + REAL (KIND=dbl_kind), & + DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & + INTENT(OUT) :: zarg + + INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube + + ! Local variables + INTEGER (KIND=int_kind) :: ii, iref, jj, ipanel, imin, imax + REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta + + REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha + REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha + + REAL (KIND=dbl_kind), & + DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg + + ! Use 0.0 order interpolation to begin + CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) + + zarg(:,:,np) = yarg(:,:,np) + + ! Calculate the overlapping alpha coordinates + width = pih / DBLE(ncube-1) + + DO jj = 1, nhalo + DO ii = 0, ncube + prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq + beta = - width * (DBLE(jj-1) + 0.5) - piq + + CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & + newalpha(ii,jj), newbeta) + ENDDO + ENDDO + + ! Now apply linear interpolation to obtain edge components + DO jj = 1, nhalo + ! Reset the reference index + iref = 2 + + ! Interpolation can be applied to more elements after first band + IF (jj == 1) THEN + imin = 1 + imax = ncube-1 + ELSE + imin = 0 + imax = ncube + ENDIF + + ! Apply linear interpolation + DO ii = imin, imax + DO WHILE ((iref .NE. ncube-1) .AND. & + (newalpha(ii,jj) > prealpha(iref,jj))) + iref = iref + 1 + ENDDO + + IF ((newalpha(ii,jj) > prealpha(iref-1,jj)) .AND. & + (newalpha(ii,jj) .LE. prealpha(iref ,jj))) & + THEN + a = (newalpha(ii,jj) - prealpha(iref-1,jj)) / & + (prealpha(iref,jj) - prealpha(iref-1,jj)) + + IF ((a < 0.0) .OR. (a > one)) THEN + WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' + WRITE (*,*) 'a out of bounds' + STOP + ENDIF + + ! Bottom edge of panel + zarg(ii, 1-jj, np) = & + (one - a) * yarg(iref-1, 1-jj, np) + & + a * yarg(iref, 1-jj, np) + + ! Left edge of panel + zarg(1-jj, ii, np) = & + (one - a) * yarg(1-jj, iref-1, np) + & + a * yarg(1-jj, iref, np) + + ! Top edge of panel + zarg(ii, ncube+jj-1, np) = & + (one - a) * yarg(iref-1, ncube+jj-1, np) + & + a * yarg(iref, ncube+jj-1, np) + + ! Right edge of panel + zarg(ncube+jj-1, ii, np) = & + (one - a) * yarg(ncube+jj-1, iref-1, np) + & + a * yarg(ncube+jj-1, iref, np) + + ELSE + WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' + WRITE (*,*) 'ii: ', ii, ' jj: ', jj + WRITE (*,*) 'newalpha: ', newalpha(ii,jj) + WRITE (*,*) 'prealpha: ', prealpha(iref-1,jj), '-', prealpha(iref,jj) + STOP + ENDIF + ENDDO + ENDDO + + ! Fill in corner bits + zarg(0, 0, np) = & + 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & + zarg(-1,0,np) + zarg(0,-1,np)) + zarg(0, ncube, np) = & + 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & + zarg(-1,ncube,np) + zarg(1,ncube,np)) + zarg(ncube, 0, np) = & + 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & + zarg(ncube,-1,np) + zarg(ncube,1,np)) + zarg(ncube, ncube, np) = & + 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & + zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) + + END SUBROUTINE CubedSphereFillHalo_Linear + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereFillHalo_Cubic +! +! Description: +! Recompute the cubed sphere data storage array, with the addition of a +! 2-element halo region around the specified panel. Use higher order +! interpolation to translate between panels. +! +! Parameters: +! parg - Current panel values +! zarg (OUT) - Calculated panel values with halo/ghost region +! np - Panel number +! ncube - Dimension of the cubed sphere (# of grid lines) +!------------------------------------------------------------------------------ + SUBROUTINE CubedSphereFillHalo_Cubic(parg, zarg, np, ncube) + +! USE CubedSphereTrans ! Cubed sphere transforms +! USE MathUtils ! Has function for 1D cubic interpolation + + IMPLICIT NONE + + INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 + + REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg + + REAL (KIND=dbl_kind), & + DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & + INTENT(OUT) :: zarg + + INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube + + ! Local variables + INTEGER (KIND=int_kind) :: ii, iref, ibaseref, jj, ipanel, imin, imax + REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta + + REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha + REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha + REAL (KIND=dbl_kind), DIMENSION(1:4) :: C, D, X + + REAL (KIND=dbl_kind), & + DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg + + ! Use 0.0 order interpolation to begin + CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) + + zarg(:,:,np) = yarg(:,:,np) + + ! Calculate the overlapping alpha coordinates + width = pih / DBLE(ncube-1) + + DO jj = 1, nhalo + DO ii = 0, ncube + ! + ! alpha,beta for the cell center (extending the panel) + ! + prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq + beta = - width * (DBLE(jj-1) + 0.5) - piq + + CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & + newalpha(ii,jj), newbeta) + ENDDO + ENDDO + + ! Now apply cubic interpolation to obtain edge components + DO jj = 1, nhalo + ! Reset the reference index, which gives the element in newalpha that + ! is closest to ii, looking towards larger values of alpha. + iref = 2 + + ! Interpolation can be applied to more elements after first band +! IF (jj == 1) THEN +! imin = 1 +! imax = ncube-1 +! ELSE + imin = 0 + imax = ncube +! ENDIF + + ! Apply cubic interpolation + DO ii = imin, imax + DO WHILE ((iref .NE. ncube-1) .AND. & + (newalpha(ii,jj) > prealpha(iref,jj))) + iref = iref + 1 + ENDDO + + ! Smallest index for cubic interpolation - apply special consideration + IF (iref == 2) THEN + ibaseref = iref-1 + + ! Largest index for cubic interpolation - apply special consideration + ELSEIF (iref == ncube-1) THEN + ibaseref = iref-3 + + ! Normal range + ELSE + ibaseref = iref-2 + ENDIF + + ! Bottom edge of panel + zarg(ii, 1-jj, np) = & + CUBIC_EQUISPACE_INTERP( & + width, newalpha(ii,jj) - prealpha(ibaseref,jj), & + yarg(ibaseref:ibaseref+3, 1-jj, np)) + + ! Left edge of panel + zarg(1-jj, ii, np) = & + CUBIC_EQUISPACE_INTERP( & + width, newalpha(ii,jj) - prealpha(ibaseref,jj), & + yarg(1-jj, ibaseref:ibaseref+3, np)) + + ! Top edge of panel + zarg(ii, ncube+jj-1, np) = & + CUBIC_EQUISPACE_INTERP( & + width, newalpha(ii,jj) - prealpha(ibaseref,jj), & + yarg(ibaseref:ibaseref+3, ncube+jj-1, np)) + + ! Right edge of panel + zarg(ncube+jj-1, ii, np) = & + CUBIC_EQUISPACE_INTERP( & + width, newalpha(ii,jj) - prealpha(ibaseref,jj), & + yarg(ncube+jj-1, ibaseref:ibaseref+3, np)) + + ENDDO + ENDDO + + ! Fill in corner bits + zarg(0, 0, np) = & + 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & + zarg(-1,0,np) + zarg(0,-1,np)) + zarg(0, ncube, np) = & + 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & + zarg(-1,ncube,np) + zarg(1,ncube,np)) + zarg(ncube, 0, np) = & + 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & + zarg(ncube,-1,np) + zarg(ncube,1,np)) + zarg(ncube, ncube, np) = & + 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & + zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) + + END SUBROUTINE CubedSphereFillHalo_Cubic + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereABPFromABP +! +! Description: +! Determine the (alpha,beta,idest) coordinate of a source point on +! panel isource. +! +! Parameters: +! alpha_in - Alpha coordinate in +! beta_in - Beta coordinate in +! isource - Source panel +! idest - Destination panel +! alpha_out (OUT) - Alpha coordinate out +! beta_out (OUT) - Beta coordiante out +!------------------------------------------------------------------------------ + SUBROUTINE CubedSphereABPFromABP(alpha_in, beta_in, isource, idest, & + alpha_out, beta_out) + + IMPLICIT NONE + + REAL (KIND=dbl_kind), INTENT(IN) :: alpha_in, beta_in + INTEGER (KIND=int_kind), INTENT(IN) :: isource, idest + REAL (KIND=dbl_kind), INTENT(OUT) :: alpha_out, beta_out + + ! Local variables + REAL (KIND=dbl_kind) :: a1, b1 + REAL (KIND=dbl_kind) :: xx, yy, zz + REAL (KIND=dbl_kind) :: sx, sy, sz + + ! Convert to relative Cartesian coordinates + a1 = TAN(alpha_in) + b1 = TAN(beta_in) + + sz = (one + a1 * a1 + b1 * b1)**(-0.5) + sx = sz * a1 + sy = sz * b1 + + ! Convert to full Cartesian coordinates + IF (isource == 6) THEN + yy = sx; xx = -sy; zz = sz + + ELSEIF (isource == 5) THEN + yy = sx; xx = sy; zz = -sz + + ELSEIF (isource == 1) THEN + yy = sx; zz = sy; xx = sz + + ELSEIF (isource == 3) THEN + yy = -sx; zz = sy; xx = -sz + + ELSEIF (isource == 2) THEN + xx = -sx; zz = sy; yy = sz + + ELSEIF (isource == 4) THEN + xx = sx; zz = sy; yy = -sz + + ELSE + WRITE(*,*) 'Fatal Error: Source panel invalid in CubedSphereABPFromABP' + WRITE(*,*) 'panel = ', isource + STOP + ENDIF + + ! Convert to relative Cartesian coordinates on destination panel + IF (idest == 6) THEN + sx = yy; sy = -xx; sz = zz + + ELSEIF (idest == 5) THEN + sx = yy; sy = xx; sz = -zz + + ELSEIF (idest == 1) THEN + sx = yy; sy = zz; sz = xx + + ELSEIF (idest == 3) THEN + sx = -yy; sy = zz; sz = -xx + + ELSEIF (idest == 2) THEN + sx = -xx; sy = zz; sz = yy + + ELSEIF (idest == 4) THEN + sx = xx; sy = zz; sz = -yy + + ELSE + WRITE(*,*) 'Fatal Error: Dest panel invalid in CubedSphereABPFromABP' + WRITE(*,*) 'panel = ', idest + STOP + ENDIF + IF (sz < 0) THEN + WRITE(*,*) 'Fatal Error: In CubedSphereABPFromABP' + WRITE(*,*) 'Invalid relative Z coordinate' + STOP + ENDIF + + ! Use panel information to calculate (alpha, beta) coords + alpha_out = ATAN(sx / sz) + beta_out = ATAN(sy / sz) + + END SUBROUTINE + + +!------------------------------------------------------------------------------ +! FUNCTION CUBIC_EQUISPACE_INTERP +! +! Description: +! Apply cubic interpolation on the specified array of values, where all +! points are equally spaced. +! +! Parameters: +! dx - Spacing of points +! x - X coordinate where interpolation is to be applied +! y - Array of 4 values = f(x + k * dx) where k = 0,1,2,3 +!------------------------------------------------------------------------------ + FUNCTION CUBIC_EQUISPACE_INTERP(dx, x, y) + + IMPLICIT NONE + + REAL (KIND=dbl_kind) :: CUBIC_EQUISPACE_INTERP + REAL (KIND=dbl_kind) :: dx, x + REAL (KIND=dbl_kind), DIMENSION(1:4) :: y + + CUBIC_EQUISPACE_INTERP = & + (-y(1) / (6.0 * dx**3)) * (x - dx) * (x - 2.0 * dx) * (x - 3.0 * dx) + & + ( y(2) / (2.0 * dx**3)) * (x) * (x - 2.0 * dx) * (x - 3.0 * dx) + & + (-y(3) / (2.0 * dx**3)) * (x) * (x - dx) * (x - 3.0 * dx) + & + ( y(4) / (6.0 * dx**3)) * (x) * (x - dx) * (x - 2.0 * dx) + + END FUNCTION CUBIC_EQUISPACE_INTERP + +! FUNCTION I_10_ab(alpha,beta) +! IMPLICIT NONE +! REAL (KIND=dbl_kind) :: I_10_AB +! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta +! I_10_ab = -ASINH(COS(alpha) * TAN(beta)) +! END FUNCTION I_10_AB +!! +! +! REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) +! IMPLICIT NONE +! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta +! I_01_ab = -ASINH(COS(beta) * TAN(alpha)) +! END FUNCTION I_01_AB +! +! REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) +! IMPLICIT NONE +! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta +! +! I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) +! END FUNCTION I_20_AB +! +! REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) +! IMPLICIT NONE +! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta +! +! I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) +! END FUNCTION I_02_AB +! +! REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) +! IMPLICIT NONE +! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta +! +! I_11_ab = -SQRT(1.0+TAN(alpha)**2+TAN(beta)**2) +! END FUNCTION I_11_AB +! + + +END MODULE reconstruct + diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 b/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 new file mode 100755 index 000000000000..ed87b29c5a6d --- /dev/null +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 @@ -0,0 +1,1562 @@ +MODULE remap + INTEGER, PARAMETER :: & + int_kind = KIND(1), & + real_kind = SELECTED_REAL_KIND(p=14,r=100),& + dbl_kind = selected_real_kind(13) + + INTEGER :: nc,nhe + +! LOGICAL, PARAMETER:: ldbgr_r = .FALSE. + LOGICAL :: ldbgr + LOGICAL :: ldbg_global + + REAL(kind=real_kind), PARAMETER :: & + one = 1.0 ,& + aa = 1.0 ,& + tiny= 1.0E-9 ,& + bignum = 1.0E20 + REAL (KIND=dbl_kind), parameter :: fuzzy_width = 10.0*tiny !CAM-SE add + + contains + + + subroutine compute_weights_cell(xcell_in,ycell_in,jx,jy,nreconstruction,xgno,ygno,& + jx_min, jx_max, jy_min, jy_max,tmp,& + ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& + nc_in,nhe_in,nvertex,ldbg) + + implicit none + integer (kind=int_kind) , intent(in):: nreconstruction, jx,jy,ngauss,jmax_segments + real (kind=real_kind) , dimension(0:nvertex+1) :: xcell_in,ycell_in +! real (kind=real_kind) , dimension(0:5), intent(in):: xcell_in,ycell_in + integer (kind=int_kind), intent(in) :: nc_in,nhe_in,nvertex + logical, intent(in) :: ldbg + ! + ! ipanel is just for debugging + ! + integer (kind=int_kind), intent(in) :: jx_min, jy_min, jx_max, jy_max + real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: xgno + real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: ygno + ! + ! for Gaussian quadrature + ! + real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae + ! + ! boundaries of domain + ! + real (kind=real_kind):: tmp + ! + ! Number of Eulerian sub-cell integrals for the cell in question + ! + integer (kind=int_kind), intent(out) :: jcollect + ! + ! local workspace + ! + ! + ! max number of line segments is: + ! + ! (number of longitudes)*(max average number of crossings per line segment = 3)*ncube*2 + ! + real (kind=real_kind) , & + dimension(jmax_segments,nreconstruction), intent(out) :: weights + integer (kind=int_kind), & + dimension(jmax_segments,2), intent(out) :: weights_eul_index + + real (kind=real_kind), dimension(0:3) :: x,y + integer (kind=int_kind),dimension(0:5) :: jx_eul, jy_eul + integer (kind=int_kind) :: jsegment,i + ! + ! variables for registering crossings with Eulerian latitudes and longitudes + ! + integer (kind=int_kind) :: jcross_lat, iter + ! + ! max. crossings per side is 2*nhe + ! + real (kind=real_kind), & + dimension(jmax_segments,2) :: r_cross_lat + integer (kind=int_kind), & + dimension(jmax_segments,2) :: cross_lat_eul_index + real (kind=real_kind) , dimension(1:nvertex) :: xcell,ycell + + real (kind=real_kind) :: eps + + ldbg_global = ldbg + ldbgr = ldbg + + nc = nc_in + nhe = nhe_in + + xcell = xcell_in(1:nvertex) + ycell = ycell_in(1:nvertex) + + + ! + ! this is to avoid ill-conditioning problems + ! + eps = 1.0E-9 + + jsegment = 0 + weights = 0.0D0 + jcross_lat = 0 + ! + !********************** + ! + ! Integrate cell sides + ! + !********************** + + + IF (jx<-nhe.OR.jx>nc+1+nhe.OR.jy<-nhe.OR.jy>nc+1+nhe) THEN + WRITE(*,*) "jx,jy,-nhe,nc+1+nhe",jx,jy,-nhe,nc+1+nhe + STOP + END IF + + + call side_integral(xcell,ycell,nvertex,jsegment,jmax_segments,& + weights,weights_eul_index,nreconstruction,jx,jy,xgno,ygno,jx_min, jx_max, jy_min, jy_max,& + ngauss,gauss_weights,abscissae,& + jcross_lat,r_cross_lat,cross_lat_eul_index) + + ! + !********************** + ! + ! Do inner integrals + ! + !********************** + ! + call compute_inner_line_integrals_lat_nonconvex(r_cross_lat,cross_lat_eul_index,& + jcross_lat,jsegment,jmax_segments,xgno,jx_min, jx_max, jy_min, jy_max,& + weights,weights_eul_index,& + nreconstruction,ngauss,gauss_weights,abscissae) + ! + ! collect line-segment that reside in the same Eulerian cell + ! + if (jsegment>0) then + call collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) + ! + ! DBG + ! + tmp=0.0 + do i=1,jcollect + tmp=tmp+weights(i,1) + enddo + + IF (abs(tmp)>0.01) THEN + WRITE(*,*) "sum of weights too large",tmp + !stop + END IF + IF (tmp<-1.0E-9) THEN + WRITE(*,*) "sum of weights is negative - negative area?",tmp,jx,jy + ! ldbgr=.TRUE. + !stop + !!turn this off for phys grid as that of E3SM + END IF + else + jcollect = 0 + end if + end subroutine compute_weights_cell + + + ! + !**************************************************************************** + ! + ! organize data and store it + ! + !**************************************************************************** + ! + subroutine collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) + implicit none + integer (kind=int_kind) , intent(in) :: nreconstruction + real (kind=real_kind) , dimension(jmax_segments,nreconstruction), intent(inout) :: weights + integer (kind=int_kind), dimension(jmax_segments,2 ), intent(inout) :: weights_eul_index + integer (kind=int_kind), INTENT(OUT ) :: jcollect + integer (kind=int_kind), INTENT(IN ) :: jsegment,jmax_segments + ! + ! local workspace + ! + integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k,h + logical :: ltmp + + real (kind=real_kind) , dimension(jmax_segments,nreconstruction) :: weights_out + integer (kind=int_kind), dimension(jmax_segments,2 ) :: weights_eul_index_out + + weights_out = 0.0D0 + weights_eul_index_out = -100 + + imin = MINVAL(weights_eul_index(1:jsegment,1)) + imax = MAXVAL(weights_eul_index(1:jsegment,1)) + jmin = MINVAL(weights_eul_index(1:jsegment,2)) + jmax = MAXVAL(weights_eul_index(1:jsegment,2)) + + ltmp = .FALSE. + + jcollect = 1 + + do j=jmin,jmax + do i=imin,imax + do k=1,jsegment + if (weights_eul_index(k,1)==i.AND.weights_eul_index(k,2)==j) then + weights_out(jcollect,1:nreconstruction) = & + weights_out(jcollect,1:nreconstruction) + weights(k,1:nreconstruction) + ltmp = .TRUE. + h = k + endif + enddo + if (ltmp) then + weights_eul_index_out(jcollect,:) = weights_eul_index(h,:) + jcollect = jcollect+1 + endif + ltmp = .FALSE. + enddo + enddo + jcollect = jcollect-1 + weights = weights_out + weights_eul_index = weights_eul_index_out + end subroutine collect + ! + !***************************************************************************************** + ! + ! + ! + !***************************************************************************************** + ! + subroutine compute_inner_line_integrals_lat(r_cross_lat,cross_lat_eul_index,& + jcross_lat,jsegment,jmax_segments,xgno,jx_min,jx_max,jy_min, jy_max,weights,weights_eul_index,& + nreconstruction,ngauss,gauss_weights,abscissae)!phl add jx_min etc. + implicit none + ! + ! for Gaussian quadrature + ! + real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae + ! + ! variables for registering crossings with Eulerian latitudes and longitudes + ! + integer (kind=int_kind), intent(in):: jcross_lat, jmax_segments,nreconstruction,ngauss + integer (kind=int_kind), intent(inout):: jsegment + ! + ! max. crossings per side is 2*nhe + ! + real (kind=real_kind), & + dimension(jmax_segments,2), intent(in):: r_cross_lat + integer (kind=int_kind), & + dimension(jmax_segments,2), intent(in):: cross_lat_eul_index + integer (kind=int_kind), intent(in) ::jx_min, jx_max, jy_min, jy_max + real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: xgno + real (kind=real_kind) , & + dimension(jmax_segments,nreconstruction), intent(inout) :: weights + integer (kind=int_kind), & + dimension(jmax_segments,2), intent(inout) :: weights_eul_index + real (kind=real_kind) , dimension(nreconstruction) :: weights_tmp + + integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k, isgn, h, eul_jx, eul_jy + integer (kind=int_kind) :: idx_start_y,idx_end_y + logical :: ltmp,lcontinue + real (kind=real_kind), dimension(2) :: rstart,rend,rend_tmp + real (kind=real_kind), dimension(2) :: xseg, yseg +5 FORMAT(10e14.6) + + + if (jcross_lat>0) then + do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) + ! + ! find "first" crossing with Eulerian cell i + ! + do k=1,jcross_lat + if (cross_lat_eul_index(k,2)==i) exit + enddo + do j=k+1,jcross_lat + ! + ! find "second" crossing with Eulerian cell i + ! + if (cross_lat_eul_index(j,2)==i) then + if (r_cross_lat(k,1)0) then + do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) + ! WRITE(*,*) "looking at latitude ",i !xxxx + count = 1 + ! + ! find all crossings with Eulerian latitude i + ! + do k=1,jcross_lat + if (cross_lat_eul_index(k,2)==i) then + ! WRITE(*,*) "other crossings with latitude",i ," is ",k!xxxx + r_cross_lat_seg (count,:) = r_cross_lat (k,:) + cross_lat_eul_index_seg(count,:) = cross_lat_eul_index(k,:) + + IF (ldbg_global) then + WRITE(*,*) r_cross_lat_seg(count,1),r_cross_lat_seg(count,2) + WRITE(*,*) " " + END IF + count = count+1 + end if + enddo + count = count-1 + IF (ABS((count/2)-DBLE(count)/2.0)1000) THEN + WRITE(*,*) "search not converging",iter + STOP + END IF + lsame_cell_x = (x(2).GE.xgno(jx_eul).AND.x(2).LE.xgno(jx_eul+1)) + lsame_cell_y = (y(2).GE.ygno(jy_eul).AND.y(2).LE.ygno(jy_eul+1)) +! IF (ldbgr) WRITE(*,*) "lsame_cell_x,lsame_cell_y=",lsame_cell_x,lsame_cell_y + IF (lsame_cell_x.AND.lsame_cell_y) THEN + ! + !**************************** + ! + ! same cell integral + ! + !**************************** + ! +! IF (ldbgr) WRITE(*,*) "same cell integral",jx_eul,jy_eul + xseg(1) = x(1); yseg(1) = y(1); xseg(2) = x(2); yseg(2) = y(2) + jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; + lcontinue = .FALSE. + ! + ! prepare for next side if (x(2),y(2)) is on a grid line + ! + IF (x(2).EQ.xgno(jx_eul+1).AND.x(3)>xgno(jx_eul+1)) THEN + ! + ! cross longitude jx_eul+1 + ! +! IF (ldbgr) WRITE(*,*) "cross longitude",jx_eul+1 + jx_eul=jx_eul+1 + ELSE IF (x(2).EQ.xgno(jx_eul ).AND.x(3)ygno(jy_eul+1)) THEN + ! + ! register crossing with latitude: line-segments point Northward + ! + jcross_lat = jcross_lat + 1 + jy_eul = jy_eul + 1 +! IF (ldbgr) WRITE(*,*) "cross latitude",jy_eul + cross_lat_eul_index(jcross_lat,1) = jx_eul + cross_lat_eul_index(jcross_lat,2) = jy_eul + r_cross_lat(jcross_lat,1) = x(2) + r_cross_lat(jcross_lat,2) = y(2) + ELSE IF (y(2).EQ.ygno(jy_eul ).AND.y(3)y(1) else "0" + ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" + ! + !******************************************************************************* + ! + ! there is at least one crossing with latitudes but no crossing with longitudes + ! + !******************************************************************************* + ! + yeul = ygno(jy_eul+ysgn1) + IF (x(1).EQ.x(2)) THEN + ! + ! line segment is parallel to longitude (infinite slope) + ! +! IF (ldbgr) WRITE(*,*) "line segment parallel to longitude" + xcross = x(1) + ELSE + slope = (y(2)-y(1))/(x(2)-x(1)) + xcross = x_cross_eul_lat(x(1),y(1),yeul,slope) + ! + ! constrain crossing to be "physically" possible + ! + xcross = MIN(MAX(xcross,xgno(jx_eul)),xgno(jx_eul+1)) + + +! IF (ldbgr) WRITE(*,*) "cross latitude" + ! + ! debugging + ! + IF (xcross.GT.xgno(jx_eul+1).OR.xcross.LT.xgno(jx_eul)) THEN + WRITE(*,*) "xcross is out of range",jx,jy + WRITE(*,*) "xcross-xgno(jx_eul+1), xcross-xgno(jx_eul))",& + xcross-xgno(jx_eul+1), xcross-ygno(jx_eul) + STOP + END IF + END IF + xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul + jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; + ! + ! prepare for next iteration + ! + x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 + ! + ! register crossing with latitude + ! + jcross_lat = jcross_lat+1 + cross_lat_eul_index(jcross_lat,1) = jx_eul + if (ysgn2>0) then + cross_lat_eul_index(jcross_lat,2) = jy_eul + else + cross_lat_eul_index(jcross_lat,2) = jy_eul+1 + end if + r_cross_lat(jcross_lat,1) = xcross + r_cross_lat(jcross_lat,2) = yeul + ELSE IF (lsame_cell_y) THEN +! IF (ldbgr) WRITE(*,*) "same cell y" + ! + !******************************************************************************* + ! + ! there is at least one crossing with longitudes but no crossing with latitudes + ! + !******************************************************************************* + ! + xsgn1 = (1+INT(SIGN(1.0D0,x(2)-x(1))))/2 !"1" if x(2)>x(1) else "0" + xsgn2 = INT(SIGN(1.0D0,x(2)-x(1))) !"1" if x(2)>x(1) else "-1" + xeul = xgno(jx_eul+xsgn1) +! IF (ldbgr) WRITE(*,*) " crossing longitude",jx_eul+xsgn1 + IF (ABS(x(2)-x(1))x(1) else "0" + xsgn2 = (INT(SIGN(1.0D0,x(2)-x(1)))) !"1" if x(2)>x(1) else "0" + xeul = xgno(jx_eul+xsgn1) + ysgn1 = (1+INT(SIGN(1.0D0,y(2)-y(1))))/2 !"1" if y(2)>y(1) else "0" + ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" + yeul = ygno(jy_eul+ysgn1) + + slope = (y(2)-y(1))/(x(2)-x(1)) + IF (ABS(x(2)-x(1))0.AND.xcross.LE.xeul).OR.(xsgn2<0.AND.xcross.GE.xeul)) THEN + ! + ! cross latitude + ! +! IF (ldbgr) WRITE(*,*) "crossing latitude",jy_eul+ysgn1 + xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul + jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; + ! + ! prepare for next iteration + ! + x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 + ! + ! register crossing with latitude + ! + jcross_lat = jcross_lat+1 + cross_lat_eul_index(jcross_lat,1) = jx_eul + if (ysgn2>0) then + cross_lat_eul_index(jcross_lat,2) = jy_eul + else + cross_lat_eul_index(jcross_lat,2) = jy_eul+1 + end if + r_cross_lat(jcross_lat,1) = xcross + r_cross_lat(jcross_lat,2) = yeul + ELSE + ! + ! cross longitude + ! +! IF (ldbgr) WRITE(*,*) "crossing longitude",jx_eul+xsgn1 + xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xeul; yseg(2) = ycross + jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; + ! + ! prepare for next iteration + ! + x(0) = x(1); y(0) = y(1); x(1) = xeul; y(1) = ycross; jx_eul = jx_eul+xsgn2 + END IF + + END IF + END IF + ! + ! register line-segment (don't register line-segment if outside of panel) + ! + if (jx_eul_tmp>=jx_min.AND.jy_eul_tmp>=jy_min.AND.& + jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1) then + ! jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1.AND.side_count<3) then + jsegment=jsegment+1 + weights_eul_index(jsegment,1) = jx_eul_tmp + weights_eul_index(jsegment,2) = jy_eul_tmp + call get_weights_gauss(weights(jsegment,1:nreconstruction),& + xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) + +! if (ldbg_global) then +! OPEN(unit=40, file='side_integral.dat',status='old',access='append') +! WRITE(40,*) xseg(1),yseg(1) +! WRITE(40,*) xseg(2),yseg(2) +! WRITE(40,*) " " +! CLOSE(40) +! end if + + + jdbg=jdbg+1 + + if (xseg(1).EQ.xseg(2))then + slope = bignum + else if (abs(yseg(1) -yseg(2))0) THEN + compute_slope = (y(2)-y(1))/(x(2)-x(1)) + else + compute_slope = bignum + end if + end function compute_slope + + real (kind=real_kind) function y_cross_eul_lon(x,y,xeul,slope) + implicit none + real (kind=real_kind), intent(in) :: x,y + real (kind=real_kind) , intent(in) :: xeul,slope + ! line: y=a*x+b + real (kind=real_kind) :: a,b + b = y-slope*x + y_cross_eul_lon = slope*xeul+b + end function y_cross_eul_lon + + real (kind=real_kind) function x_cross_eul_lat(x,y,yeul,slope) + implicit none + real (kind=real_kind), intent(in) :: x,y + real (kind=real_kind) , intent(in) :: yeul,slope + + if (fuzzy(ABS(slope),fuzzy_width)>0) THEN + x_cross_eul_lat = x+(yeul-y)/slope + ELSE + ! WRITE(*,*) "WARNING: slope is epsilon - ABORT" + x_cross_eul_lat = bignum + END IF + end function x_cross_eul_lat + + subroutine get_weights_exact(weights,xseg,yseg,nreconstruction) +! use cslam_analytic_mod, only: I_00, I_10, I_01, I_20, I_02, I_11 + implicit none + integer (kind=int_kind), intent(in) :: nreconstruction + real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights + real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg + ! + ! compute weights + ! + real (kind=real_kind) :: tmp,slope,b,integral,dx2,xc + integer (kind=int_kind) :: i +! weights(:) = -half*(xseg(1)*yseg(2)-xseg(2)*yseg(1)) !dummy for testing + + weights(1) = ((I_00(xseg(2),yseg(2))-I_00(xseg(1),yseg(1)))) + if (ABS(weights(1))>1.0) THEN + WRITE(*,*) "1 exact weights(jsegment)",weights(1),xseg,yseg + stop + end if + if (nreconstruction>1) then + weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) + weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) + endif + if (nreconstruction>3) then + weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) + weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) + weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) + endif + + end subroutine get_weights_exact + + + + subroutine get_weights_gauss(weights,xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) + implicit none + integer (kind=int_kind), intent(in) :: nreconstruction,ngauss + real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights + real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg + real (kind=real_kind) :: slope + ! + ! compute weights + ! + ! + ! for Gaussian quadrature + ! + real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae + + ! if line-segment parallel to x or y use exact formulaes else use qudrature + ! + real (kind=real_kind) :: tmp,b,integral,dx2,xc,x,y + integer (kind=int_kind) :: i + + + + +! if (fuzzy(abs(xseg(1) -xseg(2)),fuzzy_width)==0)then + if (xseg(1).EQ.xseg(2))then + weights = 0.0D0 + else if (abs(yseg(1) -yseg(2))1) then + weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) + weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) + endif + if (nreconstruction>3) then + weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) + weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) + weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) + endif + else + + + slope = (yseg(2)-yseg(1))/(xseg(2)-xseg(1)) + b = yseg(1)-slope*xseg(1) + dx2 = 0.5D0*(xseg(2)-xseg(1)) + if (ldbgr) WRITE(*,*) "dx2 and slope in gauss weight",dx2,slope + xc = 0.5D0*(xseg(1)+xseg(2)) + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_00(x,y) + enddo + weights(1) = integral*dx2 + if (nreconstruction>1) then + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_10(x,y) + enddo + weights(2) = integral*dx2 + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_01(x,y) + enddo + weights(3) = integral*dx2 + endif + if (nreconstruction>3) then + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_20(x,y) + enddo + weights(4) = integral*dx2 + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_02(x,y) + enddo + weights(5) = integral*dx2 + integral = 0.0D0 + do i=1,ngauss + x = xc+abscissae(i)*dx2 + y = slope*x+b + integral = integral+gauss_weights(i)*F_11(x,y) + enddo + weights(6) = integral*dx2 + endif + end if + end subroutine get_weights_gauss + + real (kind=real_kind) function F_00(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,tmp + + x = x_in + y = y_in + + F_00 =y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) + end function F_00 + + real (kind=real_kind) function F_10(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,tmp + + x = x_in + y = y_in + + F_10 =x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) + end function F_10 + + real (kind=real_kind) function F_01(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,tmp + + x = x_in + y = y_in + + F_01 =-1.0D0/(SQRT(1.0D0+x*x+y*y)) + end function F_01 + + real (kind=real_kind) function F_20(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,tmp + + x = x_in + y = y_in + + F_20 =x*x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) + end function F_20 + + real (kind=real_kind) function F_02(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,alpha, tmp + + x = x_in + y = y_in + + alpha = ATAN(x) + tmp=y*COS(alpha) + F_02 =-y/SQRT(1.0D0+x*x+y*y)+log(tmp+sqrt(tmp*tmp+1)) + + ! + ! cos(alpha) = 1/sqrt(1+x*x) + ! + end function F_02 + + real (kind=real_kind) function F_11(x_in,y_in) + implicit none + real (kind=real_kind), intent(in) :: x_in,y_in + real (kind=real_kind) :: x,y,tmp + + x = x_in + y = y_in + + F_11 =-x/(SQRT(1.0D0+x*x+y*y)) + end function F_11 + + subroutine which_eul_cell(x,j_eul,gno) + implicit none + integer (kind=int_kind) , intent(inout) :: j_eul + real (kind=real_kind), dimension(3) , intent(in) :: x + real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl +! real (kind=real_kind), intent(in) :: eps + + real (kind=real_kind) :: d1,d2,d3,d1p1 + logical :: lcontinue + integer :: iter + + + ! + ! this is not needed in transport code search + ! +! IF (x(1)gno(nc+2+nhe)) j_eul=nc+1+nhe +! RETURN + +! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added + + lcontinue = .TRUE. + iter = 0 + IF (ldbgr) WRITE(*,*) "from which_eul_cell",x(1),x(2),x(3) + DO WHILE (lcontinue) + iter = iter+1 + IF (x(1).GE.gno(j_eul).AND.x(1).LT.gno(j_eul+1)) THEN + lcontinue = .FALSE. + ! + ! special case when x(1) is on top of grid line + ! + IF (x(1).EQ.gno(j_eul)) THEN +! IF (ABS(x(1)-gno(j_eul))1000.OR.j_eul<-nhe.OR.j_eul>nc+2+nhe) THEN + WRITE(*,*) "search in which_eul_cell not converging!", iter,j_eul + WRITE(*,*) "input", x + WRITE(*,*) "gno", gno(nc),gno(nc+1),gno(nc+2),gno(nc+3) + STOP + END IF + END DO + END subroutine which_eul_cell + + + subroutine truncate_vertex(x,j_eul,gno) + implicit none + integer (kind=int_kind) , intent(inout) :: j_eul + real (kind=real_kind) , intent(inout) :: x + real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl +! real (kind=real_kind), intent(in) :: eps + + logical :: lcontinue + integer :: iter + real (kind=real_kind) :: xsgn,dist,dist_new,tmp + + ! + ! this is not needed in transport code search + ! +! IF (xgno(nc+2+nhe)) j_eul=nc+1+nhe +! +! RETURN + + + lcontinue = .TRUE. + iter = 0 + dist = bignum +! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added + xsgn = INT(SIGN(1.0_dbl_kind,x-gno(j_eul))) + DO WHILE (lcontinue) + iter = iter+1 + tmp = x-gno(j_eul) + dist_new = ABS(tmp) + IF (dist_new>dist) THEN + lcontinue = .FALSE. +! ELSE IF (ABS(tmp)<1.0E-11) THEN + ELSE IF (ABS(tmp)<1.0E-9) THEN +! ELSE IF (ABS(tmp)<1.0E-4) THEN + x = gno(j_eul) + lcontinue = .FALSE. + ELSE + j_eul = j_eul+xsgn + dist = dist_new + END IF + IF (iter>10000) THEN + WRITE(*,*) "truncate vertex not converging" + STOP + END IF + END DO + END subroutine truncate_vertex + + + + +!******************************************************************************** +! +! Gauss-Legendre quadrature +! +! Tabulated values +! +!******************************************************************************** +subroutine gauss_points(n,weights,points) + implicit none + real (kind=real_kind), dimension(n), intent(out) :: weights, points + integer (kind=int_kind) , intent(in ) :: n + + select case (n) +! CASE(1) +! abscissae(1) = 0.0D0 +! weights(1) = 2.0D0 + case(2) + points(1) = -sqrt(1.0D0/3.0D0) + points(2) = sqrt(1.0D0/3.0D0) + weights(1) = 1.0D0 + weights(2) = 1.0D0 + case(3) + points(1) = -0.774596669241483377035853079956D0 + points(2) = 0.0D0 + points(3) = 0.774596669241483377035853079956D0 + weights(1) = 0.555555555555555555555555555556D0 + weights(2) = 0.888888888888888888888888888889D0 + weights(3) = 0.555555555555555555555555555556D0 + case(4) + points(1) = -0.861136311594052575223946488893D0 + points(2) = -0.339981043584856264802665659103D0 + points(3) = 0.339981043584856264802665659103D0 + points(4) = 0.861136311594052575223946488893D0 + weights(1) = 0.347854845137453857373063949222D0 + weights(2) = 0.652145154862546142626936050778D0 + weights(3) = 0.652145154862546142626936050778D0 + weights(4) = 0.347854845137453857373063949222D0 + case(5) + points(1) = -(1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) + points(2) = -(1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) + points(3) = 0.0D0 + points(4) = (1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) + points(5) = (1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) + weights(1) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 + weights(2) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 + weights(3) = 128.0D0/225.0D0 + weights(4) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 + weights(5) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 + case default + write(*,*) 'n out of range in glwp of module gll. n=',n + write(*,*) '0 0.0D0) THEN + signum = 1.0D0 + ELSEIF (x < 0.0D0) THEN + signum = -1.0D0 + ELSE + signum = 0.0D0 + ENDIF + end function + +!------------------------------------------------------------------------------ +! FUNCTION SIGNUM_FUZZY +! +! Description: +! Gives the sign of the given real number, returning zero if x is within +! a small amount from zero. +!------------------------------------------------------------------------------ + function signum_fuzzy(x) + implicit none + + real (kind=real_kind) :: signum_fuzzy + real (kind=real_kind) :: x + + IF (x > fuzzy_width) THEN + signum_fuzzy = 1.0D0 + ELSEIF (x < fuzzy_width) THEN + signum_fuzzy = -1.0D0 + ELSE + signum_fuzzy = 0.0D0 + ENDIF + end function + + function fuzzy(x,epsilon) + implicit none + + integer (kind=int_kind) :: fuzzy + real (kind=real_kind), intent(in) :: epsilon + real (kind=real_kind) :: x + + IF (ABS(x)epsilon) THEN + fuzzy = 1 + ELSE !IF (x < fuzzy_width) THEN + fuzzy = -1 + ENDIF + end function + +! +! see, e.g., http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ +! +subroutine check_lines_cross(x1,x2,x3,x4,y1,y2,y3,y4,lcross) + implicit none + real (kind=real_kind), INTENT(IN) :: x1,x2,x3,x4,y1,y2,y3,y4 + LOGICAL, INTENT(OUT) :: lcross + ! + ! local workspace + ! + real (kind=real_kind) :: cp,tx,ty + + cp = (y4-y3)*(x2-x1)-(x4-x3)*(y2-y1) + IF (ABS(cp)-tiny.AND.tx<1.0D0+tiny.AND.& + ty>-tiny.AND.ty<1.0D0+tiny) THEN + lcross = .TRUE. + ELSE + lcross = .FALSE. +! WRITE(*,*) "not parallel but not crossing,",tx,ty + ENDIF + ENDIF +end subroutine check_lines_cross + + + REAL (KIND=dbl_kind) FUNCTION I_00(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y + + x = x_in/aa + y = y_in/aa +! x = x_in +! y = y_in + I_00 = ATAN(x*y/SQRT(one+x*x+y*y)) + END FUNCTION I_00 + + REAL (KIND=dbl_kind) FUNCTION I_10(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y,tmp + + x = x_in/aa + y = y_in/aa + tmp = ATAN(x) + I_10 = -ASINH(y*COS(tmp)) + ! + ! = -arcsinh(y/sqrt(1+x^2)) + ! + END FUNCTION I_10 + + REAL (KIND=dbl_kind) FUNCTION I_10_ab(alpha,beta) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta + I_10_ab = -ASINH(COS(alpha) * TAN(beta)) + END FUNCTION I_10_AB + + REAL (KIND=dbl_kind) FUNCTION I_01(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y!,beta + + x = x_in/aa + y = y_in/aa +! beta = ATAN(y) +! I_01 = -ASINH(x*COS(beta)) + I_01 = -ASINH(x/SQRT(1+y*y)) + END FUNCTION I_01 + + REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta + I_01_ab = -ASINH(COS(beta) * TAN(alpha)) + END FUNCTION I_01_AB + + REAL (KIND=dbl_kind) FUNCTION I_20(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta + + x = x_in/aa + y = y_in/aa +! alpha = aa*ATAN(x) +! beta = aa*ATAN(y) + + tmp = one+y*y + +! I_20 = y*ASINH(COS(beta)*x)+ACOS(SIN(alpha)*SIN(beta)) + I_20 = y*ASINH(x/SQRT(tmp))+ACOS(x*y/(SQRT((one+x*x)*tmp))) + END FUNCTION I_20 + + REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta + + I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) + END FUNCTION I_20_AB + + REAL (KIND=dbl_kind) FUNCTION I_02(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta + + x = x_in/aa + y = y_in/aa +! alpha = aa*ATAN(x) +! beta = aa*ATAN(y) + + tmp=one+x*x + + I_02 = x*ASINH(y/SQRT(tmp))+ACOS(x*y/SQRT(tmp*(1+y*y))) + END FUNCTION I_02 + + REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta + + I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) + END FUNCTION I_02_AB + + + REAL (KIND=dbl_kind) FUNCTION I_11(x_in,y_in) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in + REAL (KIND=dbl_kind) :: x,y + + x = x_in/aa + y = y_in/aa + + I_11 = -SQRT(1+x*x+y*y) + END FUNCTION I_11 + + REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) + IMPLICIT NONE + REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta + + I_11_ab = -SQRT(one+TAN(alpha)**2+TAN(beta)**2) + END FUNCTION I_11_AB +!------------------------------------------------------------------------------ +! FUNCTION ASINH +! +! Description: +! Hyperbolic arcsin function +!------------------------------------------------------------------------------ + FUNCTION ASINH(x) + IMPLICIT NONE + + REAL (KIND=dbl_kind) :: ASINH + REAL (KIND=dbl_kind) :: x + + ASINH = LOG(x + SQRT(x * x + one)) + END FUNCTION + + + !******************************************************************************** + ! + ! Gauss-Legendre quadrature + ! + ! Tabulated values + ! + !******************************************************************************** + SUBROUTINE glwp(n,weights,abscissae) + IMPLICIT NONE + REAL (KIND=dbl_kind), DIMENSION(n), INTENT(OUT) :: weights, abscissae + INTEGER (KIND=int_kind) , INTENT(IN ) :: n + + SELECT CASE (n) + CASE(1) + abscissae(1) = 0.0 + weights(1) = 2.0 + CASE(2) + abscissae(1) = -SQRT(1.0/3.0) + abscissae(2) = SQRT(1.0/3.0) + weights(1) = 1.0 + weights(2) = 1.0 + CASE(3) + abscissae(1) = -0.774596669241483377035853079956_dbl_kind + abscissae(2) = 0.0 + abscissae(3) = 0.774596669241483377035853079956_dbl_kind + weights(1) = 0.555555555555555555555555555556_dbl_kind + weights(2) = 0.888888888888888888888888888889_dbl_kind + weights(3) = 0.555555555555555555555555555556_dbl_kind + CASE(4) + abscissae(1) = -0.861136311594052575223946488893_dbl_kind + abscissae(2) = -0.339981043584856264802665659103_dbl_kind + abscissae(3) = 0.339981043584856264802665659103_dbl_kind + abscissae(4) = 0.861136311594052575223946488893_dbl_kind + weights(1) = 0.347854845137453857373063949222_dbl_kind + weights(2) = 0.652145154862546142626936050778_dbl_kind + weights(3) = 0.652145154862546142626936050778_dbl_kind + weights(4) = 0.347854845137453857373063949222_dbl_kind + CASE(5) + abscissae(1) = -(1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) + abscissae(2) = -(1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) + abscissae(3) = 0.0 + abscissae(4) = (1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) + abscissae(5) = (1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) + weights(1) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind + weights(2) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind + weights(3) = 128.0_dbl_kind/225.0_dbl_kind + weights(4) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind + weights(5) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind + CASE DEFAULT + WRITE(*,*) 'n out of range in glwp of module gll. n=',n + WRITE(*,*) '0 shr_kind_r8 +contains +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereABPFromRLL +! +! Description: +! Determine the (alpha,beta,panel) coordinate of a point on the sphere from +! a given regular lat lon coordinate. +! +! Parameters: +! lon - Coordinate longitude +! lat - Coordinate latitude +! alpha (OUT) - Alpha coordinate +! beta (OUT) - Beta coordinate +! ipanel (OUT) - Face panel +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + REAL (R8), INTENT(IN) :: lon, lat + REAL (R8), INTENT(OUT) :: alpha, beta + INTEGER :: ipanel + LOGICAL, INTENT(IN) :: ldetermine_panel + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + REAL (r8), PARAMETER :: rotate_cube = 0.0 + + ! Local variables + REAL (R8) :: xx, yy, zz, pm + REAL (R8) :: sx, sy, sz + INTEGER :: ix, iy, iz + + ! Translate to (x,y,z) space + xx = COS(lon-rotate_cube) * COS(lat) + yy = SIN(lon-rotate_cube) * COS(lat) + zz = SIN(lat) + + pm = MAX(ABS(xx), ABS(yy), ABS(zz)) + + ! Check maximality of the x coordinate + IF (pm == ABS(xx)) THEN + IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF + ELSE + ix = 0 + ENDIF + + ! Check maximality of the y coordinate + IF (pm == ABS(yy)) THEN + IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF + ELSE + iy = 0 + ENDIF + + ! Check maximality of the z coordinate + IF (pm == ABS(zz)) THEN + IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF + ELSE + iz = 0 + ENDIF + + ! Panel assignments + IF (ldetermine_panel) THEN + IF (iz == 1) THEN + ipanel = 6; sx = yy; sy = -xx; sz = zz + + ELSEIF (iz == -1) THEN + ipanel = 5; sx = yy; sy = xx; sz = -zz + + ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN + ipanel = 1; sx = yy; sy = zz; sz = xx + + ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN + ipanel = 3; sx = -yy; sy = zz; sz = -xx + + ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN + ipanel = 2; sx = -xx; sy = zz; sz = yy + + ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN + ipanel = 4; sx = xx; sy = zz; sz = -yy + + ELSE + WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' + WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' + WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' + STOP + ENDIF + ELSE + IF (ipanel == 6) THEN + sx = yy; sy = -xx; sz = zz + ELSEIF (ipanel == 5) THEN + sx = yy; sy = xx; sz = -zz + ELSEIF (ipanel == 1) THEN + sx = yy; sy = zz; sz = xx + ELSEIF (ipanel == 3) THEN + sx = -yy; sy = zz; sz = -xx + ELSEIF (ipanel == 2) THEN + sx = -xx; sy = zz; sz = yy + ELSEIF (ipanel == 4) THEN + sx = xx; sy = zz; sz = -yy + ELSE + WRITE(*,*) "ipanel out of range",ipanel + STOP + END IF + END IF + + ! Use panel information to calculate (alpha, beta) coords + alpha = ATAN(sx / sz) + beta = ATAN(sy / sz) + +END SUBROUTINE CubedSphereABPFromRLL + +!------------------------------------------------------------------------------ +! SUBROUTINE EquiangularAllAreas +! +! Description: +! Compute the area of all cubed sphere grid cells, storing the results in +! a two dimensional array. +! +! Parameters: +! icube - Resolution of the cubed sphere +! dA (OUT) - Output array containing the area of all cubed sphere grid cells +!------------------------------------------------------------------------------ +SUBROUTINE EquiangularAllAreas(icube, dA) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + INTEGER, INTENT(IN) :: icube + REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA + + ! Local variables + INTEGER :: k, k1, k2 + REAL (r8) :: a1, a2, a3, a4 + REAL (r8), DIMENSION(icube+1,icube+1) :: ang + REAL (r8), DIMENSION(icube+1) :: gp + + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + + + !#ifdef DBG + REAL (r8) :: dbg1 !DBG + !#endif + + ! Recall that we are using equi-angular spherical gridding + ! Compute the angle between equiangular cubed sphere projection grid lines. + DO k = 1, icube+1 + gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) + ENDDO + + DO k2=1,icube+1 + DO k1=1,icube+1 + ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) + ENDDO + ENDDO + + DO k2=1,icube + DO k1=1,icube + a1 = ang(k1 , k2 ) + a2 = pi - ang(k1+1, k2 ) + a3 = pi - ang(k1 , k2+1) + a4 = ang(k1+1, k2+1) + ! area = r*r*(-2*pi+sum(interior angles)) + DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 + ENDDO + ENDDO + + !#ifdef DBG + ! Only for debugging - test consistency + dbg1 = 0.0 !DBG + DO k2=1,icube + DO k1=1,icube + dbg1 = dbg1 + DA(k1,k2) !DBG + ENDDO + ENDDO + write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG + !#endif +END SUBROUTINE EquiangularAllAreas + + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereRLLFromABP +! +! Description: +! Determine the lat lon coordinate of a point on a sphere given its +! (alpha,beta,panel) coordinate. +! +! Parameters: +! alpha - Alpha coordinate +! beta - Beta coordinate +! panel - Cubed sphere panel id +! lon (OUT) - Calculated longitude +! lat (OUT) - Calculated latitude +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + REAL (r8), INTENT(IN) :: alpha, beta + INTEGER , INTENT(IN) :: ipanel + REAL (r8), INTENT(OUT) :: lon, lat + ! Local variables + REAL (r8) :: xx, yy, zz, rotate_cube + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: piq = 0.25*pi + + rotate_cube = 0.0 + ! Convert to cartesian coordinates + CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) + ! Convert back to lat lon + lat = ASIN(zz) + if (xx==0.0.and.yy==0.0) THEN + lon = 0.0 + else + lon = ATAN2(yy, xx) +rotate_cube + IF (lon<0.0) lon=lon+2.0*pi + IF (lon>2.0*pi) lon=lon-2.0*pi + end if +END SUBROUTINE CubedSphereRLLFromABP + +!------------------------------------------------------------------------------ +! SUBROUTINE CubedSphereXYZFromABP +! +! Description: +! Determine the Cartesian coordinate of a point on a sphere given its +! (alpha,beta,panel) coordinate. +! +! Parameters: +! alpha - Alpha coordinate +! beta - Beta coordinate +! panel - Cubed sphere panel id +! xx (OUT) - Calculated x coordinate +! yy (OUT) - Calculated y coordinate +! zz (OUT) - Calculated z coordinate +!------------------------------------------------------------------------------ +SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) + use shr_kind_mod, only: r8 => shr_kind_r8 + IMPLICIT NONE + + REAL (r8), INTENT(IN) :: alpha, beta + INTEGER , INTENT(IN) :: ipanel + REAL (r8), INTENT(OUT) :: xx, yy, zz + ! Local variables + REAL (r8) :: a1, b1, pm + REAL (r8) :: sx, sy, sz + + ! Convert to Cartesian coordinates + a1 = TAN(alpha) + b1 = TAN(beta) + + sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) + sx = sz * a1 + sy = sz * b1 + ! Panel assignments + IF (ipanel == 6) THEN + yy = sx; xx = -sy; zz = sz + ELSEIF (ipanel == 5) THEN + yy = sx; xx = sy; zz = -sz + ELSEIF (ipanel == 1) THEN + yy = sx; zz = sy; xx = sz + ELSEIF (ipanel == 3) THEN + yy = -sx; zz = sy; xx = -sz + ELSEIF (ipanel == 2) THEN + xx = -sx; zz = sy; yy = sz + ELSEIF (ipanel == 4) THEN + xx = sx; zz = sy; yy = -sz + ELSE + WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' + WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' + STOP + ENDIF +END SUBROUTINE CubedSphereXYZFromABP + + +SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out) + use shr_kind_mod, only: r8 => shr_kind_r8 + integer, intent(in) :: n_in + integer,dimension(n_in), intent(in) :: f_in + integer, intent(out) :: n_out + integer,dimension(n_in), intent(out) :: f_out + ! + ! local work space + ! + integer :: k,i,j + ! + ! remove duplicates in ipanel_tmp + ! + k = 1 + f_out(1) = f_in(1) + outer: do i=2,n_in + do j=1,k + ! if (f_out(j) == f_in(i)) then + if (ABS(f_out(j)-f_in(i))<1.0E-10) then + ! Found a match so start looking again + cycle outer + end if + end do + ! No match found so add it to the output + k = k + 1 + f_out(k) = f_in(i) + end do outer + n_out = k +END SUBROUTINE remove_duplicates_integer + +SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg) + use shr_kind_mod, only: r8 => shr_kind_r8 + integer, intent(in) :: n_in + real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in + real, intent(in) :: tiny + integer, intent(out) :: n_out + real(r8),dimension(n_in), intent(out) :: lon_out,lat_out + logical :: ldbg + ! + ! local work space + ! + integer :: k,i,j + REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 + REAL (r8), PARAMETER :: pih = 0.50*pi + ! + ! for pole points: make sure the longitudes are identical so that algorithm below works properly + ! + do i=2,n_in + if (abs(lat_in(i)-pih) Date: Sun, 6 Oct 2024 17:30:30 -0700 Subject: [PATCH 02/19] Implement the new orographic drag schemes 1. The new orographic drag schemes is implemented into physics package. It includes nonlinear orographic gravity wave drag (oGWD), flow-blocking drag (FBD), small-scale GWD (sGWD), turbulent orographic form drag (TOFD). The code modifications are in physics, clubb, and control of eam (for input of the new topo file). 2. A new topo file including new topo parameters is input into the model. namelist_defaults_eam.xml is modified to add the new topo file. 3. See #PR 6665 for more info. modified: bld/namelist_files/namelist_defaults_eam.xml modified: src/control/startup_initialconds.F90 modified: src/physics/cam/clubb_intr.F90 modified: src/physics/cam/comsrf.F90 modified: src/physics/cam/gw_common.F90 modified: src/physics/cam/gw_drag.F90 modified: src/physics/cam/hb_diff.F90 modified: src/physics/cam/physics_types.F90 modified: src/physics/cam/physpkg.F90 modified: src/physics/cam/ppgrid.F90 modified: src/physics/clubb/advance_windm_edsclrm_module.F90 [Non-BFB] --- .../namelist_files/namelist_defaults_eam.xml | 2 +- .../eam/src/control/startup_initialconds.F90 | 41 + components/eam/src/physics/cam/clubb_intr.F90 | 125 +- components/eam/src/physics/cam/comsrf.F90 | 44 +- components/eam/src/physics/cam/gw_common.F90 | 1244 +++++++++++++++++ components/eam/src/physics/cam/gw_drag.F90 | 221 ++- components/eam/src/physics/cam/hb_diff.F90 | 118 ++ .../eam/src/physics/cam/physics_types.F90 | 41 +- components/eam/src/physics/cam/physpkg.F90 | 10 +- components/eam/src/physics/cam/ppgrid.F90 | 12 +- .../clubb/advance_windm_edsclrm_module.F90 | 2 +- 11 files changed, 1831 insertions(+), 29 deletions(-) diff --git a/components/eam/bld/namelist_files/namelist_defaults_eam.xml b/components/eam/bld/namelist_files/namelist_defaults_eam.xml index cfd9bf682c8e..1f357767f8b1 100755 --- a/components/eam/bld/namelist_files/namelist_defaults_eam.xml +++ b/components/eam/bld/namelist_files/namelist_defaults_eam.xml @@ -133,7 +133,7 @@ atm/cam/topo/USGS-gtopo30_ne16np4_16xconsistentSGH.c20160612.nc atm/cam/topo/USGS-gtopo30_ne16np4pg2_16xdel2_20200527.nc atm/cam/topo/USGS-gtopo30_ne30np4_16xdel2-PFC-consistentSGH.nc -atm/cam/topo/USGS-gtopo30_ne30np4pg2_x6t-SGH.c20210614.nc +atm/cam/topo/USGS-gtopo30_ne30np4pg2_x6t-SGH_forOroDrag.c20241001.nc atm/cam/topo/USGS-gtopo30_ne30np4pg3_16xdel2.c20200504.nc atm/cam/topo/USGS-gtopo30_ne30np4pg4_16xdel2.c20200504.nc atm/cam/topo/USGS-gtopo30_ne45np4pg2_16xdel2.c20200615.nc diff --git a/components/eam/src/control/startup_initialconds.F90 b/components/eam/src/control/startup_initialconds.F90 index fed4cece6460..6b8b4062f9da 100644 --- a/components/eam/src/control/startup_initialconds.F90 +++ b/components/eam/src/control/startup_initialconds.F90 @@ -5,16 +5,28 @@ module startup_initialconds ! !----------------------------------------------------------------------- +use pio, only: file_desc_t + implicit none private save public :: initial_conds ! Read in initial conditions (dycore dependent) +!added for orographic drag +public topoGWD_file_get_id +public setup_initialGWD +public close_initial_fileGWD +type(file_desc_t), pointer :: ncid_topoGWD !======================================================================= contains !======================================================================= +function topoGWD_file_get_id() + type(file_desc_t), pointer :: topoGWD_file_get_id + topoGWD_file_get_id => ncid_topoGWD +end function topoGWD_file_get_id + subroutine initial_conds(dyn_in) ! This routine does some initializing of buffers that should move to a @@ -62,4 +74,33 @@ end subroutine initial_conds !======================================================================= +subroutine setup_initialGWD() + use filenames, only: bnd_topo + use ioFileMod, only: getfil + use cam_pio_utils, only: cam_pio_openfile + use pio, only: pio_nowrite +! +! Input arguments +! +!----------------------------------------------------------------------- + include 'netcdf.inc' +!----------------------------------------------------------------------- + character(len=256) :: bnd_topo_loc ! filepath of topo file on local disk + allocate(ncid_topoGWD) + call getfil(bnd_topo, bnd_topo_loc) + call cam_pio_openfile(ncid_topoGWD, bnd_topo_loc, PIO_NOWRITE) +end subroutine setup_initialGWD + +subroutine close_initial_fileGWD + use pio, only: pio_closefile + call pio_closefile(ncid_topoGWD) + deallocate(ncid_topoGWD) + nullify(ncid_topoGWD) +end subroutine close_initial_fileGWD +!======================================================================= + + + + + end module startup_initialconds diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index a93331fabdd0..9118c9bb39a9 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -927,7 +927,18 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call addfld ('VMAGDP', horiz_only, 'A', '-', 'ZM gustiness enhancement') call addfld ('VMAGCL', horiz_only, 'A', '-', 'CLUBB gustiness enhancement') call addfld ('TPERTBLT', horiz_only, 'A', 'K', 'perturbation temperature at PBL top') - + !================================== + !!added for TOFD output + call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') + call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') + call addfld ('DUSFC_FD',horiz_only,'A','N/m2','fd zonal oro surface stress') + call addfld ('DVSFC_FD',horiz_only,'A','N/m2','fd merio oro surface stress') + call add_default('DTAUX3_FD', 1, ' ') + call add_default('DTAUY3_FD', 1, ' ') + call add_default('DUSFC_FD', 1, ' ') + call add_default('DVSFC_FD', 1, ' ') + !!added for TOFD output + !===================================== ! Initialize statistics, below are dummy variables dum1 = 300._r8 dum2 = 1200._r8 @@ -1155,7 +1166,11 @@ subroutine clubb_tend_cam( & use model_flags, only: ipdf_call_placement use advance_clubb_core_module, only: ipdf_post_advance_fields #endif - + use gw_common, only: gwdo_gsd,grid_size,pblh_get_level_idx + use hycoef, only: etamid + use physconst, only: rh2o,pi,rearth,r_universal + !!get the znu,znw,p_top set to 0 + use phys_grid, only: get_rlat_all_p implicit none ! --------------- ! @@ -1518,7 +1533,24 @@ subroutine clubb_tend_cam( & real(r8) :: sfc_v_diff_tau(pcols) ! Response to tau perturbation, m/s real(r8), parameter :: pert_tau = 0.1_r8 ! tau perturbation, Pa - + !=========================== + !simply add par + !for z,dz,from other files + real(r8) :: ztop(pcols,pver) ! top interface height asl(m) + real(r8) :: zbot(pcols,pver) ! bottom interface height asl(m) + real(r8) :: zmid(pcols,pver) ! middle interface height asl(m) + real(r8) :: dz(pcols,pver) + real(r8) :: rlat(pcols) ! latitude in radians for columns + integer :: kpbl2d_in(pcols) + real(r8) :: ttgw(pcols,pver) ! temperature tendency + real(r8) :: utgw(pcols,pver) ! zonal wind tendency + real(r8) :: vtgw(pcols,pver) ! meridional wind tendency + real(r8) :: dtaux3_fd(pcols,pver) + real(r8) :: dtauy3_fd(pcols,pver) + real(r8) :: dusfc_fd(pcols) + real(r8) :: dvsfc_fd(pcols) + real(r8) :: dx(pcols),dy(pcols) + !============================== real(r8) :: inv_exner_clubb_surf @@ -1946,7 +1978,73 @@ subroutine clubb_tend_cam( & tautmsx, tautmsy, cam_in%landfrac ) call t_stopf('compute_tms') endif - + ztop= 0.0_r8 ! top interface height asl(m) + zbot= 0.0_r8 ! bottom interface height asl(m) + zmid= 0.0_r8 ! middle interface height asl(m) + dz= 0.0_r8 + kpbl2d_in = -1 + dtaux3_fd= 0.0_r8 + dtauy3_fd= 0.0_r8 + dusfc_fd= 0.0_r8 + dvsfc_fd= 0.0_r8 + !similar as in gw_drag + do k=1,pverp-1 + ! assign values from top + ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) + ! assign values from bottom + zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) + end do + !transform adding the pressure + !transfer from surface to sea level + do k=1,pver + do i=1,ncol + ztop(i,k)=ztop(i,k)+state%phis(i)/gravit + zbot(i,k)=zbot(i,k)+state%phis(i)/gravit + zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit + !dz is from bottom to top already for gw_drag + dz(i,k)=ztop(i,k)-zbot(i,k) + end do + end do + !get the layer index of pblh in layer + kpbl2d_in=0._r8 + do i=1,pcols + kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) + end do + !rlat + call get_rlat_all_p(lchnk, ncol, rlat) + !========================================= + utgw=0._r8 + vtgw=0._r8 + ttgw=0._r8 + dusfc_fd=0._r8 + dvsfc_fd=0._r8 + ! + call grid_size(state,dx,dy) + call gwdo_gsd(& + u3d=state%u(:,pver:1:-1),v3d=state%v(:,pver:1:-1),& + t3d=state%t(:,pver:1:-1),qv3d=state%q(:,pver:1:-1,1),& + p3d=state%pmid(:,pver:1:-1),p3di=state%pint(:,pver+1:1:-1),& + pi3d=state%exner(:,pver:1:-1),z=zbot,& + rublten=utgw(:,pver:1:-1),rvblten=vtgw(:,pver:1:-1),& + rthblten=ttgw(:,pver:1:-1),& + dtaux3d_fd=dtaux3_fd(:,pver:1:-1),dtauy3d_fd=dtauy3_fd(:,pver:1:-1),& + dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& + xland=cam_in%landfrac,br=state%ribulk,& + var2d=sgh30(:ncol),& + znu=etamid(pver:1:-1),dz=dz,pblh=pblh,& + cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,& + dx=dx,dy=dy,& + kpbl2d=kpbl2d_in,itimestep=hdtime,gwd_opt=0,& + ids=1,ide=pcols,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=pcols,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=pcols,jts=0,jte=0,kts=1,kte=pver,& + gwd_ls=0,gwd_bl=0,gwd_ss=0,gwd_fd=1) + !! + call outfld ('DTAUX3_FD', dtaux3_fd, pcols, lchnk) + call outfld ('DTAUY3_FD', dtauy3_fd, pcols, lchnk) + call outfld ('DUSFC_FD', dusfc_fd, pcols, lchnk) + call outfld ('DVSFC_FD', dvsfc_fd, pcols, lchnk) + !! if (micro_do_icesupersat) then call physics_ptend_init(ptend_loc,state%psetcols, 'clubb_ice3', ls=.true., lu=.true., lv=.true., lq=lq) endif @@ -2067,7 +2165,12 @@ subroutine clubb_tend_cam( & dum_core_rknd = real((ksrftms(i)*state1%v(i,pver)), kind = core_rknd) vpwp_sfc = vpwp_sfc-(dum_core_rknd/rho_ds_zm(1)) endif - + !----------------------------------------------------! + !Apply TOFD + !----------------------------------------------------! + !tendency is flipped already + um_forcing(2:pverp)=dtaux3_fd(i,pver:1:-1) + vm_forcing(2:pverp)=dtauy3_fd(i,pver:1:-1) ! Need to flip arrays around for CLUBB core do k=1,pverp um_in(k) = real(um(i,pverp-k+1), kind = core_rknd) @@ -3112,6 +3215,7 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) use ppgrid, only: pver, pcols use constituents, only: cnst_get_ind use camsrfexch, only: cam_in_t + use hb_diff, only: pblintd_ri implicit none @@ -3143,6 +3247,7 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) real(r8) :: kinheat ! kinematic surface heat flux real(r8) :: kinwat ! kinematic surface vapor flux real(r8) :: kbfs ! kinematic surface buoyancy flux + real(r8) :: kbfs_pcol(pcols) integer :: ixq,ixcldliq !PMA fix for thv real(r8) :: rrho ! Inverse air density @@ -3180,7 +3285,15 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) enddo - + !!===== add calculation of ribulk here===== + kbfs_pcol=0.0_r8 + do i=1,ncol + call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & + kinheat, kinwat, kbfs, obklen(i) ) + kbfs_pcol(i)=kbfs + enddo + call pblintd_ri(ncol, thv, state%zm, state%u, state%v, & + ustar, obklen, kbfs_pcol, state%ribulk) return #endif diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index 856cc9d23a67..c916ef661e22 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -17,7 +17,7 @@ module comsrf ! USES: ! use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use ppgrid, only: pcols, begchunk, endchunk + use ppgrid, only: pcols, begchunk, endchunk,nvar_dirOA,nvar_dirOL,indexb use infnan, only: nan, assignment(=) use cam_abortutils, only: endrun @@ -31,6 +31,8 @@ module comsrf ! ! PUBLIC MEMBER FUNCTIONS: ! public initialize_comsrf ! Set the surface temperature and sea-ice fraction + !!added for separate input of ogwd parareters in gw_drag + public initialize_comsrf2 ! ! Public data ! @@ -53,13 +55,17 @@ module comsrf real(r8), allocatable:: prcsnw(:,:) ! cam tot snow precip real(r8), allocatable:: trefmxav(:,:) ! diagnostic: tref max over the day real(r8), allocatable:: trefmnav(:,:) ! diagnostic: tref min over the day - + ! + public var,var30,oc,ol,oadir + real(r8), allocatable:: var(:,:) ! sgh + real(r8), allocatable:: var30(:,:) ! sgh30 + real(r8), allocatable:: oc(:,:) ! Convexity + real(r8), allocatable:: oadir(:,:,:) ! Asymmetry + real(r8), allocatable:: ol(:,:,:) ! Effective length + ! ! Private module data -!=============================================================================== CONTAINS -!=============================================================================== - !====================================================================== ! PUBLIC ROUTINES: Following routines are publically accessable !====================================================================== @@ -134,4 +140,32 @@ subroutine initialize_comsrf end if end subroutine initialize_comsrf + subroutine initialize_comsrf2 + use cam_control_mod, only: ideal_phys, adiabatic +!----------------------------------------------------------------------- +! +! Purpose: +! Initialize surface data +! +! Method: +! +! Author: Mariana Vertenstein +! +!----------------------------------------------------------------------- + integer k,c ! level, constituent indices + + if(.not. (adiabatic .or. ideal_phys)) then + allocate (var(pcols,begchunk:endchunk)) + allocate (var30(pcols,begchunk:endchunk)) + allocate (oc(pcols,begchunk:endchunk)) + allocate (oadir(pcols,nvar_dirOA,begchunk:endchunk)) + allocate (ol(pcols,nvar_dirOL,begchunk:endchunk)) + var(:,:)=nan + var30(:,:)=nan + oc (:,:) = nan + oadir (:,:,:) = nan + ol (:,:,:) = nan + end if + end subroutine initialize_comsrf2 + end module comsrf diff --git a/components/eam/src/physics/cam/gw_common.F90 b/components/eam/src/physics/cam/gw_common.F90 index 86881900e598..989852b00e4f 100644 --- a/components/eam/src/physics/cam/gw_common.F90 +++ b/components/eam/src/physics/cam/gw_common.F90 @@ -5,6 +5,8 @@ module gw_common ! parameterizations. ! use gw_utils, only: r8 +use ppgrid, only: nvar_dirOA,nvar_dirOL!pcols,pver,pverp, +use cam_logfile, only: iulog implicit none private @@ -26,6 +28,7 @@ module gw_common public :: kwv public :: gravit public :: rair +public :: gwdo_gsd,pblh_get_level_idx,grid_size ! This flag preserves answers for vanilla CAM by making a few changes (e.g. ! order of operations) when only orographic waves are on. @@ -741,5 +744,1246 @@ subroutine gw_drag_prof(ncol, ngwv, src_level, tend_level, do_taper, dt, & end if end subroutine gw_drag_prof +!========================================================================== +function pblh_get_level_idx(height_array ,pblheight) +implicit none +real(8),intent(in),dimension(30) :: height_array +real(8),intent(in) :: pblheight +integer :: pblh_get_level_idx + +!local +integer :: i +logical :: found + +pblh_get_level_idx = -1 +found=.False. + +do i = 1, pver + if((pblheight >= height_array(i+1).and.pblheight 300._r8) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10._r8 + ELSE + hpbl2 = za(i,k)+10._r8 + ENDIF + exit + ENDIF + enddo + + if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then + if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then + cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) + cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) + coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) + xlinv(i) = coefm(i) / cleff + govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) + XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) +! + if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then + tauwavex0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" + else + tauwavex0=0._r8 + endif +! + if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then + tauwavey0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" + else + tauwavey0=0._r8 + endif +! + + do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) + utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + enddo + endif + endif + enddo ! end i loop + + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + enddo + enddo + +ENDIF ! end if gsd_gwd_ss == 1 +!================================================================ +!add Beljaars et al. (2004, QJRMS, equ. 16) form drag: +!================================================================ +IF ( (gsd_gwd_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + + utendform=0._r8 + vtendform=0._r8 + zq=0._r8 + + IF ( (gsd_gwd_ss .NE. 1).and.(ss_taper.GT.1.E-02) ) THEN + ! Defining layer height. This is already done above is small-scale GWD is used + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz2(i,k)+zq(i,k) + enddo + enddo + + do k = kts,kte + do i = its,ite + za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) + enddo + enddo + ENDIF + + DO i=its,ite + IF (xland1(i) .gt. 0..and.2._r8*var(i).gt.0) then + a1=0.00026615161_r8*var(i)**2_r8 + a2=a1*0.005363_r8 + DO k=kts,kte + wsp=SQRT(u1(i,k)**2_r8 + v1(i,k)**2_r8) + ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + utendform(i,k)=-0.0759_r8*wsp*u1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + ! + ENDDO + ENDIF + ENDDO + ! + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + !limit drag tendency + !some tendency is likely to even overturn the wind, + !making wind reverse in 1 timestep and reverse again in next, + !this limitation may help to make model stable, + !and no more wind reversal due to drag, + !which is suppose to decelerate, not accelerate + utendform(i,k) = sign(min(abs(utendform(i,k)),abs(u1(i,k))/kdt),utendform(i,k)) + vtendform(i,k) = sign(min(abs(vtendform(i,k)),abs(v1(i,k))/kdt),vtendform(i,k)) + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + enddo + enddo + ENDIF ! end if gsd_gwd_fd == 1 +!======================================================= +! More for the large-scale gwd component +!======================================================= +IF ( (gsd_gwd_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN +! +! now compute vertical structure of the stress. +! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo +! +!determination of the interface height +do i=its,ite +iint=.false. + do k=kpblmin,kte-1 + if (k.gt.kbl(i).and.usqj(1,k)-usqj(1,k-1).lt.0.and.(.not.iint)) then + iint=.true. + zl_hint(i)=zl(i,k+1) + endif + enddo +enddo + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + !we modify the criteria for unstable layer + !that the lv is critical under 0.25 + !while we keep wave breaking ric for + !other larger lv + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& + .or. (velco(i,k) .le. 0.0_r8) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo +! + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then + temv = 1.0_r8 / velco(i,k) + tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv + + ! + ! rim is the minimum-richardson number by shutts (1985) + ! + tem2 = sqrt(usqj(i,k)) + tem = 1._r8 + tem2 * fro + rim = usqj(i,k) * (1._r8-fro) / (tem * tem) + + ! + ! check stability to employ the 'saturation hypothesis' + ! of lindzen (1981) except at tropospheric downstream regions + ! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then + temc = 2.0_r8 + 1.0_r8 / tem2 + hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + ! + ! taup is restricted to monotoncally decrease + ! to avoid unexpected high taup with taup cal + taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) + !add vertical decrease at low level below hint (Kim and Doyle 2005) + !where Ri first decreases + if (k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i)) then + l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2)!-(shr2_xjb(i,kp1)/velco(i,kp1)) + l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2)!-(shr2_xjb(i,k)/velco(i,k)) + taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) + endif + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo +! + + + if(lcap.lt.kte) then + do klcap = lcapp1,kte + + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + +ENDIF !END LARGE-SCALE TAU CALCULATION +!=============================================================== +!COMPUTE BLOCKING COMPONENT +!=============================================================== +IF ( (gsd_gwd_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN + + do i = its,ite + if(.not.ldrag(i)) then +! +!------- determine the height of flow-blocking layer +! + kblk = 0 + pe = 0.0_r8 + + do k = kte, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + !flow block appears within the reference level + !compare potential energy and kinetic energy + !divided by g*ro is to turn del(pa) into height + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) + ke = 0.5_r8*((rcs*u1(i,k))**2._r8+(rcs*v1(i,k))**2._r8) +! +!---------- apply flow-blocking drag when pe >= ke +! + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + if(kblk.ne.0) then +! +!--------- compute flow-blocking stress +! + + !dxmax_ls is different than the usual one + !because the taper is very different + !dxy is a length scale mostly in the direction of the flow to the ridge + !so it is good and not needed for an uneven grid area + !ref Lott and Miller (1997) original scheme + cd = max(2.0_r8-1.0_r8/od(i),0.0_r8) + ! + !tuning of the drag magnitude + ! + cd=ncd*cd + ! + taufb(i,kts) = 0.5_r8 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & + * olp(i) * zblk * ulow(i)**2 + !changed grid box area into dy*dy + tautem = taufb(i,kts)/float(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo + + ! + !----------sum orographic GW stress and flow-blocking stress + ! + !taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now + endif + endif + enddo + +ENDIF ! end blocking drag +!=========================================================== +IF ( (gsd_gwd_ls .EQ. 1 .OR. gsd_gwd_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN + +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,kte + do i = its,ite + taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo + enddo +! +! limit de-acceleration (momentum deposition ) at top to 1/2 value +! the idea is some stuff must go out the 'top' +! + + do klcap = lcap,kte + do i = its,ite + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop + enddo + enddo + +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,ite + if (k .le. kbl(i)) then + if((taud_ls(i,k)+taud_bl(i,k)).ne.0._r8) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo + enddo +! + + do k = kts,kte + do i = its,ite + taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper + !apply limiter for ogwd + !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) + !2.dudt shr_kind_r8 - use ppgrid, only: pcols, pver + use ppgrid, only: pcols,pver,pverp,nvar_dirOA,nvar_dirOL,indexb,begchunk,endchunk + use hycoef, only: hyai, hybi, hyam, hybm, etamid !get the znu,znw,p_top set to 0 use constituents, only: pcnst use physics_types, only: physics_state, physics_ptend, physics_ptend_init use spmd_utils, only: masterproc @@ -33,7 +34,8 @@ module gw_drag use cam_abortutils, only: endrun use ref_pres, only: do_molec_diff, ntop_molec, nbot_molec - use physconst, only: cpair + use physconst, only: cpair,rh2o,zvir,pi,rearth,r_universal + !zvir is the ep1 in wrf,rearth is the radius of earth(m),r_universal is the gas constant ! These are the actual switches for different gravity wave sources. use phys_control, only: use_gw_oro, use_gw_front, use_gw_convect, use_gw_energy_fix @@ -117,7 +119,8 @@ module gw_drag ! namelist logical :: history_amwg ! output the variables used by the AMWG diag package - + integer :: pblh_idx = 0 + ! !========================================================================== contains !========================================================================== @@ -214,7 +217,13 @@ subroutine gw_init() use gw_oro, only: gw_oro_init use gw_front, only: gw_front_init use gw_convect, only: gw_convect_init - + !! + use comsrf, only:var,var30,oc,oadir,ol,initialize_comsrf2 + use pio, only:file_desc_t + use startup_initialconds,only:topoGWD_file_get_id,setup_initialGWD,close_initial_fileGWD + use ncdio_atm, only:infld + use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id,cam_grid_get_dim_names + !! !---------------------------Local storage------------------------------- integer :: l, k @@ -287,7 +296,38 @@ subroutine gw_init() character(len=128) :: errstring !----------------------------------------------------------------------- - + !added for input of ogwd parameters + type(file_desc_t), pointer :: ncid_topoGWD + logical :: found=.false. + character(len=8) :: dim1name, dim2name + character*11 :: subname='gw_init' ! subroutine name + integer :: grid_id + pblh_idx = pbuf_get_index('pblh') + ! + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + !! + call initialize_comsrf2() + call setup_initialGWD() + ncid_topoGWD=>topoGWD_file_get_id() + call infld('SGH' ,ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk,& + endchunk, var, found, gridname='physgrid') + call infld('SGH30',ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk,& + endchunk, var30, found, gridname='physgrid') + call infld('OC', ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk, & + endchunk, oc, found, gridname='physgrid') + !keep the same interval of OA,OL + call infld('OA', ncid_topoGWD,dim1name,'nvar_dirOA',dim2name,1,pcols,1,nvar_dirOA,begchunk, & + endchunk, oadir(:,:,:), found, gridname='physgrid') + call infld('OL', ncid_topoGWD,dim1name,'nvar_dirOL',dim2name,1,pcols,1,nvar_dirOL,begchunk, & + endchunk, ol, found, gridname='physgrid') + if(.not. found) call endrun('ERROR: GWD topo file readerr') + ! + call close_initial_fileGWD() + ! ! Set model flags. do_spectral_waves = (pgwv > 0 .and. (use_gw_front .or. use_gw_convect)) orographic_only = (use_gw_oro .and. .not. do_spectral_waves) @@ -383,6 +423,32 @@ subroutine gw_init() 'Zonal gravity wave surface stress') call addfld ('TAUGWY',horiz_only, 'A','N/m2', & 'Meridional gravity wave surface stress') + !added for orographic drag + call addfld ('DTAUX3_LS',(/'lev'/),'A','m/s2','U tendency - ls orographic drag') + call addfld ('DTAUY3_LS',(/'lev'/),'A','m/s2','V tendency - ls orographic drag') + call addfld ('DTAUX3_BL',(/'lev'/),'A','m/s2','U tendency - bl orographic drag') + call addfld ('DTAUY3_BL',(/'lev'/),'A','m/s2','V tendency - bl orographic drag') + call addfld ('DTAUX3_SS',(/'lev'/),'A','m/s2','U tendency - ss orographic drag') + call addfld ('DTAUY3_SS',(/'lev'/),'A','m/s2','V tendency - ss orographic drag') + call addfld ('DUSFC_LS',horiz_only,'A', 'N/m2', 'ls zonal oro surface stress') + call addfld ('DVSFC_LS',horiz_only,'A', 'N/m2', 'ls merio oro surface stress') + call addfld ('DUSFC_BL',horiz_only,'A', 'N/m2', 'bl zonal oro surface stress') + call addfld ('DVSFC_BL',horiz_only,'A', 'N/m2', 'bl merio oro surface stress') + call addfld ('DUSFC_SS',horiz_only,'A', 'N/m2', 'ss zonal oro surface stress') + call addfld ('DVSFC_SS',horiz_only,'A', 'N/m2', 'ss merio oro surface stress') + call add_default('DTAUX3_LS ', 1,' ') + call add_default('DTAUY3_LS ', 1,' ') + call add_default('DTAUX3_BL ', 1,' ') + call add_default('DTAUY3_BL ', 1,' ') + call add_default('DTAUX3_SS ', 1,' ') + call add_default('DTAUY3_SS ', 1,' ') + call add_default ('DUSFC_LS ', 1,' ') + call add_default ('DVSFC_LS ', 1,' ') + call add_default ('DUSFC_BL ', 1,' ') + call add_default ('DVSFC_BL ', 1,' ') + call add_default ('DUSFC_SS ', 1,' ') + call add_default ('DVSFC_SS ', 1,' ') + !added for orographic drag output if (history_amwg) then call add_default('TAUGWX ', 1, ' ') @@ -589,6 +655,9 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) use gw_front, only: gw_cm_src use gw_convect, only: gw_beres_src use dycore, only: dycore_is + use phys_grid, only: get_rlat_all_p + use gw_common, only: gwdo_gsd,pblh_get_level_idx,grid_size + use physconst, only: gravit,rair !------------------------------Arguments-------------------------------- type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. @@ -598,6 +667,43 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) ! Parameterization net tendencies. type(physics_ptend), intent(out):: ptend type(cam_in_t), intent(in) :: cam_in + !input par + integer :: kpbl2d_in(pcols) + !simply add par + !for z,dz,from other files + real(r8) :: ztop(pcols,pver) ! top interface height asl (m) + real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) + real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) + real(r8) :: dz(pcols,pver) ! model layer height + + !bulk richardson number from hb_diff + !bulk at the surface + !real(r8),parameter :: rino(pcols,nver) + real(r8) :: rlat(pcols) + !locally added gw and bl drag + real(r8) :: dtaux3_ls(pcols,pver) + real(r8) :: dtauy3_ls(pcols,pver) + real(r8) :: dtaux3_bl(pcols,pver) + real(r8) :: dtauy3_bl(pcols,pver) + ! + real(r8) :: dtaux3_ss(pcols,pver) + real(r8) :: dtauy3_ss(pcols,pver) + ! + real(r8) :: dusfc_ls(pcols) + real(r8) :: dvsfc_ls(pcols) + real(r8) :: dusfc_bl(pcols) + real(r8) :: dvsfc_bl(pcols) + ! + real(r8) :: dusfc_ss(pcols) + real(r8) :: dvsfc_ss(pcols) + real(r8) :: g + + real(r8) :: dtaux3_fd(pcols,pver) + real(r8) :: dtauy3_fd(pcols,pver) + real(r8) :: dusfc_fd(pcols) + real(r8) :: dvsfc_fd(pcols) + real(r8), pointer :: pblh(:) + real(r8) :: dx(pcols),dy(pcols) !---------------------------Local storage------------------------------- @@ -894,10 +1000,102 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) effgw_oro, c, kvtt, q, dse, tau, utgw, vtgw, & ttgw, qtgw, taucd, egwdffi, gwut(:,:,0:0), dttdf, dttke) - ! Add the orographic tendencies to the spectrum tendencies - ! Compute the temperature tendency from energy conservation - ! (includes spectrum). + + !--------------------------------------------------------------------- + ! Replaced the basic units with cam's states + !--------------------------------------------------------------------- + !this is for z,dz,dx,dy + !add surface height (surface geopotential/gravity) to convert CAM + !heights based on geopotential above surface into height above sea + !level + !taken from %%module cospsimulator_intr + !CAM is top to surface, which may be opposite in WRF + !fv is same dlat,dlon, so we do it directly + !%%needs to decide which to reverse!!!!!!! + !ztop and zbot are already reversed, start from bottom to top + !dz needs no reverse also + !zmid is different calculation process, + !so it needs reverse if to use + ztop(1:ncol,1:pver)=0._r8 + zbot(1:ncol,1:pver)=0._r8 + zmid(1:ncol,1:pver)=0._r8 + ! + do k=1,pverp-1 + ! assign values from top + ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) + ! assign values from bottom + zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) + end do + !get g + g=gravit + !transform adding the pressure + !transfer from surface to sea level + do k=1,pver + do i=1,ncol + ztop(i,k)=ztop(i,k)+state%phis(i)/g + zbot(i,k)=zbot(i,k)+state%phis(i)/g + zmid(i,k)=state%zm(i,k)+state%phis(i)/g + !dz is from bottom to top already for gw_drag + dz(i,k)=ztop(i,k)-zbot(i,k) + end do + end do + !reverse to keep good format in scheme + ztop=ztop(:,pver:1:-1) + zbot=zbot(:,pver:1:-1) + !get the layer index of pblh in layer + call pbuf_get_field(pbuf, pblh_idx, pblh) + ! + kpbl2d_in=0_r8 + do i=1,pcols + kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/g),pblh(i)) + end do + call get_rlat_all_p(lchnk, ncol, rlat) + !Initialize + utgw=0._r8 + vtgw=0._r8 + ttgw=0._r8 + call grid_size(state,dx,dy) + call gwdo_gsd(& + u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& + qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& + pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& + rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& + dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& + dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& + dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& + dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& + dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& + dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& + xland=cam_in%landfrac,br=state%ribulk(:ncol),& + var2d=state%var(:ncol),& + oc12d=state%oc(:ncol),& + oa2d=state%oadir(:ncol,:),& + ol2d=state%ol(:ncol,:),& + znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& + cp=cpair,g=g,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& + dt=dt,dx=dx,dy=dy,& + kpbl2d=kpbl2d_in,itimestep=dt,gwd_opt=0,& + ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & + gwd_ls=1,gwd_bl=1,gwd_ss=1,gwd_fd=0 ) + ! + call outfld ('DTAUX3_LS', dtaux3_ls, pcols, lchnk) + call outfld ('DTAUY3_LS', dtauy3_ls, pcols, lchnk) + call outfld ('DTAUX3_BL', dtaux3_bl, pcols, lchnk) + call outfld ('DTAUY3_BL', dtauy3_bl, pcols, lchnk) + call outfld ('DTAUX3_SS', dtaux3_ss, pcols, lchnk) + call outfld ('DTAUY3_SS', dtauy3_ss, pcols, lchnk) + call outfld ('DUSFC_LS', dusfc_ls, pcols, lchnk) + call outfld ('DVSFC_LS', dvsfc_ls, pcols, lchnk) + call outfld ('DUSFC_BL', dusfc_bl, pcols, lchnk) + call outfld ('DVSFC_BL', dvsfc_bl, pcols, lchnk) + call outfld ('DUSFC_SS', dusfc_ss, pcols, lchnk) + call outfld ('DVSFC_SS', dvsfc_ss, pcols, lchnk) + ! Add the orographic tendencies to the spectrum tendencies + ! Compute the temperature tendency from energy conservation + ! (includes spectrum). if(.not. use_gw_energy_fix) then !original do k = 1, pver @@ -947,8 +1145,11 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) call outfld('UTGWORO', utgw, ncol, lchnk) call outfld('VTGWORO', vtgw, ncol, lchnk) call outfld('TTGWORO', ttgw, ncol, lchnk) - tau0x = tau(:,0,pver) * xv * effgw_oro - tau0y = tau(:,0,pver) * yv * effgw_oro + !set the GWORO as combination of 3 + tau0x=dusfc_ls+dusfc_bl+dusfc_ss + tau0y=dvsfc_ls+dvsfc_bl+dvsfc_ss + !tau0x = tau(:,0,pver) * xv * effgw_oro + !tau0y = tau(:,0,pver) * yv * effgw_oro call outfld('TAUGWX', tau0x, ncol, lchnk) call outfld('TAUGWY', tau0y, ncol, lchnk) call outfld('SGH ', sgh,pcols, lchnk) diff --git a/components/eam/src/physics/cam/hb_diff.F90 b/components/eam/src/physics/cam/hb_diff.F90 index fdebeb1ee93a..88f0cd8032ae 100644 --- a/components/eam/src/physics/cam/hb_diff.F90 +++ b/components/eam/src/physics/cam/hb_diff.F90 @@ -36,6 +36,8 @@ module hb_diff public init_hb_diff public compute_hb_diff public pblintd + !added for separation calculation of monin-obklen length + public pblintd_ri ! ! PBL limits ! @@ -764,5 +766,121 @@ subroutine austausch_pbl(lchnk ,ncol , & end do return end subroutine austausch_pbl + !=============================================================================== + subroutine pblintd_ri(ncol , & + thv ,z ,u ,v , & + ustar ,obklen ,kbfs ,rino_bulk) + !! + use pbl_utils, only: virtem, calc_ustar, calc_obklen + !! + integer, intent(in) :: ncol ! number of atmospheric columns + + real(r8), intent(in) :: thv(pcols,pver) ! virtual temperature + real(r8), intent(in) :: z(pcols,pver) ! height above surface [m] + real(r8), intent(in) :: u(pcols,pver) ! windspeed x-direction [m/s] + real(r8), intent(in) :: v(pcols,pver) ! windspeed y-direction [m/s] + real(r8), intent(in) :: ustar(pcols) ! surface friction velocity [m/s] + real(r8), intent(in) :: obklen(pcols) ! Obukhov length + real(r8), intent(in) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] + !! + ! Output arguments + ! + real(r8) :: wstar(pcols) ! convective sclae velocity [m/s] + real(r8) :: pblh(pcols) ! boundary-layer height [m] + real(r8) :: bge(pcols) ! buoyancy gradient enhancment + real(r8), intent(out) :: rino_bulk(pcols) ! bulk Richardson no. surface level + !! + !---------------------------Local parameters---------------------------- + ! + real(r8), parameter :: tiny = 1.e-36_r8 ! lower bound for wind magnitude + real(r8), parameter :: fac = 100._r8 ! ustar parameter in height diagnosis + ! + !---------------------------Local workspace----------------------------- + ! + integer :: i ! longitude index + integer :: k ! level index + real(r8) :: phiminv(pcols) ! inverse phi function for momentum + real(r8) :: phihinv(pcols) ! inverse phi function for heat + real(r8) :: rino(pcols,pver) ! bulk Richardson no. from level to ref lev + real(r8) :: tlv(pcols) ! ref. level pot tmp + tmp excess + real(r8) :: vvk ! velocity magnitude squared + + logical :: unstbl(pcols) ! pts w/unstbl pbl (positive virtual ht flx) + logical :: check(pcols) ! True=>chk if Richardson no.>critcal + !! + do i=1,ncol + check(i) = .true. + rino(i,pver) = 0.0_r8 + rino_bulk(i) = 0.0_r8 + pblh(i) = z(i,pver) + end do + ! + ! + ! PBL height calculation: Scan upward until the Richardson number between + ! the first level and the current level exceeds the "critical" value. + ! + do k=pver-1,pver-npbl+1,-1 + do i=1,ncol + if (check(i)) then + vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 + vvk = max(vvk,tiny) + rino(i,k) = g*(thv(i,k) - thv(i,pver))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + if (rino(i,k) >= ricr) then + pblh(i) = z(i,k+1) + (ricr - rino(i,k+1))/(rino(i,k) - rino(i,k+1)) * & + (z(i,k) - z(i,k+1)) + check(i) = .false. + end if + end if + end do + end do + ! + ! Estimate an effective surface temperature to account for surface fluctuations + ! + do i=1,ncol + if (check(i)) pblh(i) = z(i,pverp-npbl) + unstbl(i) = (kbfs(i) > 0._r8) + check(i) = (kbfs(i) > 0._r8) + if (check(i)) then + phiminv(i) = (1._r8 - binm*pblh(i)/obklen(i))**onet + rino(i,pver) = 0.0_r8 + tlv(i) = thv(i,pver) + kbfs(i)*fak/( ustar(i)*phiminv(i) ) + end if + end do + ! + ! Improve pblh estimate for unstable conditions using the convective temperature excess: + ! + do i = 1,ncol + bge(i) = 1.e-8_r8 + end do + do k=pver-1,pver-npbl+1,-1 + do i=1,ncol + if (check(i)) then + vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 + vvk = max(vvk,tiny) + rino(i,k) = g*(thv(i,k) - tlv(i))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + if (rino(i,k) >= ricr) then + pblh(i) = z(i,k+1) + (ricr - rino(i,k+1))/(rino(i,k) - rino(i,k+1))* & + (z(i,k) - z(i,k+1)) + bge(i) = 2._r8*g/(thv(i,k)+thv(i,k+1))*(thv(i,k)-thv(i,k+1))/(z(i,k)-z(i,k+1))*pblh(i) + if (bge(i).lt.0._r8) then + bge(i) = 1.e-8_r8 + endif + check(i) = .false. + end if + end if + end do + end do + ! + !calculate bulk richardson number in the surface layer + ! + do i=1,ncol + vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 + vvk = max(vvk,tiny) + rino_bulk(i)=g*(thv(i,k) - tlv(i))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + enddo + ! + return + end subroutine pblintd_ri + !=============================================================================== end module hb_diff diff --git a/components/eam/src/physics/cam/physics_types.F90 b/components/eam/src/physics/cam/physics_types.F90 index 2b7d78c14618..652d43644d69 100644 --- a/components/eam/src/physics/cam/physics_types.F90 +++ b/components/eam/src/physics/cam/physics_types.F90 @@ -6,7 +6,7 @@ module physics_types use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, psubcols + use ppgrid, only: pcols, pver, psubcols,nvar_dirOA,nvar_dirOL use constituents, only: pcnst, qmin, cnst_name, icldliq, icldice use geopotential, only: geopotential_t use physconst, only: zvir, gravit, cpair, rair, cpairv, rairv @@ -137,7 +137,20 @@ module physics_types cid ! unique column id integer :: ulatcnt, &! number of unique lats in chunk uloncnt ! number of unique lons in chunk - + real(r8), dimension(:),allocatable :: & + var !standard deviation of high-res grid height + real(r8), dimension(:),allocatable :: & + var30 !standard deviation of high-res grid height below 3km + real(r8), dimension(:),allocatable :: & + oc !convexity of high-res grid height + real(r8), dimension(:,:),allocatable :: & + oadir !orographic asymmetry in a coarse grid + real(r8), dimension(:,:),allocatable :: & + ol !orographic length in a coarse grid + real(r8), dimension(:),allocatable :: & + pblh !get plantet boundary layer height + real(r8), dimension(:),allocatable :: & + ribulk end type physics_state !------------------------------------------------------------------------------- @@ -1830,7 +1843,29 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%cid(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid') - + allocate(state%var(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%var') + allocate(state%var30(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%var30') + allocate(state%oc(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%oc') + allocate(state%oadir(psetcols,nvar_dirOA), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%oadir') + allocate(state%ol(psetcols,nvar_dirOL), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ol') + allocate(state%pblh(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pblh') + allocate(state%ribulk(psetcols), stat=ierr) + if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ribulk') + !! + state%var(:)=0.0_r8!inf + state%var30(:)=0.0_r8!inf + state%oc(:)=inf + state%oadir(:,:)=inf + state%ol(:,:)=inf + state%pblh(:)=inf + state%ribulk(:)=0.0_r8!inf + !! state%lat(:) = inf state%lon(:) = inf state%ulat(:) = inf diff --git a/components/eam/src/physics/cam/physpkg.F90 b/components/eam/src/physics/cam/physpkg.F90 index 5ece67252791..72703371f3d8 100644 --- a/components/eam/src/physics/cam/physpkg.F90 +++ b/components/eam/src/physics/cam/physpkg.F90 @@ -1321,7 +1321,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & use cam_diagnostics,only: diag_deallocate, diag_surf - use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds + use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds, var, var30,oc,oadir,ol use physconst, only: stebol, latvap #if ( defined OFFLINE_DYN ) use metdata, only: get_met_srf2 @@ -1432,7 +1432,13 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & call t_startf('diag_surf') call diag_surf(cam_in(c), cam_out(c), phys_state(c)%ps,trefmxav(1,c), trefmnav(1,c)) call t_stopf('diag_surf') - + ! for tranport of ogwd related parameters + phys_state(c)%var(:)=var(:,c) + phys_state(c)%var30(:)=var30(:,c) + phys_state(c)%oc(:)=oc(:,c) + phys_state(c)%oadir(:,:)=oadir(:,:,c) + phys_state(c)%ol(:,:)=ol(:,:,c) + ! call tphysac(ztodt, cam_in(c), & sgh(1,c), sgh30(1,c), cam_out(c), & phys_state(c), phys_tend(c), phys_buffer_chunk, phys_diag(c), & diff --git a/components/eam/src/physics/cam/ppgrid.F90 b/components/eam/src/physics/cam/ppgrid.F90 index 88c5740a3506..8a1779ca3b47 100644 --- a/components/eam/src/physics/cam/ppgrid.F90 +++ b/components/eam/src/physics/cam/ppgrid.F90 @@ -21,7 +21,9 @@ module ppgrid public psubcols public pver public pverp - + public nvar_dirOA + public nvar_dirOL + public indexb ! Grid point resolution parameters @@ -31,6 +33,10 @@ module ppgrid integer psubcols ! number of sub-columns (max) integer pver ! number of vertical levels integer pverp ! pver + 1 + !added for ogwd + integer nvar_dirOA + integer nvar_dirOL + integer indexb #ifdef PPCOLS parameter (pcols = PCOLS) @@ -38,6 +44,10 @@ module ppgrid parameter (psubcols = PSUBCOLS) parameter (pver = PLEV) parameter (pverp = pver + 1 ) + !added for ogwd + parameter (nvar_dirOA =2+1 )!avoid bug when nvar_dirOA is 2 + parameter (nvar_dirOL =180)!set for 360 degrees wind direction + parameter (indexb = 3232)!set for 3km-inputs ! ! start, end indices for chunks owned by a given MPI task ! (set in phys_grid_init). diff --git a/components/eam/src/physics/clubb/advance_windm_edsclrm_module.F90 b/components/eam/src/physics/clubb/advance_windm_edsclrm_module.F90 index 72d2e4d214bd..d4f3dc9c8d09 100644 --- a/components/eam/src/physics/clubb/advance_windm_edsclrm_module.F90 +++ b/components/eam/src/physics/clubb/advance_windm_edsclrm_module.F90 @@ -1572,7 +1572,7 @@ subroutine compute_uv_tndcy( solve_type, fcor, perp_wind_m, perp_wind_g, xm_forc else ! implemented in a host model. - xm_tndcy = 0.0_core_rknd + xm_tndcy(1:gr%nz) = xm_forcing(1:gr%nz) endif From 066ba19a51b288e8a64b370b29395ac52aaa8fc5 Mon Sep 17 00:00:00 2001 From: xie7 Date: Tue, 22 Oct 2024 00:04:25 -0700 Subject: [PATCH 03/19] Add namelist control 1. The new orographic drag schemes are added with namelist variables to turn on/off the schemes in E3SM. 2. The correspondent model files are modified in the namelist defaults. 3. Some bugs are modified. See #PR 6667 for more info. modified: components/eam/bld/build-namelist modified: components/eam/bld/namelist_files/namelist_defaults_eam.xml modified: components/eam/bld/namelist_files/namelist_definition.xml modified: components/eam/src/physics/cam/clubb_intr.F90 modified: components/eam/src/physics/cam/comsrf.F90 modified: components/eam/src/physics/cam/gw_common.F90 modified: components/eam/src/physics/cam/gw_drag.F90 modified: components/eam/src/physics/cam/hb_diff.F90 modified: components/eam/src/physics/cam/phys_control.F90 modified: components/eam/src/physics/cam/physpkg.F90 modified: components/eam/src/physics/cam/ppgrid.F90 [Non-BFB] --- components/eam/bld/build-namelist | 11 + .../namelist_files/namelist_defaults_eam.xml | 8 +- .../namelist_files/namelist_definition.xml | 42 +++ components/eam/src/physics/cam/clubb_intr.F90 | 170 ++++++----- components/eam/src/physics/cam/comsrf.F90 | 2 +- components/eam/src/physics/cam/gw_common.F90 | 272 +++++++++++++----- components/eam/src/physics/cam/gw_drag.F90 | 235 ++++++--------- components/eam/src/physics/cam/hb_diff.F90 | 23 +- .../eam/src/physics/cam/phys_control.F90 | 23 +- components/eam/src/physics/cam/physpkg.F90 | 4 +- components/eam/src/physics/cam/ppgrid.F90 | 3 - 11 files changed, 478 insertions(+), 315 deletions(-) diff --git a/components/eam/bld/build-namelist b/components/eam/bld/build-namelist index 8dc532b6a3df..45179324f776 100755 --- a/components/eam/bld/build-namelist +++ b/components/eam/bld/build-namelist @@ -4089,13 +4089,24 @@ if ($waccm_phys or $cfg->get('nlev') >= 60) { add_default($nl, 'use_gw_oro' , 'val'=>'.true.'); add_default($nl, 'use_gw_front' , 'val'=>'.true.'); add_default($nl, 'use_gw_convect', 'val'=>'.true.'); + add_default($nl, 'use_od_ls', 'val'=>'.false.'); + add_default($nl, 'use_od_bl', 'val'=>'.false.'); + add_default($nl, 'use_od_ss', 'val'=>'.false.'); + add_default($nl, 'use_od_fd', 'val'=>'.false.'); } else { add_default($nl, 'use_gw_oro' , 'val'=>'.true.'); add_default($nl, 'use_gw_front' , 'val'=>'.false.'); add_default($nl, 'use_gw_convect', 'val'=>'.false.'); + add_default($nl, 'use_od_ls', 'val'=>'.false.'); + add_default($nl, 'use_od_bl', 'val'=>'.false.'); + add_default($nl, 'use_od_ss', 'val'=>'.false.'); + add_default($nl, 'use_od_fd', 'val'=>'.false.'); } add_default($nl, 'pgwv', 'val'=>'32'); add_default($nl, 'gw_dc','val'=>'2.5D0'); +add_default($nl, 'ncleff_ls', 'val'=>'3.D0'); +add_default($nl, 'ncd_bl', 'val'=>'3.D0'); +add_default($nl, 'sncleff_ss','val'=>'1.D0'); if ($nl->get_value('use_gw_oro') =~ /$TRUE/io) { add_default($nl, 'effgw_oro'); diff --git a/components/eam/bld/namelist_files/namelist_defaults_eam.xml b/components/eam/bld/namelist_files/namelist_defaults_eam.xml index 1f357767f8b1..4ad34edf4ea1 100755 --- a/components/eam/bld/namelist_files/namelist_defaults_eam.xml +++ b/components/eam/bld/namelist_files/namelist_defaults_eam.xml @@ -126,9 +126,8 @@ atm/cam/topo/USGS-gtopo30_64x128_c050520.nc - -atm/cam/topo/USGS-gtopo30_ne4np4_16x.c20160612.nc -atm/cam/topo/USGS-gtopo30_ne4np4pg2_16x_converted.c20200527.nc +atm/cam/topo/USGS-gtopo30_ne4np4_16x_forOroDrag.c20241019.nc +atm/cam/topo/USGS-gtopo30_ne4np4pg2_16x_converted_forOroDrag.c20241019.nc atm/cam/topo/USGS-gtopo30_ne11np4_16xconsistentSGH.c20160612.nc atm/cam/topo/USGS-gtopo30_ne16np4_16xconsistentSGH.c20160612.nc atm/cam/topo/USGS-gtopo30_ne16np4pg2_16xdel2_20200527.nc @@ -1884,6 +1883,9 @@ with se_tstep, dt_remap_factor, dt_tracer_factor set to -1 1.0 0.375 .true. + 3 + 3 + 1 2.5D0 268.15D0 13.8D0 diff --git a/components/eam/bld/namelist_files/namelist_definition.xml b/components/eam/bld/namelist_files/namelist_definition.xml index 8228c7d8d2e3..b3dc78cb9ed1 100644 --- a/components/eam/bld/namelist_files/namelist_definition.xml +++ b/components/eam/bld/namelist_files/namelist_definition.xml @@ -1078,6 +1078,48 @@ Whether or not to enable GWD brute-force energy fix. Default: set by build-namelist. + +Whether or not to enable nonlinear orographic gravity wave drag (oGWD). +Default: set by build-namelist. + + + +Whether or not to enable flow-blocking drag (FBD). +Default: set by build-namelist. + + + +Whether or not to enable small-scale orographic GWD drag (sGWD). +Default: set by build-namelist. + + + +Whether or not to enable turbulent orographic form drag (TOFD). +Default: set by build-namelist. + + + +Tuning parameter of orographic GWD (oGWD). See use_od_ls. +Default: set by build-namelist. + + + +Tuning parameter of flow-blocking drag (FBD). See use_od_bl. +Default: set by build-namelist. + + + +Tuning parameter of small-scale GWD (sGWD). See use_od_ss. +Default: set by build-namelist. + + Gravity wave spectrum dimension (wave numbers are from -pgwv to pgwv). diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index 9118c9bb39a9..306ee7ca732f 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -20,7 +20,7 @@ module clubb_intr use shr_kind_mod, only: r8=>shr_kind_r8 use shr_log_mod , only: errMsg => shr_log_errMsg use ppgrid, only: pver, pverp - use phys_control, only: phys_getopts + use phys_control, only: phys_getopts,use_od_ss,use_od_fd,ncleff_ls,ncd_bl,sncleff_ss use physconst, only: rair, cpair, gravit, latvap, latice, zvir, rh2o, karman, & tms_orocnst, tms_z0fac, pi use cam_logfile, only: iulog @@ -927,7 +927,6 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call addfld ('VMAGDP', horiz_only, 'A', '-', 'ZM gustiness enhancement') call addfld ('VMAGCL', horiz_only, 'A', '-', 'CLUBB gustiness enhancement') call addfld ('TPERTBLT', horiz_only, 'A', 'K', 'perturbation temperature at PBL top') - !================================== !!added for TOFD output call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') @@ -937,8 +936,6 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call add_default('DTAUY3_FD', 1, ' ') call add_default('DUSFC_FD', 1, ' ') call add_default('DVSFC_FD', 1, ' ') - !!added for TOFD output - !===================================== ! Initialize statistics, below are dummy variables dum1 = 300._r8 dum2 = 1200._r8 @@ -1166,11 +1163,10 @@ subroutine clubb_tend_cam( & use model_flags, only: ipdf_call_placement use advance_clubb_core_module, only: ipdf_post_advance_fields #endif - use gw_common, only: gwdo_gsd,grid_size,pblh_get_level_idx + use gw_common, only: grid_size,gw_oro_interface use hycoef, only: etamid use physconst, only: rh2o,pi,rearth,r_universal !!get the znu,znw,p_top set to 0 - use phys_grid, only: get_rlat_all_p implicit none ! --------------- ! @@ -1533,25 +1529,30 @@ subroutine clubb_tend_cam( & real(r8) :: sfc_v_diff_tau(pcols) ! Response to tau perturbation, m/s real(r8), parameter :: pert_tau = 0.1_r8 ! tau perturbation, Pa - !=========================== - !simply add par - !for z,dz,from other files - real(r8) :: ztop(pcols,pver) ! top interface height asl(m) - real(r8) :: zbot(pcols,pver) ! bottom interface height asl(m) - real(r8) :: zmid(pcols,pver) ! middle interface height asl(m) - real(r8) :: dz(pcols,pver) - real(r8) :: rlat(pcols) ! latitude in radians for columns - integer :: kpbl2d_in(pcols) - real(r8) :: ttgw(pcols,pver) ! temperature tendency - real(r8) :: utgw(pcols,pver) ! zonal wind tendency - real(r8) :: vtgw(pcols,pver) ! meridional wind tendency + !add par for tofd real(r8) :: dtaux3_fd(pcols,pver) real(r8) :: dtauy3_fd(pcols,pver) real(r8) :: dusfc_fd(pcols) real(r8) :: dvsfc_fd(pcols) - real(r8) :: dx(pcols),dy(pcols) - !============================== - + logical :: gwd_ls,gwd_bl,gwd_ss,gwd_fd + real(r8) :: dummy_nm(pcols,pver) + real(r8) :: dummy_utgw(pcols,pver) + real(r8) :: dummy_vtgw(pcols,pver) + real(r8) :: dummy_ttgw(pcols,pver) + ! + real(r8) :: dummx_ls(pcols,pver) + real(r8) :: dummx_bl(pcols,pver) + real(r8) :: dummx_ss(pcols,pver) + real(r8) :: dummy_ls(pcols,pver) + real(r8) :: dummy_bl(pcols,pver) + real(r8) :: dummy_ss(pcols,pver) + real(r8) :: dummx3_ls(pcols,pver) + real(r8) :: dummx3_bl(pcols,pver) + real(r8) :: dummx3_ss(pcols,pver) + real(r8) :: dummy3_ls(pcols,pver) + real(r8) :: dummy3_bl(pcols,pver) + real(r8) :: dummy3_ss(pcols,pver) + ! real(r8) :: inv_exner_clubb_surf @@ -1978,73 +1979,36 @@ subroutine clubb_tend_cam( & tautmsx, tautmsy, cam_in%landfrac ) call t_stopf('compute_tms') endif - ztop= 0.0_r8 ! top interface height asl(m) - zbot= 0.0_r8 ! bottom interface height asl(m) - zmid= 0.0_r8 ! middle interface height asl(m) - dz= 0.0_r8 - kpbl2d_in = -1 - dtaux3_fd= 0.0_r8 - dtauy3_fd= 0.0_r8 - dusfc_fd= 0.0_r8 - dvsfc_fd= 0.0_r8 - !similar as in gw_drag - do k=1,pverp-1 - ! assign values from top - ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) - ! assign values from bottom - zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) - end do - !transform adding the pressure - !transfer from surface to sea level - do k=1,pver - do i=1,ncol - ztop(i,k)=ztop(i,k)+state%phis(i)/gravit - zbot(i,k)=zbot(i,k)+state%phis(i)/gravit - zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit - !dz is from bottom to top already for gw_drag - dz(i,k)=ztop(i,k)-zbot(i,k) - end do - end do - !get the layer index of pblh in layer - kpbl2d_in=0._r8 - do i=1,pcols - kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) - end do - !rlat - call get_rlat_all_p(lchnk, ncol, rlat) - !========================================= - utgw=0._r8 - vtgw=0._r8 - ttgw=0._r8 - dusfc_fd=0._r8 - dvsfc_fd=0._r8 ! - call grid_size(state,dx,dy) - call gwdo_gsd(& - u3d=state%u(:,pver:1:-1),v3d=state%v(:,pver:1:-1),& - t3d=state%t(:,pver:1:-1),qv3d=state%q(:,pver:1:-1,1),& - p3d=state%pmid(:,pver:1:-1),p3di=state%pint(:,pver+1:1:-1),& - pi3d=state%exner(:,pver:1:-1),z=zbot,& - rublten=utgw(:,pver:1:-1),rvblten=vtgw(:,pver:1:-1),& - rthblten=ttgw(:,pver:1:-1),& - dtaux3d_fd=dtaux3_fd(:,pver:1:-1),dtauy3d_fd=dtauy3_fd(:,pver:1:-1),& - dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& - xland=cam_in%landfrac,br=state%ribulk,& - var2d=sgh30(:ncol),& - znu=etamid(pver:1:-1),dz=dz,pblh=pblh,& - cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,& - dx=dx,dy=dy,& - kpbl2d=kpbl2d_in,itimestep=hdtime,gwd_opt=0,& - ids=1,ide=pcols,jds=0,jde=0,kds=1,kde=pver, & - ims=1,ime=pcols,jms=0,jme=0,kms=1,kme=pver, & - its=1,ite=pcols,jts=0,jte=0,kts=1,kte=pver,& - gwd_ls=0,gwd_bl=0,gwd_ss=0,gwd_fd=1) - !! - call outfld ('DTAUX3_FD', dtaux3_fd, pcols, lchnk) + if (use_od_fd) then + gwd_ls=.false. + gwd_bl=.false. + gwd_ss=.false. + gwd_fd=use_od_fd + dummy_nm=0.0_r8 + dummy_utgw=0.0_r8 + dummy_vtgw=0.0_r8 + dummy_ttgw=0.0_r8 + !sgh30 as the input for TOFD instead of sgh + call gw_oro_interface(state,cam_in,sgh30,pbuf,hdtime,dummy_nm,& + gwd_ls,gwd_bl,gwd_ss,gwd_fd,& + ncleff_ls,ncd_bl,sncleff_ss,& + dummy_utgw,dummy_vtgw,dummy_ttgw,& + dtaux3_ls=dummx3_ls,dtauy3_ls=dummy3_ls,& + dtaux3_bl=dummx3_bl,dtauy3_bl=dummy3_bl,& + dtaux3_ss=dummx3_ss,dtauy3_ss=dummy3_ss,& + dtaux3_fd=dtaux3_fd,dtauy3_fd=dtauy3_fd,& + dusfc_ls=dummx_ls,dvsfc_ls=dummy_ls,& + dusfc_bl=dummx_bl,dvsfc_bl=dummy_bl,& + dusfc_ss=dummx_ss,dvsfc_ss=dummy_ss,& + dusfc_fd=dusfc_fd,dvsfc_fd=dvsfc_fd) + ! + call outfld ('DTAUX3_FD', dtaux3_fd, pcols, lchnk) call outfld ('DTAUY3_FD', dtauy3_fd, pcols, lchnk) call outfld ('DUSFC_FD', dusfc_fd, pcols, lchnk) call outfld ('DVSFC_FD', dvsfc_fd, pcols, lchnk) - !! + endif + ! if (micro_do_icesupersat) then call physics_ptend_init(ptend_loc,state%psetcols, 'clubb_ice3', ls=.true., lu=.true., lv=.true., lq=lq) endif @@ -2169,8 +2133,10 @@ subroutine clubb_tend_cam( & !Apply TOFD !----------------------------------------------------! !tendency is flipped already + if (use_od_fd) then um_forcing(2:pverp)=dtaux3_fd(i,pver:1:-1) vm_forcing(2:pverp)=dtauy3_fd(i,pver:1:-1) + endif ! Need to flip arrays around for CLUBB core do k=1,pverp um_in(k) = real(um(i,pverp-k+1), kind = core_rknd) @@ -3211,11 +3177,12 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) !------------------------------------------------------------------------------- use physics_types, only: physics_state - use physconst, only: zvir + use physconst, only: zvir,gravit use ppgrid, only: pver, pcols use constituents, only: cnst_get_ind use camsrfexch, only: cam_in_t - use hb_diff, only: pblintd_ri + use hb_diff, only: pblintd_ri + implicit none @@ -3240,10 +3207,13 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) ! --------------- ! integer :: i ! indicees + integer :: k integer :: ncol ! # of atmospheric columns real(r8) :: th(pcols) ! surface potential temperature real(r8) :: thv(pcols) ! surface virtual potential temperature + real(r8) :: th_lv(pcols,pver) ! level potential temperature + real(r8) :: thv_lv(pcols,pver) ! level virtual potential temperature real(r8) :: kinheat ! kinematic surface heat flux real(r8) :: kinwat ! kinematic surface vapor flux real(r8) :: kbfs ! kinematic surface buoyancy flux @@ -3278,22 +3248,44 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) thv(i) = th(i)*(1._r8+zvir*state%q(i,pver,ixq)) ! diagnose virtual potential temperature end if enddo - + ! do i = 1, ncol call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & rrho, ustar(i) ) call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) enddo - !!===== add calculation of ribulk here===== + ! + if (use_od_ss) then + !add calculation of bulk richardson number here + ! + !compute the whole level th and thv for diagnose of bulk richardson number + thv_lv=0.0_r8 + th_lv=0.0_r8 + ! + do i=1,ncol + do k=1,pver + th_lv(i,k) = state%t(i,k)*state%exner(i,k) + if (use_sgv) then + thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq) & + - state%q(i,k,ixcldliq)) !PMA corrects thv formula + else + thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq)) + end if + enddo + enddo + ! kbfs_pcol=0.0_r8 do i=1,ncol call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) kbfs_pcol(i)=kbfs enddo - call pblintd_ri(ncol, thv, state%zm, state%u, state%v, & + ! + call pblintd_ri(ncol, gravit, thv_lv, state%zm, state%u, state%v, & ustar, obklen, kbfs_pcol, state%ribulk) + endif + ! return #endif diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index c916ef661e22..9d38e117d8d4 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -17,7 +17,7 @@ module comsrf ! USES: ! use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use ppgrid, only: pcols, begchunk, endchunk,nvar_dirOA,nvar_dirOL,indexb + use ppgrid, only: pcols, begchunk, endchunk,nvar_dirOA,nvar_dirOL use infnan, only: nan, assignment(=) use cam_abortutils, only: endrun diff --git a/components/eam/src/physics/cam/gw_common.F90 b/components/eam/src/physics/cam/gw_common.F90 index 989852b00e4f..36a1691f7578 100644 --- a/components/eam/src/physics/cam/gw_common.F90 +++ b/components/eam/src/physics/cam/gw_common.F90 @@ -17,6 +17,7 @@ module gw_common public :: gw_prof public :: momentum_energy_conservation public :: gw_drag_prof +public :: gw_oro_interface public :: pver, pgwv public :: dc @@ -745,9 +746,163 @@ subroutine gw_drag_prof(ncol, ngwv, src_level, tend_level, do_taper, dt, & end subroutine gw_drag_prof !========================================================================== -function pblh_get_level_idx(height_array ,pblheight) +subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, nm,& + gwd_ls, gwd_bl, gwd_ss, gwd_fd,& + ncleff_ls,ncd_bl, sncleff_ss,& + utgw, vtgw, ttgw,& + dtaux3_ls,dtauy3_ls,dtaux3_bl,dtauy3_bl,& + dtaux3_ss,dtauy3_ss,dtaux3_fd,dtauy3_fd,& + dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl,& + dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index + use camsrfexch, only: cam_in_t + use ppgrid, only: pcols,pver,pverp + use physconst, only: gravit,rair,cpair,rh2o,zvir,pi + use hycoef, only: etamid + ! + type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(in) :: sgh(pcols) + type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer + real(r8), intent(in) :: dtime + real(r8), intent(in) :: nm(state%ncol,pver) ! midpoint Brunt-Vaisalla frequency + ! + logical , intent(in) :: gwd_ls + logical , intent(in) :: gwd_bl + logical , intent(in) :: gwd_ss + logical , intent(in) :: gwd_fd + !tunable parameter from namelist + real(r8), intent(in) :: ncleff_ls + real(r8), intent(in) :: ncd_bl + real(r8), intent(in) :: sncleff_ss + ! + real(r8), intent(out), optional :: utgw(state%ncol,pver) + real(r8), intent(out), optional :: vtgw(state%ncol,pver) + real(r8), intent(out), optional :: ttgw(state%ncol,pver) + ! + real(r8), intent(out), optional :: dtaux3_ls(pcols,pver) + real(r8), intent(out), optional :: dtauy3_ls(pcols,pver) + real(r8), intent(out), optional :: dtaux3_bl(pcols,pver) + real(r8), intent(out), optional :: dtauy3_bl(pcols,pver) + real(r8), intent(out), optional :: dtaux3_ss(pcols,pver) + real(r8), intent(out), optional :: dtauy3_ss(pcols,pver) + real(r8), intent(out), optional :: dtaux3_fd(pcols,pver) + real(r8), intent(out), optional :: dtauy3_fd(pcols,pver) + real(r8), intent(out), optional :: dusfc_ls(pcols) + real(r8), intent(out), optional :: dvsfc_ls(pcols) + real(r8), intent(out), optional :: dusfc_bl(pcols) + real(r8), intent(out), optional :: dvsfc_bl(pcols) + real(r8), intent(out), optional :: dusfc_ss(pcols) + real(r8), intent(out), optional :: dvsfc_ss(pcols) + real(r8), intent(out), optional :: dusfc_fd(pcols) + real(r8), intent(out), optional :: dvsfc_fd(pcols) + ! + real(r8) :: ztop(pcols,pver) ! top interface height asl (m) + real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) + real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) + real(r8) :: dz(pcols,pver) ! model layer height + ! + !real(r8) :: g + !pblh input + integer :: pblh_idx = 0 + integer :: kpbl2d_in(pcols) + real(r8), pointer :: pblh(:) + real(r8) :: dx(pcols),dy(pcols) + !needed index + integer :: ncol + integer :: i + integer :: k + !local transfer variables + real(r8) :: dtaux3_ls_local(pcols,pver) + real(r8) :: dtauy3_ls_local(pcols,pver) + real(r8) :: dtaux3_bl_local(pcols,pver) + real(r8) :: dtauy3_bl_local(pcols,pver) + real(r8) :: dtaux3_ss_local(pcols,pver) + real(r8) :: dtauy3_ss_local(pcols,pver) + real(r8) :: dtaux3_fd_local(pcols,pver) + real(r8) :: dtauy3_fd_local(pcols,pver) + real(r8) :: dusfc_ls_local(pcols) + real(r8) :: dvsfc_ls_local(pcols) + real(r8) :: dusfc_bl_local(pcols) + real(r8) :: dvsfc_bl_local(pcols) + real(r8) :: dusfc_ss_local(pcols) + real(r8) :: dvsfc_ss_local(pcols) + real(r8) :: dusfc_fd_local(pcols) + real(r8) :: dvsfc_fd_local(pcols) + + ! + ncol=state%ncol + !convert heights above surface to heights above sea level + !obtain z,dz,dx,dy + !ztop and zbot are already reversed, start from bottom to top + kpbl2d_in=0_r8 + ! + ztop(1:ncol,1:pver)=0._r8 + zbot(1:ncol,1:pver)=0._r8 + zmid(1:ncol,1:pver)=0._r8 + ! + do k=1,pverp-1 + ! assign values for level top/bottom + ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) + zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) + end do + !transform adding the pressure + !transfer from surface to sea level + do k=1,pver + do i=1,ncol + ztop(i,k)=ztop(i,k)+state%phis(i)/gravit + zbot(i,k)=zbot(i,k)+state%phis(i)/gravit + zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit + !dz is from bottom to top already for gw_drag + dz(i,k)=ztop(i,k)-zbot(i,k) + end do + end do + !reverse to keep good format in scheme + ztop=ztop(:,pver:1:-1) + zbot=zbot(:,pver:1:-1) + !get the layer index of pblh in layer for input in drag scheme + pblh_idx = pbuf_get_index('pblh') + call pbuf_get_field(pbuf, pblh_idx, pblh) + do i=1,pcols + kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) + end do + ! + !get grid size for dx,dy + call grid_size(state,dx,dy) + !interface for orographic drag + !if (gwd_fd.eq.0) then + call gwdo_gsd(& + u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& + qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& + pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& + ncleff_ls=ncleff_ls,ncd_bl=ncd_bl,sncleff_ss=sncleff_ss,& + rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& + dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& + dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& + dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& + dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& + dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& + dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& + dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& + dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& + xland=cam_in%landfrac,br=state%ribulk(:ncol),& + var2d=sgh(:ncol),oc12d=state%oc(:ncol),& + oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& + znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& + cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& + dt=dtime,dx=dx,dy=dy,& + kpbl2d=kpbl2d_in,itimestep=dtime,gwd_opt=0,& + ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & + gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) + ! +end subroutine gw_oro_interface +!========================================================================== +function pblh_get_level_idx(height_array,pblheight) implicit none -real(8),intent(in),dimension(30) :: height_array +real(8),intent(in),dimension(pver) :: height_array real(8),intent(in) :: pblheight integer :: pblh_get_level_idx @@ -840,6 +995,7 @@ subroutine grid_size(state, grid_dx, grid_dy) end subroutine grid_size !========================================================================== subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & + ncleff_ls,ncd_bl,sncleff_ss, & rublten,rvblten,rthblten, & dtaux3d_ls,dtauy3d_ls,dtaux3d_bl,dtauy3d_bl, & dtaux3d_ss,dtauy3d_ss,dtaux3d_fd,dtauy3d_fd, & @@ -916,10 +1072,11 @@ subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & t3d, & z, & dz + real(r8), dimension( ims:ime, kms:kme+1 ) ,& + intent(in ) :: p3di + real(r8), intent(in) :: ncleff_ls,ncd_bl,sncleff_ss real(r8), dimension( ims:ime, kms:kme ) , & - intent(in ) :: p3di - real(r8), dimension( ims:ime, kms:kme ) , & - intent(inout) :: rublten, & + optional, intent(inout) :: rublten, & rvblten, & rthblten real(r8), dimension( ims:ime, kms:kme ), optional , & @@ -967,7 +1124,7 @@ subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & real(r8), dimension( its:ite, nvar_dirOA ) :: oa4 real(r8), dimension( its:ite, nvar_dirOL ) :: ol4 integer :: i,j,k,kpblmax - integer , intent(in) :: gwd_ls,gwd_bl,gwd_ss,gwd_fd + logical, intent(in) :: gwd_ls,gwd_bl,gwd_ss,gwd_fd !! do k = kts,kte if(znu(k).gt.0.6_r8) kpblmax = k + 1 @@ -987,8 +1144,7 @@ subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & enddo ! !no need when there is no large drag -IF ( (gwd_ls .EQ. 1).and.(gwd_bl .EQ. 1)) then - +IF (gwd_ls.or.gwd_bl) then do i = its,ite oa4(i,:) = oa2d(i,:) ol4(i,:) = ol2d(i,:) @@ -996,7 +1152,8 @@ subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & ENDIF !================================================================= call gwdo2d(dudt=rublten(ims,kms),dvdt=rvblten(ims,kms) & - ,dthdt=rthblten(ims,kms) & + ,dthdt=rthblten(ims,kms) & + ,ncleff=ncleff_ls,ncd=ncd_bl,sncleff=sncleff_ss & ,dtaux2d_ls=dtaux2d_ls,dtauy2d_ls=dtauy2d_ls & ,dtaux2d_bl=dtaux2d_bl,dtauy2d_bl=dtauy2d_bl & ,dtaux2d_ss=dtaux2d_ss,dtauy2d_ss=dtauy2d_ss & @@ -1026,47 +1183,39 @@ subroutine gwdo_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte & ,gsd_gwd_ls=gwd_ls,gsd_gwd_bl=gwd_bl,gsd_gwd_ss=gwd_ss,gsd_gwd_fd=gwd_fd) !!============================================ -IF ( (gwd_ls .EQ. 1).and.(gwd_bl .EQ. 1)) then do i = its,ite dusfcg_ls(i)=dusfc_ls(i) dvsfcg_ls(i)=dvsfc_ls(i) dusfcg_bl(i)=dusfc_bl(i) dvsfcg_bl(i)=dvsfc_bl(i) + dusfcg_ss(i)=dusfc_ss(i) + dvsfcg_ss(i)=dvsfc_ss(i) + dusfcg_fd(i)=dusfc_fd(i) + dvsfcg_fd(i)=dvsfc_fd(i) enddo - !! + !! dtaux3d_ls=dtaux2d_ls dtaux3d_bl=dtaux2d_bl dtauy3d_ls=dtauy2d_ls dtauy3d_bl=dtauy2d_bl - !! - do i = its,ite - dusfcg_ss(i)=dusfc_ss(i) - dvsfcg_ss(i)=dvsfc_ss(i) - end do - !! dtaux3d_ss=dtaux2d_ss - dtauy3d_ss=dtauy2d_ss -ENDIF -IF (gwd_fd .EQ. 1) then - - do i = its,ite - dusfcg_fd(i)=dusfc_fd(i) - dvsfcg_fd(i)=dvsfc_fd(i) - enddo dtaux3d_fd=dtaux2d_fd + dtauy3d_ss=dtauy2d_ss dtauy3d_fd=dtauy2d_fd -ENDIF end subroutine gwdo_gsd ! !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- - subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & - dtaux2d_bl,dtauy2d_bl,dtaux2d_ss,dtauy2d_ss, & - dtaux2d_fd,dtauy2d_fd,u1,v1,t1,q1, & + subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & + dtaux2d_ls,dtauy2d_ls, & + dtaux2d_bl,dtauy2d_bl, & + dtaux2d_ss,dtauy2d_ss, & + dtaux2d_fd,dtauy2d_fd, & + u1,v1,t1,q1, & del, & prsi,prsl,prslk,zl,rcl, & - xland1,br1,hpbl,bnv_in,dz2, & + xland1,br1,hpbl,bnv_in,dz2, & kpblmax,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd,var,oc1,oa4,ol4,& g,cp,rd,rv,fv,pi,dxmeter,dymeter,deltim,kpbl,kdt,lat, & @@ -1081,11 +1230,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & ! form drag (Beljaars et al.,2004). ! ! Activation of each component is done by specifying the integer-parameters -! (defined below) to 0: inactive or 1: active -! gsd_gwd_ls = 0 or 1: large-scale -! gsd_gwd_bl = 0 or 1: blocking drag -! gsd_gwd_ss = 0 or 1: small-scale gravity wave drag -! gsd_gwd_fd = 0 or 1: topographic form drag +! (defined below) to .true. (active) or .false. (inactive) +! gsd_gwd_ls : large-scale +! gsd_gwd_bl : blocking drag +! gsd_gwd_ss : small-scale gravity wave drag +! gsd_gwd_fd : topographic form drag ! ! ! References: @@ -1134,6 +1283,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & real(r8),intent(in) :: prsi(its:ite,kts:kte+1),del(its:ite,kts:kte) real(r8),intent(in),optional :: oa4(its:ite,nvar_dirOA) real(r8),intent(in),optional :: ol4(its:ite,nvar_dirOL) +! + !variables for open/close process + logical, intent(in) :: gsd_gwd_ls,gsd_gwd_bl,gsd_gwd_ss,gsd_gwd_fd + !tunable parameter in oro_drag_nl, ncleff_ls,ncd_bl,sncleff_ss + real(r8), intent(in) :: ncleff,ncd,sncleff ! ! added for small-scale orographic wave drag ! @@ -1233,23 +1387,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & real(r8) :: olp(its:ite),& od(its:ite) real(r8) :: taufb(its:ite,kts:kte+1) - !variables for open/close process - integer , intent(in) :: gsd_gwd_ls,gsd_gwd_bl,gsd_gwd_ss,gsd_gwd_fd - !tunable parameter - real(r8):: ncleff !!tunable parameter for gwd - real(r8):: ncd !!tunable parameter for fbd - real(r8):: sncleff !!tunable parameter for sgwd !readdata for low-level determination of ogwd real(r8) :: l1,l2,S!,shrrok1,shrrok0,gamma1 logical :: iint real(r8) :: zl_hint(its:ite) ! - !tunable parameter - ! - ncleff = 3._r8 - ncd = 3._r8 - sncleff = 1._r8 - ! !---- constants ! rcs = sqrt(rcl) @@ -1287,6 +1429,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & taub (i) = 0.0_r8 oa1(i) = 0.0_r8 ol(i) = 0.0_r8 + fr(i) = 0.0_r8 ulow (i) = 0.0_r8 dtfac(i) = 1.0_r8 ldrag(i) = .false. @@ -1391,7 +1534,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & enddo ! ! For ls and bl only -IF ((gsd_gwd_ls .EQ. 1).or.(gsd_gwd_bl .EQ. 1)) then +IF (gsd_gwd_ls.or.gsd_gwd_bl) then ! figure out low-level horizontal wind direction ! order into a counterclockwise index instead ! @@ -1443,9 +1586,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & !============================================ ! END INITIALIZATION; BEGIN GWD CALCULATIONS: !============================================ -IF ( ((gsd_gwd_ls .EQ. 1).or.(gsd_gwd_bl .EQ. 1)).and. & - (ls_taper .GT. 1.E-02) ) THEN !==== - +IF (gsd_gwd_ls.or.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02) ) THEN ! !--- saving richardson number in usqj for migwdi ! @@ -1553,11 +1694,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & ! ratio const. use simplified relationship between standard ! deviation & critical hgt ! - do i = its,ite if (.not. ldrag(i)) then - efact = (oa1(i) + 2._r8) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) + !maintain (oa+2) greater than or equal to 0 + efact = max(oa1(i)+2._r8,0._r8) ** (ce*fr(i)/frc) + efact = min(max(efact,efmin),efmax) !!!!!!! cleff (effective grid length) is highly tunable parameter !!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag cleff = sqrt(dxy(i)**2._r8 + dxyp(i)**2._r8) @@ -1568,7 +1709,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & tem = fr(i) * fr(i) * oc1(i) gfobnv = gmax * tem / ((tem + cg)*bnv(i)) !! - if ( gsd_gwd_ls .NE. 0 ) then + if (gsd_gwd_ls) then taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & * ulow(i) * gfobnv * efact else ! We've gotten what we need for the blocking scheme @@ -1581,7 +1722,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & endif enddo -ENDIF ! (gsd_gwd_ls .EQ. 1).or.(gsd_gwd_bl .EQ. 1) +ENDIF ! (gsd_gwd_ls .eq. .true.).or.(gsd_gwd_bl .eq..true.) !========================================================= ! add small-scale wavedrag for stable boundary layer !========================================================= @@ -1593,7 +1734,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & vtendwave=0._r8 zq=0._r8 ! - IF ( (gsd_gwd_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + IF (gsd_gwd_ss.and.(ss_taper.GT.1.E-02)) THEN ! ! declaring potential temperature ! @@ -1683,17 +1824,17 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & enddo enddo -ENDIF ! end if gsd_gwd_ss == 1 +ENDIF ! end if gsd_gwd_ss == .true. !================================================================ !add Beljaars et al. (2004, QJRMS, equ. 16) form drag: !================================================================ -IF ( (gsd_gwd_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN +IF (gsd_gwd_fd.and.(ss_taper.GT.1.E-02) ) THEN utendform=0._r8 vtendform=0._r8 zq=0._r8 - IF ( (gsd_gwd_ss .NE. 1).and.(ss_taper.GT.1.E-02) ) THEN + IF (.not.gsd_gwd_ss.and.(ss_taper.GT.1.E-02) ) THEN ! Defining layer height. This is already done above is small-scale GWD is used do k = kts,kte do i = its,ite @@ -1742,11 +1883,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) enddo enddo - ENDIF ! end if gsd_gwd_fd == 1 + ENDIF ! end if gsd_gwd_fd == .true. !======================================================= ! More for the large-scale gwd component !======================================================= -IF ( (gsd_gwd_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN +IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN ! ! now compute vertical structure of the stress. ! @@ -1845,7 +1986,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & !=============================================================== !COMPUTE BLOCKING COMPONENT !=============================================================== -IF ( (gsd_gwd_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN do i = its,ite if(.not.ldrag(i)) then @@ -1885,7 +2026,6 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & cd = max(2.0_r8-1.0_r8/od(i),0.0_r8) ! !tuning of the drag magnitude - ! cd=ncd*cd ! taufb(i,kts) = 0.5_r8 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & @@ -1906,7 +2046,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & ENDIF ! end blocking drag !=========================================================== -IF ( (gsd_gwd_ls .EQ. 1 .OR. gsd_gwd_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN ! ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy @@ -1951,7 +2091,9 @@ subroutine gwdo2d(dudt,dvdt,dthdt,dtaux2d_ls,dtauy2d_ls, & !apply limiter for ogwd !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) !2.dudt shr_kind_r8 - use ppgrid, only: pcols,pver,pverp,nvar_dirOA,nvar_dirOL,indexb,begchunk,endchunk + use ppgrid, only: pcols,pver,pverp,nvar_dirOA,nvar_dirOL,begchunk,endchunk use hycoef, only: hyai, hybi, hyam, hybm, etamid !get the znu,znw,p_top set to 0 use constituents, only: pcnst use physics_types, only: physics_state, physics_ptend, physics_ptend_init @@ -38,7 +38,7 @@ module gw_drag !zvir is the ep1 in wrf,rearth is the radius of earth(m),r_universal is the gas constant ! These are the actual switches for different gravity wave sources. - use phys_control, only: use_gw_oro, use_gw_front, use_gw_convect, use_gw_energy_fix + use phys_control, only: use_gw_oro, use_gw_front,use_gw_convect,use_gw_energy_fix,use_od_ls,use_od_bl,use_od_ss,ncleff_ls,ncd_bl,sncleff_ss ! Typical module header implicit none @@ -305,6 +305,8 @@ subroutine gw_init() pblh_idx = pbuf_get_index('pblh') ! grid_id = cam_grid_id('physgrid') + ! + if (use_od_ls.or.use_od_bl) then if (.not. cam_grid_check(grid_id)) then call endrun(trim(subname)//': Internal error, no "physgrid" grid') end if @@ -327,6 +329,7 @@ subroutine gw_init() if(.not. found) call endrun('ERROR: GWD topo file readerr') ! call close_initial_fileGWD() + endif ! ! Set model flags. do_spectral_waves = (pgwv > 0 .and. (use_gw_front .or. use_gw_convect)) @@ -402,7 +405,10 @@ subroutine gw_init() errstring) if (trim(errstring) /= "") call endrun("gw_common_init: "//errstring) - if (use_gw_oro) then + if (use_gw_oro.or.& + use_od_ls.or.& + use_od_bl.or.& + use_od_ss) then if (effgw_oro == unset_r8) then call endrun("gw_drag_init: Orographic gravity waves enabled, & @@ -650,13 +656,12 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) ! Location-dependent cpair use physconst, only: cpairv use gw_common, only: gw_prof, momentum_energy_conservation, & - gw_drag_prof + gw_drag_prof,gw_oro_interface use gw_oro, only: gw_oro_src use gw_front, only: gw_cm_src use gw_convect, only: gw_beres_src use dycore, only: dycore_is use phys_grid, only: get_rlat_all_p - use gw_common, only: gwdo_gsd,pblh_get_level_idx,grid_size use physconst, only: gravit,rair !------------------------------Arguments-------------------------------- type(physics_state), intent(in) :: state ! physics state structure @@ -667,43 +672,30 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) ! Parameterization net tendencies. type(physics_ptend), intent(out):: ptend type(cam_in_t), intent(in) :: cam_in - !input par - integer :: kpbl2d_in(pcols) - !simply add par - !for z,dz,from other files - real(r8) :: ztop(pcols,pver) ! top interface height asl (m) - real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) - real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) - real(r8) :: dz(pcols,pver) ! model layer height - - !bulk richardson number from hb_diff - !bulk at the surface - !real(r8),parameter :: rino(pcols,nver) - real(r8) :: rlat(pcols) - !locally added gw and bl drag - real(r8) :: dtaux3_ls(pcols,pver) - real(r8) :: dtauy3_ls(pcols,pver) - real(r8) :: dtaux3_bl(pcols,pver) - real(r8) :: dtauy3_bl(pcols,pver) - ! - real(r8) :: dtaux3_ss(pcols,pver) - real(r8) :: dtauy3_ss(pcols,pver) - ! - real(r8) :: dusfc_ls(pcols) - real(r8) :: dvsfc_ls(pcols) - real(r8) :: dusfc_bl(pcols) - real(r8) :: dvsfc_bl(pcols) - ! - real(r8) :: dusfc_ss(pcols) - real(r8) :: dvsfc_ss(pcols) - real(r8) :: g - - real(r8) :: dtaux3_fd(pcols,pver) - real(r8) :: dtauy3_fd(pcols,pver) - real(r8) :: dusfc_fd(pcols) - real(r8) :: dvsfc_fd(pcols) - real(r8), pointer :: pblh(:) - real(r8) :: dx(pcols),dy(pcols) + !locally added gw and bl drag + real(r8) :: dtaux3_ls(pcols,pver) + real(r8) :: dtauy3_ls(pcols,pver) + real(r8) :: dtaux3_bl(pcols,pver) + real(r8) :: dtauy3_bl(pcols,pver) + real(r8) :: dtaux3_ss(pcols,pver) + real(r8) :: dtauy3_ss(pcols,pver) + real(r8) :: dummx3_fd(pcols,pver) + real(r8) :: dummy3_fd(pcols,pver) + ! + real(r8) :: dusfc_ls(pcols) + real(r8) :: dvsfc_ls(pcols) + real(r8) :: dusfc_bl(pcols) + real(r8) :: dvsfc_bl(pcols) + real(r8) :: dusfc_ss(pcols) + real(r8) :: dvsfc_ss(pcols) + real(r8) :: dummx_fd(pcols) + real(r8) :: dummy_fd(pcols) + ! + real(r8), pointer :: pblh(:) + real(r8) :: dx(pcols),dy(pcols) + ! + logical :: gwd_ls,gwd_bl,gwd_ss,gwd_fd + ! !---------------------------Local storage------------------------------- @@ -985,7 +977,6 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) !--------------------------------------------------------------------- ! Orographic stationary gravity waves !--------------------------------------------------------------------- - ! Determine the orographic wave source call gw_oro_src(ncol, & u, v, t, sgh(:ncol), pmid, pint, dpm, zm, nm, & @@ -999,103 +990,44 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) piln, rhoi, nm, ni, ubm, ubi, xv, yv, & effgw_oro, c, kvtt, q, dse, tau, utgw, vtgw, & ttgw, qtgw, taucd, egwdffi, gwut(:,:,0:0), dttdf, dttke) + endif + ! + if (use_od_ls.or.& + use_od_bl.or.& + use_od_ss) then + !open ogwd,bl,ss, + !close fd + gwd_ls=use_od_ls + gwd_bl=use_od_bl + gwd_ss=use_od_ss + gwd_fd=.false. + ! + utgw=0.0_r8 + vtgw=0.0_r8 + ttgw=0.0_r8 + ! + call gw_oro_interface( state,cam_in,sgh,pbuf,dt,nm,& + gwd_ls,gwd_bl,gwd_ss,gwd_fd,& + ncleff_ls,ncd_bl,sncleff_ss,& + utgw,vtgw,ttgw,& + dtaux3_ls=dtaux3_ls,dtauy3_ls=dtauy3_ls,& + dtaux3_bl=dtaux3_bl,dtauy3_bl=dtauy3_bl,& + dtaux3_ss=dtaux3_ss,dtauy3_ss=dtauy3_ss,& + dtaux3_fd=dummx3_fd,dtauy3_fd=dummy3_fd,& + dusfc_ls=dusfc_ls,dvsfc_ls=dvsfc_ls,& + dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl,& + dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss,& + dusfc_fd=dummx_fd,dvsfc_fd=dummy_fd) - - - !--------------------------------------------------------------------- - ! Replaced the basic units with cam's states - !--------------------------------------------------------------------- - !this is for z,dz,dx,dy - !add surface height (surface geopotential/gravity) to convert CAM - !heights based on geopotential above surface into height above sea - !level - !taken from %%module cospsimulator_intr - !CAM is top to surface, which may be opposite in WRF - !fv is same dlat,dlon, so we do it directly - !%%needs to decide which to reverse!!!!!!! - !ztop and zbot are already reversed, start from bottom to top - !dz needs no reverse also - !zmid is different calculation process, - !so it needs reverse if to use - ztop(1:ncol,1:pver)=0._r8 - zbot(1:ncol,1:pver)=0._r8 - zmid(1:ncol,1:pver)=0._r8 - ! - do k=1,pverp-1 - ! assign values from top - ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) - ! assign values from bottom - zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) - end do - !get g - g=gravit - !transform adding the pressure - !transfer from surface to sea level - do k=1,pver - do i=1,ncol - ztop(i,k)=ztop(i,k)+state%phis(i)/g - zbot(i,k)=zbot(i,k)+state%phis(i)/g - zmid(i,k)=state%zm(i,k)+state%phis(i)/g - !dz is from bottom to top already for gw_drag - dz(i,k)=ztop(i,k)-zbot(i,k) - end do - end do - !reverse to keep good format in scheme - ztop=ztop(:,pver:1:-1) - zbot=zbot(:,pver:1:-1) - !get the layer index of pblh in layer - call pbuf_get_field(pbuf, pblh_idx, pblh) - ! - kpbl2d_in=0_r8 - do i=1,pcols - kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/g),pblh(i)) - end do - call get_rlat_all_p(lchnk, ncol, rlat) - !Initialize - utgw=0._r8 - vtgw=0._r8 - ttgw=0._r8 - call grid_size(state,dx,dy) - call gwdo_gsd(& - u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& - qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& - pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& - rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& - dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& - dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& - dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& - dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& - dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& - dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& - xland=cam_in%landfrac,br=state%ribulk(:ncol),& - var2d=state%var(:ncol),& - oc12d=state%oc(:ncol),& - oa2d=state%oadir(:ncol,:),& - ol2d=state%ol(:ncol,:),& - znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& - cp=cpair,g=g,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& - dt=dt,dx=dx,dy=dy,& - kpbl2d=kpbl2d_in,itimestep=dt,gwd_opt=0,& - ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & - ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & - its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & - gwd_ls=1,gwd_bl=1,gwd_ss=1,gwd_fd=0 ) - ! - call outfld ('DTAUX3_LS', dtaux3_ls, pcols, lchnk) - call outfld ('DTAUY3_LS', dtauy3_ls, pcols, lchnk) - call outfld ('DTAUX3_BL', dtaux3_bl, pcols, lchnk) - call outfld ('DTAUY3_BL', dtauy3_bl, pcols, lchnk) - call outfld ('DTAUX3_SS', dtaux3_ss, pcols, lchnk) - call outfld ('DTAUY3_SS', dtauy3_ss, pcols, lchnk) - call outfld ('DUSFC_LS', dusfc_ls, pcols, lchnk) - call outfld ('DVSFC_LS', dvsfc_ls, pcols, lchnk) - call outfld ('DUSFC_BL', dusfc_bl, pcols, lchnk) - call outfld ('DVSFC_BL', dvsfc_bl, pcols, lchnk) - call outfld ('DUSFC_SS', dusfc_ss, pcols, lchnk) - call outfld ('DVSFC_SS', dvsfc_ss, pcols, lchnk) + endif ! Add the orographic tendencies to the spectrum tendencies ! Compute the temperature tendency from energy conservation ! (includes spectrum). + ! both old and new gwd scheme will add the tendency to circulation + if (use_gw_oro.or. & + use_od_ls.or.& + use_od_bl.or.& + use_od_ss) then if(.not. use_gw_energy_fix) then !original do k = 1, pver @@ -1145,15 +1077,34 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) call outfld('UTGWORO', utgw, ncol, lchnk) call outfld('VTGWORO', vtgw, ncol, lchnk) call outfld('TTGWORO', ttgw, ncol, lchnk) - !set the GWORO as combination of 3 - tau0x=dusfc_ls+dusfc_bl+dusfc_ss - tau0y=dvsfc_ls+dvsfc_bl+dvsfc_ss - !tau0x = tau(:,0,pver) * xv * effgw_oro - !tau0y = tau(:,0,pver) * yv * effgw_oro + ! + if (use_gw_oro) then + !old gwd scheme + tau0x = tau(:,0,pver) * xv * effgw_oro + tau0y = tau(:,0,pver) * yv * effgw_oro call outfld('TAUGWX', tau0x, ncol, lchnk) call outfld('TAUGWY', tau0y, ncol, lchnk) + endif + ! call outfld('SGH ', sgh,pcols, lchnk) - + ! + if (use_od_ls.or.& + use_od_bl.or.& + use_od_ss) then + call outfld ('DTAUX3_LS', dtaux3_ls, pcols, lchnk) + call outfld ('DTAUY3_LS', dtauy3_ls, pcols, lchnk) + call outfld ('DTAUX3_BL', dtaux3_bl, pcols, lchnk) + call outfld ('DTAUY3_BL', dtauy3_bl, pcols, lchnk) + call outfld ('DTAUX3_SS', dtaux3_ss, pcols, lchnk) + call outfld ('DTAUY3_SS', dtauy3_ss, pcols, lchnk) + call outfld ('DUSFC_LS', dusfc_ls, pcols, lchnk) + call outfld ('DVSFC_LS', dvsfc_ls, pcols, lchnk) + call outfld ('DUSFC_BL', dusfc_bl, pcols, lchnk) + call outfld ('DVSFC_BL', dvsfc_bl, pcols, lchnk) + call outfld ('DUSFC_SS', dusfc_ss, pcols, lchnk) + call outfld ('DVSFC_SS', dvsfc_ss, pcols, lchnk) + endif + ! end if ! Convert the tendencies for the dry constituents to dry air basis. diff --git a/components/eam/src/physics/cam/hb_diff.F90 b/components/eam/src/physics/cam/hb_diff.F90 index 88f0cd8032ae..7721cdef4a0b 100644 --- a/components/eam/src/physics/cam/hb_diff.F90 +++ b/components/eam/src/physics/cam/hb_diff.F90 @@ -767,14 +767,14 @@ subroutine austausch_pbl(lchnk ,ncol , & return end subroutine austausch_pbl !=============================================================================== - subroutine pblintd_ri(ncol , & + subroutine pblintd_ri(ncol ,gravit , & thv ,z ,u ,v , & ustar ,obklen ,kbfs ,rino_bulk) !! use pbl_utils, only: virtem, calc_ustar, calc_obklen !! integer, intent(in) :: ncol ! number of atmospheric columns - + real(r8), intent(in) :: gravit real(r8), intent(in) :: thv(pcols,pver) ! virtual temperature real(r8), intent(in) :: z(pcols,pver) ! height above surface [m] real(r8), intent(in) :: u(pcols,pver) ! windspeed x-direction [m/s] @@ -803,16 +803,17 @@ subroutine pblintd_ri(ncol , & real(r8) :: phihinv(pcols) ! inverse phi function for heat real(r8) :: rino(pcols,pver) ! bulk Richardson no. from level to ref lev real(r8) :: tlv(pcols) ! ref. level pot tmp + tmp excess + real(r8) :: tref(pcols) ! ref. level pot tmp real(r8) :: vvk ! velocity magnitude squared - logical :: unstbl(pcols) ! pts w/unstbl pbl (positive virtual ht flx) logical :: check(pcols) ! True=>chk if Richardson no.>critcal - !! + ! do i=1,ncol check(i) = .true. rino(i,pver) = 0.0_r8 rino_bulk(i) = 0.0_r8 pblh(i) = z(i,pver) + tref(i) = thv(i,pver)!if not excess then tref is equal to lowest level thv_lv end do ! ! @@ -824,7 +825,7 @@ subroutine pblintd_ri(ncol , & if (check(i)) then vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 vvk = max(vvk,tiny) - rino(i,k) = g*(thv(i,k) - thv(i,pver))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + rino(i,k) = gravit*(thv(i,k) - thv(i,pver))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) if (rino(i,k) >= ricr) then pblh(i) = z(i,k+1) + (ricr - rino(i,k+1))/(rino(i,k) - rino(i,k+1)) * & (z(i,k) - z(i,k+1)) @@ -844,6 +845,9 @@ subroutine pblintd_ri(ncol , & phiminv(i) = (1._r8 - binm*pblh(i)/obklen(i))**onet rino(i,pver) = 0.0_r8 tlv(i) = thv(i,pver) + kbfs(i)*fak/( ustar(i)*phiminv(i) ) + ! + tref(i) = tlv(i) + ! end if end do ! @@ -857,11 +861,11 @@ subroutine pblintd_ri(ncol , & if (check(i)) then vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 vvk = max(vvk,tiny) - rino(i,k) = g*(thv(i,k) - tlv(i))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + rino(i,k) = gravit*(thv(i,k) - tlv(i))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) if (rino(i,k) >= ricr) then pblh(i) = z(i,k+1) + (ricr - rino(i,k+1))/(rino(i,k) - rino(i,k+1))* & (z(i,k) - z(i,k+1)) - bge(i) = 2._r8*g/(thv(i,k)+thv(i,k+1))*(thv(i,k)-thv(i,k+1))/(z(i,k)-z(i,k+1))*pblh(i) + bge(i) = 2._r8*gravit/(thv(i,k)+thv(i,k+1))*(thv(i,k)-thv(i,k+1))/(z(i,k)-z(i,k+1))*pblh(i) if (bge(i).lt.0._r8) then bge(i) = 1.e-8_r8 endif @@ -872,11 +876,12 @@ subroutine pblintd_ri(ncol , & end do ! !calculate bulk richardson number in the surface layer + !following Holstag and Boville (1993) equation (2.8) ! do i=1,ncol - vvk = (u(i,k) - u(i,pver))**2 + (v(i,k) - v(i,pver))**2 + fac*ustar(i)**2 + vvk = u(i,pver)**2 + v(i,pver)**2 + fac*ustar(i)**2 vvk = max(vvk,tiny) - rino_bulk(i)=g*(thv(i,k) - tlv(i))*(z(i,k)-z(i,pver))/(thv(i,pver)*vvk) + rino_bulk(i)=gravit*(thv(i,pver) - tref(i))*z(i,pver)/(thv(i,pver)*vvk) enddo ! return diff --git a/components/eam/src/physics/cam/phys_control.F90 b/components/eam/src/physics/cam/phys_control.F90 index b7c9b37fa817..400cbf31ea44 100644 --- a/components/eam/src/physics/cam/phys_control.F90 +++ b/components/eam/src/physics/cam/phys_control.F90 @@ -175,7 +175,17 @@ module phys_control !additional diagnostics switch logical, public, protected :: print_additional_diagn_phys_control = .false. - +!additional flags and tuning parameters for orographic drags, +!including orographic gravity wave drag (oGWD),flow-blocking drag (FBD), +!small-scale GWD drag (sGWD), turbulent orographic form drag (TOFD). +logical, public, protected :: use_od_ls = .false. +logical, public, protected :: use_od_bl = .false. +logical, public, protected :: use_od_ss = .false. +logical, public, protected :: use_od_fd = .false. +real(r8),public, protected :: ncleff_ls = 3._r8 !tunable parameter for oGWD +real(r8),public, protected :: ncd_bl = 3._r8 !tunable parameter for FBD +real(r8),public, protected :: sncleff_ss= 1._r8 !tunable parameter for sGWD +! ! Switches that turn on/off individual parameterizations. ! ! Comment by Hui Wan (PNNL, 2014-12): @@ -248,6 +258,8 @@ subroutine phys_ctl_readnl(nlfile) print_fixer_message, & use_hetfrz_classnuc, use_gw_oro, use_gw_front, use_gw_convect, & use_gw_energy_fix, & + use_od_ls,use_od_bl,use_od_ss,use_od_fd,& + ncleff_ls,ncd_bl,sncleff_ss,& cld_macmic_num_steps, micro_do_icesupersat, & fix_g1_err_ndrop, ssalt_tuning, resus_fix, convproc_do_aer, & convproc_do_gas, convproc_method_activate, liqcf_fix, regen_fix, demott_ice_nuc, pergro_mods, pergro_test_active, & @@ -366,7 +378,14 @@ subroutine phys_ctl_readnl(nlfile) call mpibcast(use_gw_oro, 1 , mpilog, 0, mpicom) call mpibcast(use_gw_front, 1 , mpilog, 0, mpicom) call mpibcast(use_gw_convect, 1 , mpilog, 0, mpicom) - call mpibcast(use_gw_energy_fix, 1 , mpilog, 0, mpicom) + call mpibcast(use_gw_energy_fix, 1 , mpilog, 0, mpicom) + call mpibcast(use_od_ls, 1 , mpilog, 0, mpicom) + call mpibcast(use_od_bl, 1 , mpilog, 0, mpicom) + call mpibcast(use_od_ss, 1 , mpilog, 0, mpicom) + call mpibcast(use_od_fd, 1 , mpilog, 0, mpicom) + call mpibcast(ncleff_ls, 1 , mpilog, 0, mpicom) + call mpibcast(ncd_bl, 1 , mpilog, 0, mpicom) + call mpibcast(sncleff_ss, 1 , mpilog, 0, mpicom) call mpibcast(fix_g1_err_ndrop, 1 , mpilog, 0, mpicom) call mpibcast(ssalt_tuning, 1 , mpilog, 0, mpicom) call mpibcast(resus_fix, 1 , mpilog, 0, mpicom) diff --git a/components/eam/src/physics/cam/physpkg.F90 b/components/eam/src/physics/cam/physpkg.F90 index 72703371f3d8..50ce79e15405 100644 --- a/components/eam/src/physics/cam/physpkg.F90 +++ b/components/eam/src/physics/cam/physpkg.F90 @@ -1329,7 +1329,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & use time_manager, only: get_nstep, is_first_step, is_end_curr_month, & is_first_restart_step, is_last_step use check_energy, only: ieflx_gmean, check_ieflx_fix - use phys_control, only: ieflx_opt + use phys_control, only: ieflx_opt,use_od_ls,use_od_bl use co2_diagnostics,only: get_total_carbon, print_global_carbon_diags, & co2_diags_store_fields, co2_diags_read_fields use co2_cycle, only: co2_transport @@ -1433,11 +1433,13 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & call diag_surf(cam_in(c), cam_out(c), phys_state(c)%ps,trefmxav(1,c), trefmnav(1,c)) call t_stopf('diag_surf') ! for tranport of ogwd related parameters + if (use_od_ls.or.use_od_bl) then phys_state(c)%var(:)=var(:,c) phys_state(c)%var30(:)=var30(:,c) phys_state(c)%oc(:)=oc(:,c) phys_state(c)%oadir(:,:)=oadir(:,:,c) phys_state(c)%ol(:,:)=ol(:,:,c) + endif ! call tphysac(ztodt, cam_in(c), & sgh(1,c), sgh30(1,c), cam_out(c), & diff --git a/components/eam/src/physics/cam/ppgrid.F90 b/components/eam/src/physics/cam/ppgrid.F90 index 8a1779ca3b47..8ef5d205703b 100644 --- a/components/eam/src/physics/cam/ppgrid.F90 +++ b/components/eam/src/physics/cam/ppgrid.F90 @@ -23,7 +23,6 @@ module ppgrid public pverp public nvar_dirOA public nvar_dirOL - public indexb ! Grid point resolution parameters @@ -36,7 +35,6 @@ module ppgrid !added for ogwd integer nvar_dirOA integer nvar_dirOL - integer indexb #ifdef PPCOLS parameter (pcols = PCOLS) @@ -47,7 +45,6 @@ module ppgrid !added for ogwd parameter (nvar_dirOA =2+1 )!avoid bug when nvar_dirOA is 2 parameter (nvar_dirOL =180)!set for 360 degrees wind direction - parameter (indexb = 3232)!set for 3km-inputs ! ! start, end indices for chunks owned by a given MPI task ! (set in phys_grid_init). From 0738be8799bad20be045df2c6532976589a0b473 Mon Sep 17 00:00:00 2001 From: xie7 Date: Mon, 4 Nov 2024 15:38:49 -0600 Subject: [PATCH 04/19] Modified the code and added orodrag development suite. 1. The code is modified for better format according to comments. 2. A new development suite for the new orographic drag schemes is added to the code. modified: ../../../../../cime_config/tests.py new file: ../../../cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam modified: clubb_intr.F90 modified: comsrf.F90 modified: gw_common.F90 modified: gw_drag.F90 modified: physpkg.F90 modified: ../../../tools/topo_tool/orographic_drag_toolkit/make.ncl [BFB] --- cime_config/tests.py | 15 +- .../testmods_dirs/eam/orodrag/user_nl_eam | 6 + components/eam/src/physics/cam/clubb_intr.F90 | 37 +- components/eam/src/physics/cam/comsrf.F90 | 18 +- components/eam/src/physics/cam/gw_common.F90 | 2338 +++++++++-------- components/eam/src/physics/cam/gw_drag.F90 | 57 +- components/eam/src/physics/cam/physpkg.F90 | 14 +- .../orographic_drag_toolkit/make.ncl | 19 +- 8 files changed, 1313 insertions(+), 1191 deletions(-) create mode 100644 components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam diff --git a/cime_config/tests.py b/cime_config/tests.py index 1cbf28b83974..e2ab71f0c53f 100644 --- a/cime_config/tests.py +++ b/cime_config/tests.py @@ -176,7 +176,7 @@ ) }, - "e3sm_p3_developer" : { + "e3sm_p3_developer" : { "tests" : ( "ERP.ne4pg2_oQU480.F2010.eam-p3", "REP_Ln5.ne4pg2_oQU480.F2010.eam-p3", @@ -188,6 +188,19 @@ "ERS.ne4pg2_oQU480.F2010.eam-p3" ) }, + + "e3sm_orodrag_developer" : { + "tests" : ( + "ERP.ne4pg2_oQU480.F2010.eam-orodrag", + "REP_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", + "PET.ne4pg2_oQU480.F2010.eam-orodrag", + "PEM_Ln18.ne4pg2_oQU480.F2010.eam-orodrag", + "SMS_Ln5.ne30pg2_EC30to60E2r2.F2010.eam-orodrag", + "SMS_D_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", + "SMS_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", + "ERS.ne4pg2_oQU480.F2010.eam-orodrag" + ) + }, "e3sm_atm_integration" : { "inherit" : ("eam_preqx", "eam_theta"), diff --git a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam new file mode 100644 index 000000000000..e14e93f8374c --- /dev/null +++ b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam @@ -0,0 +1,6 @@ +use_gw_oro=.false. +use_od_ls=.true. +use_od_bl=.true. +use_od_ss=.true. +use_od_fd=.true. + diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index 306ee7ca732f..c9c3bcdfa2ca 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -631,7 +631,8 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) use constituents, only: cnst_get_ind use phys_control, only: phys_getopts - use parameters_tunable, only: params_list + use parameters_tunable, only: params_list + use cam_abortutils, only: endrun #endif @@ -927,6 +928,8 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call addfld ('VMAGDP', horiz_only, 'A', '-', 'ZM gustiness enhancement') call addfld ('VMAGCL', horiz_only, 'A', '-', 'CLUBB gustiness enhancement') call addfld ('TPERTBLT', horiz_only, 'A', 'K', 'perturbation temperature at PBL top') + ! + if (use_od_fd) then !!added for TOFD output call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') @@ -936,6 +939,16 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call add_default('DTAUY3_FD', 1, ' ') call add_default('DUSFC_FD', 1, ' ') call add_default('DVSFC_FD', 1, ' ') + if (masterproc) then + write(iulog,*)'Using turbulent orographic form drag scheme (TOFD)' + end if + ! + if (use_od_fd.and.do_tms) then + call endrun("clubb_intr: Both TMS and TOFD are turned on, please turn one off& + &by setting use_od_fd or do_tms as .false.") + end if + ! + end if ! Initialize statistics, below are dummy variables dum1 = 300._r8 dum2 = 1200._r8 @@ -1166,7 +1179,6 @@ subroutine clubb_tend_cam( & use gw_common, only: grid_size,gw_oro_interface use hycoef, only: etamid use physconst, only: rh2o,pi,rearth,r_universal - !!get the znu,znw,p_top set to 0 implicit none ! --------------- ! @@ -3217,7 +3229,7 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) real(r8) :: kinheat ! kinematic surface heat flux real(r8) :: kinwat ! kinematic surface vapor flux real(r8) :: kbfs ! kinematic surface buoyancy flux - real(r8) :: kbfs_pcol(pcols) + real(r8) :: kbfs_pcol(pcols) ! kinematic surface buoyancy flux stored for all pcols integer :: ixq,ixcldliq !PMA fix for thv real(r8) :: rrho ! Inverse air density @@ -3248,44 +3260,49 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) thv(i) = th(i)*(1._r8+zvir*state%q(i,pver,ixq)) ! diagnose virtual potential temperature end if enddo - ! + do i = 1, ncol call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), & rrho, ustar(i) ) call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) enddo - ! + if (use_od_ss) then !add calculation of bulk richardson number here ! !compute the whole level th and thv for diagnose of bulk richardson number thv_lv=0.0_r8 th_lv=0.0_r8 - ! + + !use the same virtual potential temperature formula as above (thv) except for all vertical levels + !used for bulk richardson number below in pblintd_ri do i=1,ncol do k=1,pver th_lv(i,k) = state%t(i,k)*state%exner(i,k) if (use_sgv) then thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq) & - - state%q(i,k,ixcldliq)) !PMA corrects thv formula + - state%q(i,k,ixcldliq)) else thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq)) end if enddo enddo - ! + + !recalculate the kbfs stored in kbfs_pcol for bulk richardson number in pblintd_ri kbfs_pcol=0.0_r8 do i=1,ncol + call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), rrho, ustar(i) ) call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) kbfs_pcol(i)=kbfs enddo - ! + + !calculate the bulk richardson number call pblintd_ri(ncol, gravit, thv_lv, state%zm, state%u, state%v, & ustar, obklen, kbfs_pcol, state%ribulk) endif - ! + return #endif diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index 9d38e117d8d4..02ddbbb1e84b 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -155,16 +155,16 @@ subroutine initialize_comsrf2 integer k,c ! level, constituent indices if(.not. (adiabatic .or. ideal_phys)) then - allocate (var(pcols,begchunk:endchunk)) - allocate (var30(pcols,begchunk:endchunk)) - allocate (oc(pcols,begchunk:endchunk)) - allocate (oadir(pcols,nvar_dirOA,begchunk:endchunk)) - allocate (ol(pcols,nvar_dirOL,begchunk:endchunk)) - var(:,:)=nan - var30(:,:)=nan - oc (:,:) = nan + allocate (var (pcols,begchunk:endchunk)) + allocate (var30 (pcols,begchunk:endchunk)) + allocate (oc (pcols,begchunk:endchunk)) + allocate (oadir (pcols,nvar_dirOA,begchunk:endchunk)) + allocate (ol (pcols,nvar_dirOL,begchunk:endchunk)) + var (:,:) = nan + var30 (:,:) = nan + oc (:,:) = nan oadir (:,:,:) = nan - ol (:,:,:) = nan + ol (:,:,:) = nan end if end subroutine initialize_comsrf2 diff --git a/components/eam/src/physics/cam/gw_common.F90 b/components/eam/src/physics/cam/gw_common.F90 index 36a1691f7578..98743b2b8471 100644 --- a/components/eam/src/physics/cam/gw_common.F90 +++ b/components/eam/src/physics/cam/gw_common.F90 @@ -745,7 +745,9 @@ subroutine gw_drag_prof(ncol, ngwv, src_level, tend_level, do_taper, dt, & end if end subroutine gw_drag_prof + !========================================================================== + subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, nm,& gwd_ls, gwd_bl, gwd_ss, gwd_fd,& ncleff_ls,ncd_bl, sncleff_ss,& @@ -760,14 +762,14 @@ subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, n use ppgrid, only: pcols,pver,pverp use physconst, only: gravit,rair,cpair,rh2o,zvir,pi use hycoef, only: etamid - ! + type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. type(cam_in_t), intent(in) :: cam_in real(r8), intent(in) :: sgh(pcols) type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer real(r8), intent(in) :: dtime real(r8), intent(in) :: nm(state%ncol,pver) ! midpoint Brunt-Vaisalla frequency - ! + !options for the 4 schemes logical , intent(in) :: gwd_ls logical , intent(in) :: gwd_bl logical , intent(in) :: gwd_ss @@ -776,11 +778,11 @@ subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, n real(r8), intent(in) :: ncleff_ls real(r8), intent(in) :: ncd_bl real(r8), intent(in) :: sncleff_ss - ! + !vertical profile of the momentum tendencies real(r8), intent(out), optional :: utgw(state%ncol,pver) real(r8), intent(out), optional :: vtgw(state%ncol,pver) real(r8), intent(out), optional :: ttgw(state%ncol,pver) - ! + !output drag terms in 3D and surface real(r8), intent(out), optional :: dtaux3_ls(pcols,pver) real(r8), intent(out), optional :: dtauy3_ls(pcols,pver) real(r8), intent(out), optional :: dtaux3_bl(pcols,pver) @@ -807,157 +809,165 @@ subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, n !pblh input integer :: pblh_idx = 0 integer :: kpbl2d_in(pcols) + integer :: kpbl2d_reverse_in(pcols) real(r8), pointer :: pblh(:) real(r8) :: dx(pcols),dy(pcols) !needed index integer :: ncol integer :: i integer :: k - !local transfer variables - real(r8) :: dtaux3_ls_local(pcols,pver) - real(r8) :: dtauy3_ls_local(pcols,pver) - real(r8) :: dtaux3_bl_local(pcols,pver) - real(r8) :: dtauy3_bl_local(pcols,pver) - real(r8) :: dtaux3_ss_local(pcols,pver) - real(r8) :: dtauy3_ss_local(pcols,pver) - real(r8) :: dtaux3_fd_local(pcols,pver) - real(r8) :: dtauy3_fd_local(pcols,pver) - real(r8) :: dusfc_ls_local(pcols) - real(r8) :: dvsfc_ls_local(pcols) - real(r8) :: dusfc_bl_local(pcols) - real(r8) :: dvsfc_bl_local(pcols) - real(r8) :: dusfc_ss_local(pcols) - real(r8) :: dvsfc_ss_local(pcols) - real(r8) :: dusfc_fd_local(pcols) - real(r8) :: dvsfc_fd_local(pcols) - - ! - ncol=state%ncol - !convert heights above surface to heights above sea level - !obtain z,dz,dx,dy - !ztop and zbot are already reversed, start from bottom to top - kpbl2d_in=0_r8 - ! - ztop(1:ncol,1:pver)=0._r8 - zbot(1:ncol,1:pver)=0._r8 - zmid(1:ncol,1:pver)=0._r8 - ! - do k=1,pverp-1 - ! assign values for level top/bottom - ztop(1:ncol,k)=state%zi(1:ncol,pverp-k) - zbot(1:ncol,k)=state%zi(1:ncol,pverp-k+1) - end do - !transform adding the pressure - !transfer from surface to sea level - do k=1,pver - do i=1,ncol - ztop(i,k)=ztop(i,k)+state%phis(i)/gravit - zbot(i,k)=zbot(i,k)+state%phis(i)/gravit - zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit - !dz is from bottom to top already for gw_drag - dz(i,k)=ztop(i,k)-zbot(i,k) - end do - end do - !reverse to keep good format in scheme - ztop=ztop(:,pver:1:-1) - zbot=zbot(:,pver:1:-1) - !get the layer index of pblh in layer for input in drag scheme - pblh_idx = pbuf_get_index('pblh') - call pbuf_get_field(pbuf, pblh_idx, pblh) - do i=1,pcols - kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) - end do - ! - !get grid size for dx,dy - call grid_size(state,dx,dy) - !interface for orographic drag - !if (gwd_fd.eq.0) then - call gwdo_gsd(& - u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& - qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& - pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& - ncleff_ls=ncleff_ls,ncd_bl=ncd_bl,sncleff_ss=sncleff_ss,& - rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& - dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& - dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& - dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& - dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& - dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& - dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& - dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& - dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& - xland=cam_in%landfrac,br=state%ribulk(:ncol),& - var2d=sgh(:ncol),oc12d=state%oc(:ncol),& - oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& - znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& - cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& - dt=dtime,dx=dx,dy=dy,& - kpbl2d=kpbl2d_in,itimestep=dtime,gwd_opt=0,& - ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & - ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & - its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & - gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) - ! + + ncol=state%ncol + !convert heights above surface to heights above sea level + !obtain z,dz,dx,dy,and k for pblh + kpbl2d_in=0_r8 + kpbl2d_reverse_in=0_r8 + ztop=0._r8 + zbot=0._r8 + zmid=0._r8 + dusfc_ls=0._r8 + dvsfc_ls=0._r8 + dusfc_bl=0._r8 + dvsfc_bl=0._r8 + dusfc_ss=0._r8 + dvsfc_ss=0._r8 + dusfc_fd=0._r8 + dvsfc_fd=0._r8 + dtaux3_ls=0._r8 + dtaux3_bl=0._r8 + dtauy3_ls=0._r8 + dtauy3_bl=0._r8 + dtaux3_ss=0._r8 + dtaux3_fd=0._r8 + dtauy3_ss=0._r8 + dtauy3_fd=0._r8 + + do k=1,pver + do i=1,ncol + ! assign values for level top/bottom + ztop(i,k)=state%zi(i,k) + zbot(i,k)=state%zi(i,k+1) + enddo + end do + + !transform adding the pressure + !transfer from surface to sea level + do k=1,pver + do i=1,ncol + ztop(i,k)=ztop(i,k)+state%phis(i)/gravit + zbot(i,k)=zbot(i,k)+state%phis(i)/gravit + zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit + !dz is from bottom to top already for gw_drag + dz(i,k)=ztop(i,k)-zbot(i,k) + end do + end do + !get the layer index of pblh in layer for input in drag scheme + pblh_idx = pbuf_get_index('pblh') + call pbuf_get_field(pbuf, pblh_idx, pblh) + do i=1,pcols + kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) + kpbl2d_reverse_in(i)=pverp-kpbl2d_in(i)!pverp-k + end do + + !get grid size for dx,dy + call grid_size(state,dx,dy) + !interface for orographic drag + call gwdo_gsd(& + u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& + qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& + pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& + ncleff_ls=ncleff_ls,ncd_bl=ncd_bl,sncleff_ss=sncleff_ss,& + rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& + dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& + dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& + dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& + dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& + dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& + dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& + dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& + dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& + xland=cam_in%landfrac,br=state%ribulk(:ncol),& + var2d=sgh(:ncol),oc12d=state%oc(:ncol),& + oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& + znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& + cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& + dt=dtime,dx=dx,dy=dy,& + kpbl2d=kpbl2d_reverse_in,gwd_opt=0,& + ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & + gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) + end subroutine gw_oro_interface + !========================================================================== + function pblh_get_level_idx(height_array,pblheight) -implicit none -real(8),intent(in),dimension(pver) :: height_array -real(8),intent(in) :: pblheight -integer :: pblh_get_level_idx - -!local -integer :: i -logical :: found - -pblh_get_level_idx = -1 -found=.False. - -do i = 1, pver - if((pblheight >= height_array(i+1).and.pblheight = height_array(k+1).and.pblheight 300._r8) then - kpbl2 = k - IF (k == kpbl(i)) then - hpbl2 = hpbl(i)+10._r8 - ELSE - hpbl2 = za(i,k)+10._r8 - ENDIF - exit - ENDIF - enddo - - if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then - if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then - cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) - cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) - coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) - xlinv(i) = coefm(i) / cleff - govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) - XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) -! - if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then - tauwavex0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) - tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" - else - tauwavex0=0._r8 - endif -! - if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then - tauwavey0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) - tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" - else - tauwavey0=0._r8 - endif -! + do i=its,ite + hpbl2 = hpbl(i)+10._r8 + kpbl2 = kpbl(i) + kvar = 1 + do k=kts+1,MAX(kpbl(i),kts+1) + IF (za(i,k)>300._r8) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10._r8 + ELSE + hpbl2 = za(i,k)+10._r8 + ENDIF + exit + ENDIF + enddo - do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) - utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - enddo - endif - endif - enddo ! end i loop + if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then + if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then + cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) + cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) + coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) + xlinv(i) = coefm(i) / cleff + govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) + XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) + + if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then + tauwavex0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" + else + tauwavex0=0._r8 + endif - do k = kts,kte - do i = its,ite - dudt(i,k) = dudt(i,k) + utendwave(i,k) - dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) - dtaux2d_ss(i,k) = utendwave(i,k) - dtauy2d_ss(i,k) = vtendwave(i,k) - dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) - dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) - enddo + if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then + tauwavey0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" + else + tauwavey0=0._r8 + endif + + do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) + utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + enddo + endif + endif + enddo ! end i loop + + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) enddo + enddo -ENDIF ! end if gsd_gwd_ss == .true. -!================================================================ -!add Beljaars et al. (2004, QJRMS, equ. 16) form drag: -!================================================================ -IF (gsd_gwd_fd.and.(ss_taper.GT.1.E-02) ) THEN + ENDIF ! end if gsd_gwd_ss == .true. + !================================================================ + !add Beljaars et al. (2004, QJRMS, equ. 16) form drag: + !================================================================ + IF (gsd_gwd_fd.and.(ss_taper.GT.1.E-02) ) THEN - utendform=0._r8 - vtendform=0._r8 - zq=0._r8 + utendform=0._r8 + vtendform=0._r8 + zq=0._r8 - IF (.not.gsd_gwd_ss.and.(ss_taper.GT.1.E-02) ) THEN + IF (.not.gsd_gwd_ss.and.(ss_taper.GT.1.E-02) ) THEN ! Defining layer height. This is already done above is small-scale GWD is used do k = kts,kte do i = its,ite @@ -1847,152 +1927,156 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) enddo enddo - ENDIF + ENDIF - DO i=its,ite + DO i=its,ite IF (xland1(i) .gt. 0..and.2._r8*var(i).gt.0) then - a1=0.00026615161_r8*var(i)**2_r8 - a2=a1*0.005363_r8 - DO k=kts,kte - wsp=SQRT(u1(i,k)**2_r8 + v1(i,k)**2_r8) - ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - utendform(i,k)=-0.0759_r8*wsp*u1(i,k)* & - EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper - vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & - EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper - ! + a1=0.00026615161_r8*var(i)**2_r8 + a2=a1*0.005363_r8 + DO k=kts,kte + wsp=SQRT(u1(i,k)**2_r8 + v1(i,k)**2_r8) + ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + utendform(i,k)=-0.0759_r8*wsp*u1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + ! ENDDO ENDIF - ENDDO - ! - do k = kts,kte + ENDDO + + do k = kts,kte do i = its,ite - dudt(i,k) = dudt(i,k) + utendform(i,k) - dvdt(i,k) = dvdt(i,k) + vtendform(i,k) - !limit drag tendency - !some tendency is likely to even overturn the wind, - !making wind reverse in 1 timestep and reverse again in next, - !this limitation may help to make model stable, - !and no more wind reversal due to drag, - !which is suppose to decelerate, not accelerate - utendform(i,k) = sign(min(abs(utendform(i,k)),abs(u1(i,k))/kdt),utendform(i,k)) - vtendform(i,k) = sign(min(abs(vtendform(i,k)),abs(v1(i,k))/kdt),vtendform(i,k)) - dtaux2d_fd(i,k) = utendform(i,k) - dtauy2d_fd(i,k) = vtendform(i,k) - dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) - dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + !limit drag tendency + !some tendency is likely to even overturn the wind, + !making wind reverse in 1 timestep and reverse again in next, + !this limitation may help to make model stable, + !and no more wind reversal due to drag, + !which is suppose to decelerate, not accelerate + utendform(i,k) = sign(min(abs(utendform(i,k)),abs(u1(i,k))/deltim),utendform(i,k)) + vtendform(i,k) = sign(min(abs(vtendform(i,k)),abs(v1(i,k))/deltim),vtendform(i,k)) + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) enddo enddo ENDIF ! end if gsd_gwd_fd == .true. -!======================================================= -! More for the large-scale gwd component -!======================================================= -IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN -! -! now compute vertical structure of the stress. -! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo -! -!determination of the interface height -do i=its,ite -iint=.false. - do k=kpblmin,kte-1 - if (k.gt.kbl(i).and.usqj(1,k)-usqj(1,k-1).lt.0.and.(.not.iint)) then - iint=.true. - zl_hint(i)=zl(i,k+1) + !======================================================= + ! More for the large-scale gwd component + !======================================================= + IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN + ! + ! now compute vertical structure of the stress. + ! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo + + if (scorer_on) then + ! + !determination of the interface height for scorer adjustment + ! + do i=its,ite + iint=.false. + do k=kpblmin,kte-1 + if (k.gt.kbl(i).and.usqj(i,k)-usqj(i,k-1).lt.0.and.(.not.iint)) then + iint=.true. + zl_hint(i)=zl(i,k+1) endif - enddo -enddo - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite -! -! unstablelayer if ri < ric -! unstable layer if upper air vel comp along surf vel <=0 (crit lay) -! at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - !we modify the criteria for unstable layer - !that the lv is critical under 0.25 - !while we keep wave breaking ric for - !other larger lv - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& - .or. (velco(i,k) .le. 0.0_r8) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif enddo -! - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then - temv = 1.0_r8 / velco(i,k) - tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv - - ! - ! rim is the minimum-richardson number by shutts (1985) - ! - tem2 = sqrt(usqj(i,k)) - tem = 1._r8 + tem2 * fro - rim = usqj(i,k) * (1._r8-fro) / (tem * tem) - - ! - ! check stability to employ the 'saturation hypothesis' - ! of lindzen (1981) except at tropospheric downstream regions - ! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then - temc = 2.0_r8 + 1.0_r8 / tem2 - hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - ! - ! taup is restricted to monotoncally decrease - ! to avoid unexpected high taup with taup cal - taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) - !add vertical decrease at low level below hint (Kim and Doyle 2005) - !where Ri first decreases - if (k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i)) then - l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2)!-(shr2_xjb(i,kp1)/velco(i,kp1)) - l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2)!-(shr2_xjb(i,k)/velco(i,k)) - taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) - endif + enddo + endif + + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite + ! + ! unstablelayer if ri < ric + ! unstable layer if upper air vel comp along surf vel <=0 (crit lay) + ! at (u-c)=0. crit layer exists and bit vector should be set (.le.) + ! + if (k .ge. kbl(i)) then + !we modify the criteria for unstable layer + !that the lv is critical under 0.25 + !while we keep wave breaking ric for + !other larger lv + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& + .or. (velco(i,k) .le. 0.0_r8) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo + + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then + temv = 1.0_r8 / velco(i,k) + tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv + ! + ! rim is the minimum-richardson number by shutts (1985) + ! + tem2 = sqrt(usqj(i,k)) + tem = 1._r8 + tem2 * fro + rim = usqj(i,k) * (1._r8-fro) / (tem * tem) + + ! + ! check stability to employ the 'saturation hypothesis' + ! of lindzen (1981) except at tropospheric downstream regions + ! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then + temc = 2.0_r8 + 1.0_r8 / tem2 + hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + ! + ! taup is restricted to monotoncally decrease + ! to avoid unexpected high taup in calculation + ! + taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) + ! + ! add vertical decrease at low level below hint (Kim and Doyle 2005) + ! where Ri first decreases + ! + if (scorer_on.and.k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i).and.k.lt.kte-1) then + l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2) + l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2) + taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) endif endif - enddo - enddo -! - - - if(lcap.lt.kte) then - do klcap = lcapp1,kte + endif + enddo + enddo - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo + if(lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) enddo - endif + enddo + endif -ENDIF !END LARGE-SCALE TAU CALCULATION -!=============================================================== -!COMPUTE BLOCKING COMPONENT -!=============================================================== -IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN + ENDIF !END LARGE-SCALE TAU CALCULATION + !=============================================================== + !COMPUTE BLOCKING COMPONENT + !=============================================================== + IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN - do i = its,ite - if(.not.ldrag(i)) then -! -!------- determine the height of flow-blocking layer -! + do i = its,ite + if(.not.ldrag(i)) then + ! + !------- determine the height of flow-blocking layer + ! kblk = 0 pe = 0.0_r8 @@ -2003,9 +2087,9 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & !divided by g*ro is to turn del(pa) into height pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) ke = 0.5_r8*((rcs*u1(i,k))**2._r8+(rcs*v1(i,k))**2._r8) -! -!---------- apply flow-blocking drag when pe >= ke -! + ! + !---------- apply flow-blocking drag when pe >= ke + ! if(pe.ge.ke) then kblk = k kblk = min(kblk,kbl(i)) @@ -2013,10 +2097,11 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & endif endif enddo + if(kblk.ne.0) then -! -!--------- compute flow-blocking stress -! + ! + !--------- compute flow-blocking stress + ! !dxmax_ls is different than the usual one !because the taper is very different @@ -2041,26 +2126,26 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & ! !taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now endif - endif - enddo + endif + enddo -ENDIF ! end blocking drag + ENDIF ! end blocking drag !=========================================================== -IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN + IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN + ! + ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy + ! -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! do k = kts,kte do i = its,ite taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) enddo enddo -! -! limit de-acceleration (momentum deposition ) at top to 1/2 value -! the idea is some stuff must go out the 'top' -! + ! + ! limit de-acceleration (momentum deposition ) at top to 1/2 value + ! the idea is some stuff must go out the 'top' + ! do klcap = lcap,kte do i = its,ite @@ -2068,12 +2153,12 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & taud_bl(i,klcap) = taud_bl(i,klcap) * factop enddo enddo - -! -! if the gravity wave drag would force a critical line -! in the lower ksmm1 layers during the next deltim timestep, -! then only apply drag until that critical line is reached. -! + + ! + ! if the gravity wave drag would force a critical line + ! in the lower ksmm1 layers during the next deltim timestep, + ! then only apply drag until that critical line is reached. + ! do k = kts,kpblmax-1 do i = its,ite if (k .le. kbl(i)) then @@ -2083,7 +2168,6 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & endif enddo enddo -! do k = kts,kte do i = its,ite @@ -2092,7 +2176,7 @@ subroutine gwdo2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) !2.dudt shr_kind_r8 - use ppgrid, only: pcols,pver,pverp,nvar_dirOA,nvar_dirOL,begchunk,endchunk - use hycoef, only: hyai, hybi, hyam, hybm, etamid !get the znu,znw,p_top set to 0 + use ppgrid, only: pcols, pver, pverp, nvar_dirOA, nvar_dirOL, begchunk, endchunk + use hycoef, only: hyai, hybi, hyam, hybm, etamid use constituents, only: pcnst use physics_types, only: physics_state, physics_ptend, physics_ptend_init use spmd_utils, only: masterproc use cam_history, only: outfld, hist_fld_active use cam_logfile, only: iulog - use cam_abortutils, only: endrun + use cam_abortutils,only: endrun use ref_pres, only: do_molec_diff, ntop_molec, nbot_molec - use physconst, only: cpair,rh2o,zvir,pi,rearth,r_universal - !zvir is the ep1 in wrf,rearth is the radius of earth(m),r_universal is the gas constant + use physconst, only: cpair, rh2o, zvir, pi, rearth, r_universal!zvir is the ep1 in wrf,rearth is the radius of earth(m),r_universal is the gas constant ! These are the actual switches for different gravity wave sources. - use phys_control, only: use_gw_oro, use_gw_front,use_gw_convect,use_gw_energy_fix,use_od_ls,use_od_bl,use_od_ss,ncleff_ls,ncd_bl,sncleff_ss + ! The orographic control switches are also here + use phys_control, only: use_gw_oro, use_gw_front, use_gw_convect, use_gw_energy_fix, use_od_ls, use_od_bl, use_od_ss, ncleff_ls, ncd_bl, sncleff_ss ! Typical module header implicit none @@ -217,13 +217,13 @@ subroutine gw_init() use gw_oro, only: gw_oro_init use gw_front, only: gw_front_init use gw_convect, only: gw_convect_init - !! - use comsrf, only:var,var30,oc,oadir,ol,initialize_comsrf2 - use pio, only:file_desc_t - use startup_initialconds,only:topoGWD_file_get_id,setup_initialGWD,close_initial_fileGWD - use ncdio_atm, only:infld - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id,cam_grid_get_dim_names - !! + + use comsrf, only: var, var30, oc, oadir, ol, initialize_comsrf2 + use pio, only: file_desc_t + use startup_initialconds,only: topoGWD_file_get_id, setup_initialGWD, close_initial_fileGWD + use ncdio_atm, only: infld + use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id,cam_grid_get_dim_names + !---------------------------Local storage------------------------------- integer :: l, k @@ -409,12 +409,17 @@ subroutine gw_init() use_od_ls.or.& use_od_bl.or.& use_od_ss) then - - if (effgw_oro == unset_r8) then + ! + if (use_gw_oro.and.effgw_oro == unset_r8) then call endrun("gw_drag_init: Orographic gravity waves enabled, & &but effgw_oro was not set.") end if - + ! + if (use_gw_oro.and.use_od_ls) then + call endrun("gw_drag_init: Both orographic gravity waves schemes are turned on, & + &please turn one off by setting use_gw_oro or use_od_ls as .false.") + end if + ! call gw_oro_init(errstring) if (trim(errstring) /= "") call endrun("gw_oro_init: "//errstring) @@ -429,6 +434,9 @@ subroutine gw_init() 'Zonal gravity wave surface stress') call addfld ('TAUGWY',horiz_only, 'A','N/m2', & 'Meridional gravity wave surface stress') + if (use_od_ls.or.& + use_od_bl.or.& + use_od_ss) then !added for orographic drag call addfld ('DTAUX3_LS',(/'lev'/),'A','m/s2','U tendency - ls orographic drag') call addfld ('DTAUY3_LS',(/'lev'/),'A','m/s2','V tendency - ls orographic drag') @@ -455,6 +463,7 @@ subroutine gw_init() call add_default ('DUSFC_SS ', 1,' ') call add_default ('DVSFC_SS ', 1,' ') !added for orographic drag output + endif if (history_amwg) then call add_default('TAUGWX ', 1, ' ') @@ -1020,13 +1029,15 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) dusfc_fd=dummx_fd,dvsfc_fd=dummy_fd) endif + ! ! Add the orographic tendencies to the spectrum tendencies ! Compute the temperature tendency from energy conservation ! (includes spectrum). ! both old and new gwd scheme will add the tendency to circulation - if (use_gw_oro.or. & - use_od_ls.or.& - use_od_bl.or.& + ! + if (use_gw_oro.or.& + use_od_ls .or.& + use_od_bl .or.& use_od_ss) then if(.not. use_gw_energy_fix) then !original @@ -1036,11 +1047,11 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) vtgw(:,k) = vtgw(:,k) * cam_in%landfrac(:ncol) ptend%v(:ncol,k) = ptend%v(:ncol,k) + vtgw(:,k) ptend%s(:ncol,k) = ptend%s(:ncol,k) + ttgw(:,k) & - -(ptend%u(:ncol,k) * (u(:,k) + ptend%u(:ncol,k)*0.5_r8*dt) & - +ptend%v(:ncol,k) * (v(:,k) + ptend%v(:ncol,k)*0.5_r8*dt)) + -(ptend%u(:ncol,k) * (u(:,k) + ptend%u(:ncol,k)*0.5_r8*dt) & + +ptend%v(:ncol,k) * (v(:,k) + ptend%v(:ncol,k)*0.5_r8*dt)) ttgw(:,k) = ttgw(:,k) & - -(ptend%u(:ncol,k) * (u(:,k) + ptend%u(:ncol,k)*0.5_r8*dt) & - +ptend%v(:ncol,k) * (v(:,k) + ptend%v(:ncol,k)*0.5_r8*dt)) + -(ptend%u(:ncol,k) * (u(:,k) + ptend%u(:ncol,k)*0.5_r8*dt) & + +ptend%v(:ncol,k) * (v(:,k) + ptend%v(:ncol,k)*0.5_r8*dt)) ttgw(:,k) = ttgw(:,k) / cpairv(:ncol, k, lchnk) end do else diff --git a/components/eam/src/physics/cam/physpkg.F90 b/components/eam/src/physics/cam/physpkg.F90 index 50ce79e15405..b2e231d3f179 100644 --- a/components/eam/src/physics/cam/physpkg.F90 +++ b/components/eam/src/physics/cam/physpkg.F90 @@ -1321,7 +1321,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & use cam_diagnostics,only: diag_deallocate, diag_surf - use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds, var, var30,oc,oadir,ol + use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds, var, var30, oc, oadir, ol use physconst, only: stebol, latvap #if ( defined OFFLINE_DYN ) use metdata, only: get_met_srf2 @@ -1433,12 +1433,12 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & call diag_surf(cam_in(c), cam_out(c), phys_state(c)%ps,trefmxav(1,c), trefmnav(1,c)) call t_stopf('diag_surf') ! for tranport of ogwd related parameters - if (use_od_ls.or.use_od_bl) then - phys_state(c)%var(:)=var(:,c) - phys_state(c)%var30(:)=var30(:,c) - phys_state(c)%oc(:)=oc(:,c) - phys_state(c)%oadir(:,:)=oadir(:,:,c) - phys_state(c)%ol(:,:)=ol(:,:,c) + if ( use_od_ls .or. use_od_bl ) then + phys_state(c)%var (:) =var (:,c) + phys_state(c)%var30(:) =var30 (:,c) + phys_state(c)%oc (:) =oc (:,c) + phys_state(c)%oadir(:,:) =oadir (:,:,c) + phys_state(c)%ol (:,:) =ol (:,:,c) endif ! call tphysac(ztodt, cam_in(c), & diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl b/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl index d79fc234bebf..f36183d66e83 100755 --- a/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl +++ b/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl @@ -1,21 +1,10 @@ -load "/lcrc/group/e3sm/ac.xie7/Analysis/NCLep/self.ncl" begin -vars=(/"PHIS","SGH","SGH30","LANDFRAC","LANDM_COSLAT"/) ;; -fil1="final-180-ne30pg2-mod-v3.nc" -;fil2="USGS-gtopo30_ne30np4pg2_16xdel2.c20200108.nc" -;fil3="final-180-ne30pg2.nc" +fil1="USGS-gtopo30_ne30np4pg2_16xdel2_forOroDrag.c20241029.nc" fil2="USGS-gtopo30_ne30np4pg2_x6t-SGH.c20210614.nc" -fil3="final-180-ne30pg2-v3.nc" +fil3="final-180.nc" system("rm -r "+fil1) -system("cp -r "+fil3+" "+fil1) +system("cp -r "+fil2+" "+fil1) +system("ncks -A -v OA,OC,OL "+fil3+" "+fil1) ;; -ff1=addfile(fil1,"w") -ff2=addfile(fil2,"r") -;; -do i=0,4 -ff1->$vars(i)$=ff2->$vars(i)$ -end do - - end From 245ddc307f802a872f86504324d420b6720d86bc Mon Sep 17 00:00:00 2001 From: xie7 Date: Fri, 8 Nov 2024 20:15:43 -0800 Subject: [PATCH 05/19] Edit some variables in model 1.Make changes in model. modified: components/eam/src/physics/cam/comsrf.F90 modified: components/eam/src/physics/cam/gw_drag.F90 modified: components/eam/src/physics/cam/physics_types.F90 modified: components/eam/src/physics/cam/physpkg.F90 --- components/eam/bld/build-namelist | 6 +- .../namelist_files/namelist_definition.xml | 6 +- .../eam/src/control/startup_initialconds.F90 | 34 +- components/eam/src/physics/cam/clubb_intr.F90 | 4 +- components/eam/src/physics/cam/comsrf.F90 | 16 +- components/eam/src/physics/cam/gw_common.F90 | 1471 +-------- components/eam/src/physics/cam/gw_drag.F90 | 69 +- components/eam/src/physics/cam/od_common.F90 | 1497 +++++++++ .../eam/src/physics/cam/phys_control.F90 | 14 +- .../eam/src/physics/cam/physics_types.F90 | 12 - components/eam/src/physics/cam/physpkg.F90 | 4 +- .../clubb/advance_windm_edsclrm_module.F90 | 11 +- .../orographic_drag_toolkit/Makefile | 106 - .../topo_tool/orographic_drag_toolkit/README | 18 - .../Tempest-remap_generation.sh | 13 - .../cube_to_target.F90 | 2550 ---------------- .../orographic_drag_toolkit/make.ncl | 10 - .../orographic_drag_toolkit/ogwd_sub.F90 | 900 ------ .../orographic_drag_toolkit/reconstruct.F90 | 2675 ----------------- .../orographic_drag_toolkit/remap.F90 | 1562 ---------- .../topo_tool/orographic_drag_toolkit/run.sh | 6 - .../orographic_drag_toolkit/shr_kind_mod.F90 | 20 - .../orographic_drag_toolkit/transform.F90 | 351 --- 23 files changed, 1578 insertions(+), 9777 deletions(-) create mode 100644 components/eam/src/physics/cam/od_common.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/Makefile delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/README delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/Tempest-remap_generation.sh delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/cube_to_target.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/reconstruct.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/run.sh delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/shr_kind_mod.F90 delete mode 100755 components/eam/tools/topo_tool/orographic_drag_toolkit/transform.F90 diff --git a/components/eam/bld/build-namelist b/components/eam/bld/build-namelist index 45179324f776..293a03cdf3a4 100755 --- a/components/eam/bld/build-namelist +++ b/components/eam/bld/build-namelist @@ -4104,9 +4104,9 @@ if ($waccm_phys or $cfg->get('nlev') >= 60) { } add_default($nl, 'pgwv', 'val'=>'32'); add_default($nl, 'gw_dc','val'=>'2.5D0'); -add_default($nl, 'ncleff_ls', 'val'=>'3.D0'); -add_default($nl, 'ncd_bl', 'val'=>'3.D0'); -add_default($nl, 'sncleff_ss','val'=>'1.D0'); +add_default($nl, 'od_ls_ncleff ','val'=>'3.D0'); +add_default($nl, 'od_bl_ncd ','val'=>'3.D0'); +add_default($nl, 'od_ss_sncleff','val'=>'1.D0'); if ($nl->get_value('use_gw_oro') =~ /$TRUE/io) { add_default($nl, 'effgw_oro'); diff --git a/components/eam/bld/namelist_files/namelist_definition.xml b/components/eam/bld/namelist_files/namelist_definition.xml index b3dc78cb9ed1..93960ae115a7 100644 --- a/components/eam/bld/namelist_files/namelist_definition.xml +++ b/components/eam/bld/namelist_files/namelist_definition.xml @@ -1102,19 +1102,19 @@ Whether or not to enable turbulent orographic form drag (TOFD). Default: set by build-namelist. - Tuning parameter of orographic GWD (oGWD). See use_od_ls. Default: set by build-namelist. - Tuning parameter of flow-blocking drag (FBD). See use_od_bl. Default: set by build-namelist. - Tuning parameter of small-scale GWD (sGWD). See use_od_ss. Default: set by build-namelist. diff --git a/components/eam/src/control/startup_initialconds.F90 b/components/eam/src/control/startup_initialconds.F90 index 6b8b4062f9da..a68195c731db 100644 --- a/components/eam/src/control/startup_initialconds.F90 +++ b/components/eam/src/control/startup_initialconds.F90 @@ -13,19 +13,19 @@ module startup_initialconds public :: initial_conds ! Read in initial conditions (dycore dependent) !added for orographic drag -public topoGWD_file_get_id -public setup_initialGWD -public close_initial_fileGWD -type(file_desc_t), pointer :: ncid_topoGWD +public topo_OD_file_get_id +public setup_initial_OD +public close_initial_file_OD +type(file_desc_t), pointer :: ncid_topo_OD !======================================================================= contains !======================================================================= -function topoGWD_file_get_id() - type(file_desc_t), pointer :: topoGWD_file_get_id - topoGWD_file_get_id => ncid_topoGWD -end function topoGWD_file_get_id +function topo_OD_file_get_id() + type(file_desc_t), pointer :: topo_OD_file_get_id + topo_OD_file_get_id => ncid_topo_OD +end function topo_OD_file_get_id subroutine initial_conds(dyn_in) @@ -74,7 +74,7 @@ end subroutine initial_conds !======================================================================= -subroutine setup_initialGWD() +subroutine setup_initial_OD() use filenames, only: bnd_topo use ioFileMod, only: getfil use cam_pio_utils, only: cam_pio_openfile @@ -86,17 +86,17 @@ subroutine setup_initialGWD() include 'netcdf.inc' !----------------------------------------------------------------------- character(len=256) :: bnd_topo_loc ! filepath of topo file on local disk - allocate(ncid_topoGWD) + allocate(ncid_topo_OD) call getfil(bnd_topo, bnd_topo_loc) - call cam_pio_openfile(ncid_topoGWD, bnd_topo_loc, PIO_NOWRITE) -end subroutine setup_initialGWD + call cam_pio_openfile(ncid_topo_OD, bnd_topo_loc, PIO_NOWRITE) +end subroutine setup_initial_OD -subroutine close_initial_fileGWD +subroutine close_initial_file_OD use pio, only: pio_closefile - call pio_closefile(ncid_topoGWD) - deallocate(ncid_topoGWD) - nullify(ncid_topoGWD) -end subroutine close_initial_fileGWD + call pio_closefile(ncid_topo_OD) + deallocate(ncid_topo_OD) + nullify(ncid_topo_OD) +end subroutine close_initial_file_OD !======================================================================= diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index c9c3bcdfa2ca..e44c3ab7fea0 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -20,7 +20,7 @@ module clubb_intr use shr_kind_mod, only: r8=>shr_kind_r8 use shr_log_mod , only: errMsg => shr_log_errMsg use ppgrid, only: pver, pverp - use phys_control, only: phys_getopts,use_od_ss,use_od_fd,ncleff_ls,ncd_bl,sncleff_ss + use phys_control, only: phys_getopts, use_od_ss, use_od_fd, od_ls_ncleff, od_bl_ncd, od_ss_sncleff use physconst, only: rair, cpair, gravit, latvap, latice, zvir, rh2o, karman, & tms_orocnst, tms_z0fac, pi use cam_logfile, only: iulog @@ -2004,7 +2004,7 @@ subroutine clubb_tend_cam( & !sgh30 as the input for TOFD instead of sgh call gw_oro_interface(state,cam_in,sgh30,pbuf,hdtime,dummy_nm,& gwd_ls,gwd_bl,gwd_ss,gwd_fd,& - ncleff_ls,ncd_bl,sncleff_ss,& + od_ls_ncleff,od_bl_ncd,od_ss_sncleff,& dummy_utgw,dummy_vtgw,dummy_ttgw,& dtaux3_ls=dummx3_ls,dtauy3_ls=dummy3_ls,& dtaux3_bl=dummx3_bl,dtauy3_bl=dummy3_bl,& diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index 02ddbbb1e84b..64e3750dd4e7 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -32,7 +32,7 @@ module comsrf ! public initialize_comsrf ! Set the surface temperature and sea-ice fraction !!added for separate input of ogwd parareters in gw_drag - public initialize_comsrf2 + public initialize_comsrf_OD ! ! Public data ! @@ -55,10 +55,8 @@ module comsrf real(r8), allocatable:: prcsnw(:,:) ! cam tot snow precip real(r8), allocatable:: trefmxav(:,:) ! diagnostic: tref max over the day real(r8), allocatable:: trefmnav(:,:) ! diagnostic: tref min over the day - ! - public var,var30,oc,ol,oadir - real(r8), allocatable:: var(:,:) ! sgh - real(r8), allocatable:: var30(:,:) ! sgh30 + + public oc, ol, oadir real(r8), allocatable:: oc(:,:) ! Convexity real(r8), allocatable:: oadir(:,:,:) ! Asymmetry real(r8), allocatable:: ol(:,:,:) ! Effective length @@ -140,7 +138,7 @@ subroutine initialize_comsrf end if end subroutine initialize_comsrf - subroutine initialize_comsrf2 + subroutine initialize_comsrf_OD use cam_control_mod, only: ideal_phys, adiabatic !----------------------------------------------------------------------- ! @@ -155,17 +153,13 @@ subroutine initialize_comsrf2 integer k,c ! level, constituent indices if(.not. (adiabatic .or. ideal_phys)) then - allocate (var (pcols,begchunk:endchunk)) - allocate (var30 (pcols,begchunk:endchunk)) allocate (oc (pcols,begchunk:endchunk)) allocate (oadir (pcols,nvar_dirOA,begchunk:endchunk)) allocate (ol (pcols,nvar_dirOL,begchunk:endchunk)) - var (:,:) = nan - var30 (:,:) = nan oc (:,:) = nan oadir (:,:,:) = nan ol (:,:,:) = nan end if - end subroutine initialize_comsrf2 + end subroutine initialize_comsrf_OD end module comsrf diff --git a/components/eam/src/physics/cam/gw_common.F90 b/components/eam/src/physics/cam/gw_common.F90 index 98743b2b8471..198c634f2840 100644 --- a/components/eam/src/physics/cam/gw_common.F90 +++ b/components/eam/src/physics/cam/gw_common.F90 @@ -5,7 +5,6 @@ module gw_common ! parameterizations. ! use gw_utils, only: r8 -use ppgrid, only: nvar_dirOA,nvar_dirOL!pcols,pver,pverp, use cam_logfile, only: iulog implicit none @@ -17,7 +16,6 @@ module gw_common public :: gw_prof public :: momentum_energy_conservation public :: gw_drag_prof -public :: gw_oro_interface public :: pver, pgwv public :: dc @@ -29,7 +27,6 @@ module gw_common public :: kwv public :: gravit public :: rair -public :: gwdo_gsd,pblh_get_level_idx,grid_size ! This flag preserves answers for vanilla CAM by making a few changes (e.g. ! order of operations) when only orographic waves are on. @@ -747,1471 +744,5 @@ subroutine gw_drag_prof(ncol, ngwv, src_level, tend_level, do_taper, dt, & end subroutine gw_drag_prof !========================================================================== - -subroutine gw_oro_interface(state, cam_in, sgh, pbuf, dtime, nm,& - gwd_ls, gwd_bl, gwd_ss, gwd_fd,& - ncleff_ls,ncd_bl, sncleff_ss,& - utgw, vtgw, ttgw,& - dtaux3_ls,dtauy3_ls,dtaux3_bl,dtauy3_bl,& - dtaux3_ss,dtauy3_ss,dtaux3_fd,dtauy3_fd,& - dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl,& - dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index - use camsrfexch, only: cam_in_t - use ppgrid, only: pcols,pver,pverp - use physconst, only: gravit,rair,cpair,rh2o,zvir,pi - use hycoef, only: etamid - - type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(in) :: sgh(pcols) - type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer - real(r8), intent(in) :: dtime - real(r8), intent(in) :: nm(state%ncol,pver) ! midpoint Brunt-Vaisalla frequency - !options for the 4 schemes - logical , intent(in) :: gwd_ls - logical , intent(in) :: gwd_bl - logical , intent(in) :: gwd_ss - logical , intent(in) :: gwd_fd - !tunable parameter from namelist - real(r8), intent(in) :: ncleff_ls - real(r8), intent(in) :: ncd_bl - real(r8), intent(in) :: sncleff_ss - !vertical profile of the momentum tendencies - real(r8), intent(out), optional :: utgw(state%ncol,pver) - real(r8), intent(out), optional :: vtgw(state%ncol,pver) - real(r8), intent(out), optional :: ttgw(state%ncol,pver) - !output drag terms in 3D and surface - real(r8), intent(out), optional :: dtaux3_ls(pcols,pver) - real(r8), intent(out), optional :: dtauy3_ls(pcols,pver) - real(r8), intent(out), optional :: dtaux3_bl(pcols,pver) - real(r8), intent(out), optional :: dtauy3_bl(pcols,pver) - real(r8), intent(out), optional :: dtaux3_ss(pcols,pver) - real(r8), intent(out), optional :: dtauy3_ss(pcols,pver) - real(r8), intent(out), optional :: dtaux3_fd(pcols,pver) - real(r8), intent(out), optional :: dtauy3_fd(pcols,pver) - real(r8), intent(out), optional :: dusfc_ls(pcols) - real(r8), intent(out), optional :: dvsfc_ls(pcols) - real(r8), intent(out), optional :: dusfc_bl(pcols) - real(r8), intent(out), optional :: dvsfc_bl(pcols) - real(r8), intent(out), optional :: dusfc_ss(pcols) - real(r8), intent(out), optional :: dvsfc_ss(pcols) - real(r8), intent(out), optional :: dusfc_fd(pcols) - real(r8), intent(out), optional :: dvsfc_fd(pcols) - ! - real(r8) :: ztop(pcols,pver) ! top interface height asl (m) - real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) - real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) - real(r8) :: dz(pcols,pver) ! model layer height - ! - !real(r8) :: g - !pblh input - integer :: pblh_idx = 0 - integer :: kpbl2d_in(pcols) - integer :: kpbl2d_reverse_in(pcols) - real(r8), pointer :: pblh(:) - real(r8) :: dx(pcols),dy(pcols) - !needed index - integer :: ncol - integer :: i - integer :: k - - ncol=state%ncol - !convert heights above surface to heights above sea level - !obtain z,dz,dx,dy,and k for pblh - kpbl2d_in=0_r8 - kpbl2d_reverse_in=0_r8 - ztop=0._r8 - zbot=0._r8 - zmid=0._r8 - dusfc_ls=0._r8 - dvsfc_ls=0._r8 - dusfc_bl=0._r8 - dvsfc_bl=0._r8 - dusfc_ss=0._r8 - dvsfc_ss=0._r8 - dusfc_fd=0._r8 - dvsfc_fd=0._r8 - dtaux3_ls=0._r8 - dtaux3_bl=0._r8 - dtauy3_ls=0._r8 - dtauy3_bl=0._r8 - dtaux3_ss=0._r8 - dtaux3_fd=0._r8 - dtauy3_ss=0._r8 - dtauy3_fd=0._r8 - - do k=1,pver - do i=1,ncol - ! assign values for level top/bottom - ztop(i,k)=state%zi(i,k) - zbot(i,k)=state%zi(i,k+1) - enddo - end do - - !transform adding the pressure - !transfer from surface to sea level - do k=1,pver - do i=1,ncol - ztop(i,k)=ztop(i,k)+state%phis(i)/gravit - zbot(i,k)=zbot(i,k)+state%phis(i)/gravit - zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit - !dz is from bottom to top already for gw_drag - dz(i,k)=ztop(i,k)-zbot(i,k) - end do - end do - !get the layer index of pblh in layer for input in drag scheme - pblh_idx = pbuf_get_index('pblh') - call pbuf_get_field(pbuf, pblh_idx, pblh) - do i=1,pcols - kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) - kpbl2d_reverse_in(i)=pverp-kpbl2d_in(i)!pverp-k - end do - - !get grid size for dx,dy - call grid_size(state,dx,dy) - !interface for orographic drag - call gwdo_gsd(& - u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& - qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& - pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& - ncleff_ls=ncleff_ls,ncd_bl=ncd_bl,sncleff_ss=sncleff_ss,& - rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& - dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& - dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& - dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& - dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& - dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& - dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& - dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& - dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& - xland=cam_in%landfrac,br=state%ribulk(:ncol),& - var2d=sgh(:ncol),oc12d=state%oc(:ncol),& - oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& - znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& - cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& - dt=dtime,dx=dx,dy=dy,& - kpbl2d=kpbl2d_reverse_in,gwd_opt=0,& - ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & - ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & - its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & - gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) - -end subroutine gw_oro_interface - -!========================================================================== - -function pblh_get_level_idx(height_array,pblheight) - implicit none - real(r8),intent(in),dimension(pver) :: height_array - real(r8),intent(in) :: pblheight - integer :: pblh_get_level_idx - !local - integer :: k - logical :: found - - pblh_get_level_idx = -1 - found=.false. - !get the pblh level index and return - do k = 1, pver - if((pblheight >= height_array(k+1).and.pblheight 300._r8) then - kpbl2 = k - IF (k == kpbl(i)) then - hpbl2 = hpbl(i)+10._r8 - ELSE - hpbl2 = za(i,k)+10._r8 - ENDIF - exit - ENDIF - enddo - - if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then - if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then - cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) - cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) - coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) - xlinv(i) = coefm(i) / cleff - govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) - XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) - - if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then - tauwavex0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) - tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" - else - tauwavex0=0._r8 - endif - - if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then - tauwavey0=0.5_r8*XNBV*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) - tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" - else - tauwavey0=0._r8 - endif - - do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) - utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - enddo - endif - endif - enddo ! end i loop - - do k = kts,kte - do i = its,ite - dudt(i,k) = dudt(i,k) + utendwave(i,k) - dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) - dtaux2d_ss(i,k) = utendwave(i,k) - dtauy2d_ss(i,k) = vtendwave(i,k) - dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) - dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) - enddo - enddo - - ENDIF ! end if gsd_gwd_ss == .true. - !================================================================ - !add Beljaars et al. (2004, QJRMS, equ. 16) form drag: - !================================================================ - IF (gsd_gwd_fd.and.(ss_taper.GT.1.E-02) ) THEN - - utendform=0._r8 - vtendform=0._r8 - zq=0._r8 - - IF (.not.gsd_gwd_ss.and.(ss_taper.GT.1.E-02) ) THEN - ! Defining layer height. This is already done above is small-scale GWD is used - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz2(i,k)+zq(i,k) - enddo - enddo - - do k = kts,kte - do i = its,ite - za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) - enddo - enddo - ENDIF - - DO i=its,ite - IF (xland1(i) .gt. 0..and.2._r8*var(i).gt.0) then - a1=0.00026615161_r8*var(i)**2_r8 - a2=a1*0.005363_r8 - DO k=kts,kte - wsp=SQRT(u1(i,k)**2_r8 + v1(i,k)**2_r8) - ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 - utendform(i,k)=-0.0759_r8*wsp*u1(i,k)* & - EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper - vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & - EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper - ! - ENDDO - ENDIF - ENDDO - - do k = kts,kte - do i = its,ite - dudt(i,k) = dudt(i,k) + utendform(i,k) - dvdt(i,k) = dvdt(i,k) + vtendform(i,k) - !limit drag tendency - !some tendency is likely to even overturn the wind, - !making wind reverse in 1 timestep and reverse again in next, - !this limitation may help to make model stable, - !and no more wind reversal due to drag, - !which is suppose to decelerate, not accelerate - utendform(i,k) = sign(min(abs(utendform(i,k)),abs(u1(i,k))/deltim),utendform(i,k)) - vtendform(i,k) = sign(min(abs(vtendform(i,k)),abs(v1(i,k))/deltim),vtendform(i,k)) - dtaux2d_fd(i,k) = utendform(i,k) - dtauy2d_fd(i,k) = vtendform(i,k) - dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) - dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) - enddo - enddo - ENDIF ! end if gsd_gwd_fd == .true. - !======================================================= - ! More for the large-scale gwd component - !======================================================= - IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN - ! - ! now compute vertical structure of the stress. - ! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo - - if (scorer_on) then - ! - !determination of the interface height for scorer adjustment - ! - do i=its,ite - iint=.false. - do k=kpblmin,kte-1 - if (k.gt.kbl(i).and.usqj(i,k)-usqj(i,k-1).lt.0.and.(.not.iint)) then - iint=.true. - zl_hint(i)=zl(i,k+1) - endif - enddo - enddo - endif - - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite - ! - ! unstablelayer if ri < ric - ! unstable layer if upper air vel comp along surf vel <=0 (crit lay) - ! at (u-c)=0. crit layer exists and bit vector should be set (.le.) - ! - if (k .ge. kbl(i)) then - !we modify the criteria for unstable layer - !that the lv is critical under 0.25 - !while we keep wave breaking ric for - !other larger lv - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& - .or. (velco(i,k) .le. 0.0_r8) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo - - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then - temv = 1.0_r8 / velco(i,k) - tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv - ! - ! rim is the minimum-richardson number by shutts (1985) - ! - tem2 = sqrt(usqj(i,k)) - tem = 1._r8 + tem2 * fro - rim = usqj(i,k) * (1._r8-fro) / (tem * tem) - - ! - ! check stability to employ the 'saturation hypothesis' - ! of lindzen (1981) except at tropospheric downstream regions - ! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then - temc = 2.0_r8 + 1.0_r8 / tem2 - hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - ! - ! taup is restricted to monotoncally decrease - ! to avoid unexpected high taup in calculation - ! - taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) - ! - ! add vertical decrease at low level below hint (Kim and Doyle 2005) - ! where Ri first decreases - ! - if (scorer_on.and.k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i).and.k.lt.kte-1) then - l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2) - l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2) - taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) - endif - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo - enddo - - if(lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif - - ENDIF !END LARGE-SCALE TAU CALCULATION - !=============================================================== - !COMPUTE BLOCKING COMPONENT - !=============================================================== - IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN - - do i = its,ite - if(.not.ldrag(i)) then - ! - !------- determine the height of flow-blocking layer - ! - kblk = 0 - pe = 0.0_r8 - - do k = kte, kpblmin, -1 - if(kblk.eq.0 .and. k.le.komax(i)) then - !flow block appears within the reference level - !compare potential energy and kinetic energy - !divided by g*ro is to turn del(pa) into height - pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) - ke = 0.5_r8*((rcs*u1(i,k))**2._r8+(rcs*v1(i,k))**2._r8) - ! - !---------- apply flow-blocking drag when pe >= ke - ! - if(pe.ge.ke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - endif - endif - enddo - - if(kblk.ne.0) then - ! - !--------- compute flow-blocking stress - ! - - !dxmax_ls is different than the usual one - !because the taper is very different - !dxy is a length scale mostly in the direction of the flow to the ridge - !so it is good and not needed for an uneven grid area - !ref Lott and Miller (1997) original scheme - cd = max(2.0_r8-1.0_r8/od(i),0.0_r8) - ! - !tuning of the drag magnitude - cd=ncd*cd - ! - taufb(i,kts) = 0.5_r8 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & - * olp(i) * zblk * ulow(i)**2 - !changed grid box area into dy*dy - tautem = taufb(i,kts)/float(kblk-kts) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo - - ! - !----------sum orographic GW stress and flow-blocking stress - ! - !taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now - endif - endif - enddo - - ENDIF ! end blocking drag -!=========================================================== - IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN - ! - ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy - ! - - do k = kts,kte - do i = its,ite - taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) - taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) - enddo - enddo - ! - ! limit de-acceleration (momentum deposition ) at top to 1/2 value - ! the idea is some stuff must go out the 'top' - ! - - do klcap = lcap,kte - do i = its,ite - taud_ls(i,klcap) = taud_ls(i,klcap) * factop - taud_bl(i,klcap) = taud_bl(i,klcap) * factop - enddo - enddo - - ! - ! if the gravity wave drag would force a critical line - ! in the lower ksmm1 layers during the next deltim timestep, - ! then only apply drag until that critical line is reached. - ! - do k = kts,kpblmax-1 - do i = its,ite - if (k .le. kbl(i)) then - if((taud_ls(i,k)+taud_bl(i,k)).ne.0._r8) & - dtfac(i) = min(dtfac(i),abs(velco(i,k) & - /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) - endif - enddo - enddo - - do k = kts,kte - do i = its,ite - taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper - !apply limiter for ogwd - !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) - !2.dudttopoGWD_file_get_id() - call infld('SGH' ,ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk,& - endchunk, var, found, gridname='physgrid') - call infld('SGH30',ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk,& - endchunk, var30, found, gridname='physgrid') - call infld('OC', ncid_topoGWD,dim1name,dim2name, 1,pcols,begchunk, & - endchunk, oc, found, gridname='physgrid') + ! + call initialize_comsrf_OD() + call setup_initial_OD() + ncid_topo_OD=>topo_OD_file_get_id() + call infld('OC', ncid_topo_OD, dim1name, dim2name, 1, pcols, begchunk, & + endchunk, oc , found, gridname='physgrid') !keep the same interval of OA,OL - call infld('OA', ncid_topoGWD,dim1name,'nvar_dirOA',dim2name,1,pcols,1,nvar_dirOA,begchunk, & - endchunk, oadir(:,:,:), found, gridname='physgrid') - call infld('OL', ncid_topoGWD,dim1name,'nvar_dirOL',dim2name,1,pcols,1,nvar_dirOL,begchunk, & - endchunk, ol, found, gridname='physgrid') - if(.not. found) call endrun('ERROR: GWD topo file readerr') + call infld('OA', ncid_topo_OD,dim1name, 'nvar_dirOA', dim2name, 1, pcols, 1, nvar_dirOA, begchunk, & + endchunk, oadir(:,:,:), found, gridname='physgrid') + call infld('OL', ncid_topo_OD,dim1name, 'nvar_dirOL', dim2name, 1, pcols, 1, nvar_dirOL, begchunk, & + endchunk, ol , found, gridname='physgrid') + if(.not. found) call endrun('ERROR: OD topo file readerr') ! - call close_initial_fileGWD() + call close_initial_file_OD() endif ! ! Set model flags. @@ -664,14 +660,15 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) use camsrfexch, only: cam_in_t ! Location-dependent cpair use physconst, only: cpairv + use od_common, only: oro_drag_interface use gw_common, only: gw_prof, momentum_energy_conservation, & - gw_drag_prof,gw_oro_interface + gw_drag_prof use gw_oro, only: gw_oro_src use gw_front, only: gw_cm_src use gw_convect, only: gw_beres_src use dycore, only: dycore_is - use phys_grid, only: get_rlat_all_p - use physconst, only: gravit,rair + use phys_grid, only: get_rlat_all_p + use physconst, only: gravit,rair !------------------------------Arguments-------------------------------- type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. @@ -1015,18 +1012,18 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) vtgw=0.0_r8 ttgw=0.0_r8 ! - call gw_oro_interface( state,cam_in,sgh,pbuf,dt,nm,& - gwd_ls,gwd_bl,gwd_ss,gwd_fd,& - ncleff_ls,ncd_bl,sncleff_ss,& - utgw,vtgw,ttgw,& - dtaux3_ls=dtaux3_ls,dtauy3_ls=dtauy3_ls,& - dtaux3_bl=dtaux3_bl,dtauy3_bl=dtauy3_bl,& - dtaux3_ss=dtaux3_ss,dtauy3_ss=dtauy3_ss,& - dtaux3_fd=dummx3_fd,dtauy3_fd=dummy3_fd,& - dusfc_ls=dusfc_ls,dvsfc_ls=dvsfc_ls,& - dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl,& - dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss,& - dusfc_fd=dummx_fd,dvsfc_fd=dummy_fd) + call oro_drag_interface(state,cam_in,sgh,pbuf,dt,nm,& + gwd_ls,gwd_bl,gwd_ss,gwd_fd,& + od_ls_ncleff,od_bl_ncd,od_ss_sncleff,& + utgw,vtgw,ttgw,& + dtaux3_ls=dtaux3_ls,dtauy3_ls=dtauy3_ls,& + dtaux3_bl=dtaux3_bl,dtauy3_bl=dtauy3_bl,& + dtaux3_ss=dtaux3_ss,dtauy3_ss=dtauy3_ss,& + dtaux3_fd=dummx3_fd,dtauy3_fd=dummy3_fd,& + dusfc_ls=dusfc_ls,dvsfc_ls=dvsfc_ls,& + dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl,& + dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss,& + dusfc_fd=dummx_fd,dvsfc_fd=dummy_fd) endif ! diff --git a/components/eam/src/physics/cam/od_common.F90 b/components/eam/src/physics/cam/od_common.F90 new file mode 100644 index 000000000000..d548e32b3790 --- /dev/null +++ b/components/eam/src/physics/cam/od_common.F90 @@ -0,0 +1,1497 @@ +module od_common + +! +! This module contains code common to different orographic drag +! parameterizations. +! It includes 4 parts: +! orographic gravity wave drag (Xie et al.,2020), +! flow-blocking drag (Xie et al.,2020), +! small-scale orographic gravity wave drag (Tsiringakis et al. 2017), +! turbulent orographic form drag (Beljaars et al.,2004). +! +use gw_utils, only: r8 +use ppgrid, only: nvar_dirOA,nvar_dirOL +use cam_logfile, only: iulog + +implicit none +private +save + +! Public interface. +public :: oro_drag_interface +public :: od_gsd,pblh_get_level_idx,grid_size + +contains + +!========================================================================== + +subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm,& + gwd_ls, gwd_bl, gwd_ss, gwd_fd, & + od_ls_ncleff, od_bl_ncd,od_ss_sncleff,& + utgw, vtgw, ttgw, & + dtaux3_ls,dtauy3_ls,dtaux3_bl,dtauy3_bl, & + dtaux3_ss,dtauy3_ss,dtaux3_fd,dtauy3_fd, & + dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl, & + dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index + use camsrfexch, only: cam_in_t + use ppgrid, only: pcols,pver,pverp + use physconst, only: gravit,rair,cpair,rh2o,zvir,pi + use hycoef, only: etamid + + type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(in) :: sgh(pcols) + type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer + real(r8), intent(in) :: dtime + real(r8), intent(in) :: nm(state%ncol,pver) ! midpoint Brunt-Vaisalla frequency + !options for the 4 schemes + logical , intent(in) :: gwd_ls + logical , intent(in) :: gwd_bl + logical , intent(in) :: gwd_ss + logical , intent(in) :: gwd_fd + !tunable parameter from namelist + real(r8), intent(in) :: od_ls_ncleff + real(r8), intent(in) :: od_bl_ncd + real(r8), intent(in) :: od_ss_sncleff + !vertical profile of the momentum tendencies + real(r8), intent(out), optional :: utgw(state%ncol,pver) + real(r8), intent(out), optional :: vtgw(state%ncol,pver) + real(r8), intent(out), optional :: ttgw(state%ncol,pver) + !output drag terms in 3D and surface + real(r8), intent(out), optional :: dtaux3_ls(pcols,pver) + real(r8), intent(out), optional :: dtauy3_ls(pcols,pver) + real(r8), intent(out), optional :: dtaux3_bl(pcols,pver) + real(r8), intent(out), optional :: dtauy3_bl(pcols,pver) + real(r8), intent(out), optional :: dtaux3_ss(pcols,pver) + real(r8), intent(out), optional :: dtauy3_ss(pcols,pver) + real(r8), intent(out), optional :: dtaux3_fd(pcols,pver) + real(r8), intent(out), optional :: dtauy3_fd(pcols,pver) + real(r8), intent(out), optional :: dusfc_ls(pcols) + real(r8), intent(out), optional :: dvsfc_ls(pcols) + real(r8), intent(out), optional :: dusfc_bl(pcols) + real(r8), intent(out), optional :: dvsfc_bl(pcols) + real(r8), intent(out), optional :: dusfc_ss(pcols) + real(r8), intent(out), optional :: dvsfc_ss(pcols) + real(r8), intent(out), optional :: dusfc_fd(pcols) + real(r8), intent(out), optional :: dvsfc_fd(pcols) + ! + real(r8) :: ztop(pcols,pver) ! top interface height asl (m) + real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) + real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) + real(r8) :: dz(pcols,pver) ! model layer height + ! + !real(r8) :: g + !pblh input + integer :: pblh_idx = 0 + integer :: kpbl2d_in(pcols) + integer :: kpbl2d_reverse_in(pcols) + real(r8), pointer :: pblh(:) + real(r8) :: dx(pcols),dy(pcols) + !needed index + integer :: ncol + integer :: i + integer :: k + + ncol=state%ncol + !convert heights above surface to heights above sea level + !obtain z,dz,dx,dy,and k for pblh + kpbl2d_in=0_r8 + kpbl2d_reverse_in=0_r8 + ztop=0._r8 + zbot=0._r8 + zmid=0._r8 + dusfc_ls=0._r8 + dvsfc_ls=0._r8 + dusfc_bl=0._r8 + dvsfc_bl=0._r8 + dusfc_ss=0._r8 + dvsfc_ss=0._r8 + dusfc_fd=0._r8 + dvsfc_fd=0._r8 + dtaux3_ls=0._r8 + dtaux3_bl=0._r8 + dtauy3_ls=0._r8 + dtauy3_bl=0._r8 + dtaux3_ss=0._r8 + dtaux3_fd=0._r8 + dtauy3_ss=0._r8 + dtauy3_fd=0._r8 + + do k=1,pver + do i=1,ncol + ! assign values for level top/bottom + ztop(i,k)=state%zi(i,k) + zbot(i,k)=state%zi(i,k+1) + enddo + end do + + !transform adding the pressure + !transfer from surface to sea level + do k=1,pver + do i=1,ncol + ztop(i,k)=ztop(i,k)+state%phis(i)/gravit + zbot(i,k)=zbot(i,k)+state%phis(i)/gravit + zmid(i,k)=state%zm(i,k)+state%phis(i)/gravit + !dz is from bottom to top already for gw_drag + dz(i,k)=ztop(i,k)-zbot(i,k) + end do + end do + !get the layer index of pblh in layer for input in drag scheme + pblh_idx = pbuf_get_index('pblh') + call pbuf_get_field(pbuf, pblh_idx, pblh) + do i=1,pcols + kpbl2d_in(i)=pblh_get_level_idx(zbot(i,:)-(state%phis(i)/gravit),pblh(i)) + kpbl2d_reverse_in(i)=pverp-kpbl2d_in(i)!pverp-k + end do + + !get grid size for dx,dy + call grid_size(state,dx,dy) + !interface for orographic drag + call od_gsd(& + u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& + qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& + pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& + od_ls_ncleff=od_ls_ncleff,od_bl_ncd=od_bl_ncd,od_ss_sncleff=od_ss_sncleff,& + rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& + dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& + dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& + dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& + dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& + dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& + dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& + dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& + dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& + xland=cam_in%landfrac,br=state%ribulk(:ncol),& + var2d=sgh(:ncol),oc12d=state%oc(:ncol),& + oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& + znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& + cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& + dt=dtime,dx=dx,dy=dy,& + kpbl2d=kpbl2d_reverse_in,gwd_opt=0,& + ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & + gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) + +end subroutine oro_drag_interface + +!========================================================================== + +function pblh_get_level_idx(height_array,pblheight) + implicit none + real(r8),intent(in),dimension(pver) :: height_array + real(r8),intent(in) :: pblheight + integer :: pblh_get_level_idx + !local + integer :: k + logical :: found + + pblh_get_level_idx = -1 + found=.false. + !get the pblh level index and return + do k = 1, pver + if((pblheight >= height_array(k+1).and.pblheight 300._r8) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10._r8 + ELSE + hpbl2 = za(i,k)+10._r8 + ENDIF + exit + ENDIF + enddo + + if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then + if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then + cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) + cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) + coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) + xlinv(i) = coefm(i) / cleff + govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) + bnrf=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) + + if(abs(bnrf/u1(i,kpbl2)).gt.xlinv(i))then + tauwavex0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" + else + tauwavex0=0._r8 + endif + + if(abs(bnrf/v1(i,kpbl2)).gt.xlinv(i))then + tauwavey0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" + else + tauwavey0=0._r8 + endif + + do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) + utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + enddo + endif + endif + enddo ! end i loop + + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + enddo + enddo + + ENDIF ! end if gsd_gwd_ss == .true. + !================================================================ + !add Beljaars et al. (2004, QJRMS, equ. 16) form drag: + !================================================================ + IF (gsd_gwd_fd.and.(ss_taper.GT.1.E-02) ) THEN + + utendform=0._r8 + vtendform=0._r8 + zq=0._r8 + + if (.not.gsd_gwd_ss.and.(ss_taper.GT.1.E-02) ) THEN + ! Defining layer height. This is already done above is small-scale GWD is used + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz2(i,k)+zq(i,k) + enddo + enddo + + do k = kts,kte + do i = its,ite + za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) + enddo + enddo + endif + + do i=its,ite + if (xland1(i) .gt. 0..and.2._r8*var(i).gt.0) then + ! refer to Beljaars (2004) eq.16. + a1=0.00026615161_r8*var(i)**2_r8 + a2=a1*0.005363_r8 + do k=kts,kte + wsp=SQRT(u1(i,k)**2_r8 + v1(i,k)**2_r8) + ! refer to Beljaars (2004) eq.16. + ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + utendform(i,k)=-0.0759_r8*wsp*u1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & + EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper + ! + enddo + endif + enddo + + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + !limit drag tendency + !some tendency is likely to even overturn the wind, + !making wind reverse in 1 timestep and reverse again in next, + !this limitation may help to make model stable, + !and no more wind reversal due to drag, + !which is suppose to decelerate, not accelerate + utendform(i,k) = sign(min(abs(utendform(i,k)),abs(u1(i,k))/deltim),utendform(i,k)) + vtendform(i,k) = sign(min(abs(vtendform(i,k)),abs(v1(i,k))/deltim),vtendform(i,k)) + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + enddo + enddo + ENDIF ! end if gsd_gwd_fd == .true. + !======================================================= + ! More for the large-scale gwd component + !======================================================= + IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN + ! + ! now compute vertical structure of the stress. + ! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo + + if (scorer_on) then + ! + !determination of the interface height for scorer adjustment + ! + do i=its,ite + iint=.false. + do k=kpblmin,kte-1 + if (k.gt.kbl(i).and.usqj(i,k)-usqj(i,k-1).lt.0.and.(.not.iint)) then + iint=.true. + zl_hint(i)=zl(i,k+1) + endif + enddo + enddo + endif + + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite + ! + ! unstablelayer if ri < ric + ! unstable layer if upper air vel comp along surf vel <=0 (crit lay) + ! at (u-c)=0. crit layer exists and bit vector should be set (.le.) + ! + if (k .ge. kbl(i)) then + !we modify the criteria for unstable layer + !that the lv is critical under 0.25 + !while we keep wave breaking ric for + !other larger lv + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& + .or. (velco(i,k) .le. 0.0_r8) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo + + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then + temv = 1.0_r8 / velco(i,k) + tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv + ! + ! rim is the minimum-richardson number by shutts (1985) + ! + tem2 = sqrt(usqj(i,k)) + tem = 1._r8 + tem2 * fro + rim = usqj(i,k) * (1._r8-fro) / (tem * tem) + + ! + ! check stability to employ the 'saturation hypothesis' + ! of lindzen (1981) except at tropospheric downstream regions + ! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then + temc = 2.0_r8 + 1.0_r8 / tem2 + hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + ! + ! taup is restricted to monotoncally decrease + ! to avoid unexpected high taup in calculation + ! + taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) + ! + ! add vertical decrease at low level below hint (Kim and Doyle 2005) + ! where Ri first decreases + ! + if (scorer_on.and.k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i).and.k.lt.kte-1) then + l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2) + l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2) + taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) + endif + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo + + if(lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + + ENDIF !END LARGE-SCALE TAU CALCULATION + !=============================================================== + !COMPUTE BLOCKING COMPONENT + !=============================================================== + IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN + + do i = its,ite + if(.not.ldrag(i)) then + ! + !------- determine the height of flow-blocking layer + ! + kblk = 0 + pe = 0.0_r8 + + do k = kte, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + !flow block appears within the reference level + !compare potential energy and kinetic energy + !divided by g*ro is to turn del(pa) into height + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) + ke = 0.5_r8*((rcs*u1(i,k))**2._r8+(rcs*v1(i,k))**2._r8) + ! + !---------- apply flow-blocking drag when pe >= ke + ! + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + + if(kblk.ne.0) then + ! + !--------- compute flow-blocking stress + ! + + !dxmax_ls is different than the usual one + !because the taper is very different + !dxy is a length scale mostly in the direction of the flow to the ridge + !so it is good and not needed for an uneven grid area + !ref Lott and Miller (1997) original scheme + cd = max(2.0_r8-1.0_r8/od(i),0.0_r8) + ! + !tuning of the drag magnitude + cd=ncd*cd + ! + taufb(i,kts) = 0.5_r8 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & + * olp(i) * zblk * ulow(i)**2 + !changed grid box area into dy*dy + tautem = taufb(i,kts)/float(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo + + ! + !----------sum orographic GW stress and flow-blocking stress + ! + !taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now + endif + endif + enddo + + ENDIF ! end blocking drag +!=========================================================== + IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN + ! + ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy + ! + + do k = kts,kte + do i = its,ite + taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo + enddo + ! + ! limit de-acceleration (momentum deposition ) at top to 1/2 value + ! the idea is some stuff must go out the 'top' + ! + + do klcap = lcap,kte + do i = its,ite + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop + enddo + enddo + + ! + ! if the gravity wave drag would force a critical line + ! in the lower ksmm1 layers during the next deltim timestep, + ! then only apply drag until that critical line is reached. + ! + do k = kts,kpblmax-1 + do i = its,ite + if (k .le. kbl(i)) then + if((taud_ls(i,k)+taud_bl(i,k)).ne.0._r8) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo + enddo + + do k = kts,kte + do i = its,ite + taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper + !apply limiter for ogwd + !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) + !2.dudt shr_kind_r8 - use reconstruct - use ogwd_sub - implicit none -# include - - !************************************** - ! - ! USER SETTINGS BELOW - ! - !************************************** - ! - ! - ! if smoothed PHIS is available SGH needs to be recomputed to account for the sub-grid-scale - ! variability introduced by the smoothing - ! -logical :: lsmooth_terr = .FALSE. -!logical :: lsmooth_terr = .TRUE. - ! - ! PHIS is smoothed by other software/dynamical core - ! - logical :: lexternal_smooth_terr = .FALSE. ! lexternal_smooth_terr = .FALSE. is NOT supported currently -!logical :: lexternal_smooth_terr = .TRUE. - ! - ! set PHIS=0.0 if LANDFRAC<0.01 - ! - logical :: lzero_out_ocean_point_phis = .TRUE.!.FALSE. -!logical :: lzero_out_ocean_point_phis = .FALSE. - ! - ! For internal smoothing (experimental at this point) - ! =================================================== - ! - ! if smoothing is internal (lexternal_smooth_terr=.FALSE.) choose coarsening factor - ! - ! recommendation: 2*(target resolution)/(0.03 degree) - ! - ! factor must be an even integer - ! - integer, parameter :: factor = 60 !coarse grid = 2.25 degrees - integer, parameter :: norder = 2 - integer, parameter :: nmono = 0 - integer, parameter :: npd = 1 - ! - !********************************************************************** - ! - ! END OF USER SETTINS BELOW - ! (do not edit beyond this point unless you know what you are doing!) - ! - !********************************************************************** - ! - integer :: im, jm, ncoarse - integer :: ncube !dimension of cubed-sphere grid - - real(r8), allocatable, dimension(:) :: landm_coslat, landfrac, terr, sgh30 - real(r8), allocatable, dimension(:) :: terr_coarse !for internal smoothing - - integer :: alloc_error,dealloc_error - integer :: i,j,n,k,index - integer*2, allocatable, dimension(:,:) :: iterr ! terrain data for 30-sec tile - integer ncid,status, dimlatid,dimlonid, landid, topoid ! for netCDF USGS data file - integer :: srcid,dstid, jm_dbg ! for netCDF weight file - integer, dimension(2) :: src_grid_dims ! for netCDF weight file - - integer :: dimid - - logical :: ldbg - real(r8), allocatable, dimension(:) :: lon , lat - real(r8), allocatable, dimension(:) :: lon_landm , lat_landm - real(r8), allocatable, dimension(:) :: area - integer :: im_landm, jm_landm - integer :: lonid, latid, phisid - ! - ! constants - ! - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: pih = 0.50*pi - REAL (r8), PARAMETER :: deg2rad = pi/180.0 - - real(r8) :: wt,dlat - integer :: ipanel,icube,jcube - real(r8), allocatable, dimension(:,:,:) :: weight,terr_cube,landfrac_cube,sgh30_cube - real(r8), allocatable, dimension(:,:,:) :: landm_coslat_cube - integer, allocatable, dimension(:,:) :: idx,idy,idp - integer :: npatch, isub,jsub, itmp, iplm1,jmin,jmax - real(r8) :: sum,dx,scale,dmax,arad,jof,term,s1,c1,clon,iof,dy,s2,c2,dist - ! - ! for linear interpolation - ! - real(r8) :: lambda,theta,wx,wy,offset - integer :: ilon,ilat,ip1,jp1 - ! - ! variable for regridding - ! - integer :: src_grid_dim ! for netCDF weight file - integer :: n_a,n_b,n_s,n_aid,n_bid,n_sid - integer :: count - real(r8), allocatable, dimension(:) :: landfrac_target, terr_target, sgh30_target, sgh_target - real(r8), allocatable, dimension(:) :: oc_target - real(r8), allocatable, dimension(:,:) :: oa_target,ol_target - real(r8) :: terr_if - real(r8), allocatable, dimension(:) :: lat_terr,lon_terr - integer :: nvar_dirOA,nvar_dirOL - integer,allocatable,dimension(:) :: indexb !max indice dimension - real(r8),allocatable,dimension(:,:,:) :: terrout - real(r8),allocatable,dimension(:,:) :: dxy - - real(r8), allocatable, dimension(:) :: landm_coslat_target, area_target - ! - ! this is only used if target grid is a lat-lon grid - ! - integer , parameter :: im_target = 360 , jm_target = 180 - ! - ! this is only used if target grid is not a lat-lon grid - ! - real(r8), allocatable, dimension(:) :: lon_target, lat_target - ! - ! new - ! - integer :: ntarget, ntarget_id, ncorner, ncorner_id, nrank, nrank_id - integer :: ntarget_smooth - real(r8), allocatable, dimension(:,:):: target_corner_lon, target_corner_lat - real(r8), allocatable, dimension(:) :: target_center_lon, target_center_lat, target_area -real(r8), allocatable, dimension(:,:):: target_corner_lon_deg,target_corner_lat_deg - integer :: ii,ip,jx,jy,jp - real(r8), dimension(:), allocatable :: xcell, ycell, xgno, ygno - real(r8), dimension(:), allocatable :: gauss_weights,abscissae - integer, parameter :: ngauss = 3 - integer :: jmax_segments,jall - real(r8) :: tmp - - real(r8), allocatable, dimension(:,:) :: weights_all - integer , allocatable, dimension(:,:) :: weights_eul_index_all - integer , allocatable, dimension(:) :: weights_lgr_index_all - integer :: ix,iy - ! - ! volume of topography - ! - real(r8) :: vol_target, vol_target_un, area_target_total,vol_source,vol_tmp - integer :: nlon,nlon_smooth,nlat,nlat_smooth - logical :: ltarget_latlon,lpole - real(r8), allocatable, dimension(:,:) :: terr_smooth - ! - ! for internal filtering - ! - real(r8), allocatable, dimension(:,:) :: weights_all_coarse - integer , allocatable, dimension(:,:) :: weights_eul_index_all_coarse - integer , allocatable, dimension(:) :: weights_lgr_index_all_coarse - real(r8), allocatable, dimension(:) :: area_target_coarse - real(r8), allocatable, dimension(:,:) :: da_coarse,da - real(r8), allocatable, dimension(:,:) :: recons,centroids - integer :: nreconstruction - - integer :: jmax_segments_coarse,jall_coarse,ncube_coarse - real(r8) :: all_weights - character(len=512) :: target_grid_file - character(len=512) :: input_topography_file - character(len=512) :: output_topography_file - character(len=512) :: smoothed_topography_file -real(r8) :: xxt,yyt,zzt -!real(r8),allocatable,dimension(:) :: xbar,ybar,zbar -real(r8),dimension(32768) :: xhds,yhds,zhds,hds,xbar,ybar,zbar,lon_bar,lat_bar -real(r8) :: rad,xx2,yy2,zz2,ix2,iy2,ip2 -real(r8) :: lonii,latii -character*20 :: indice - ! - nvar_dirOA=2+1!4 !2+1!4!36 - nvar_dirOL=180 - ! - ! turn extra debugging on/off - ! - ldbg = .FALSE. - - nreconstruction = 1 - ! - call parse_arguments(target_grid_file , input_topography_file , & - output_topography_file, smoothed_topography_file, & - lsmooth_terr ) - ! - !********************************************************* - ! - ! read in target grid - ! - !********************************************************* - ! - status = nf_open(trim(target_grid_file), 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'grid_size', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, ntarget) - WRITE(*,*) "dimension of target grid: ntarget=",ntarget - - status = NF_INQ_DIMID(ncid, 'grid_corners', ncorner_id) - status = NF_INQ_DIMLEN(ncid, ncorner_id, ncorner) - WRITE(*,*) "maximum number of corners: ncorner=",ncorner - - status = NF_INQ_DIMID(ncid, 'grid_rank', nrank_id);status = NF_INQ_DIMLEN(ncid, nrank_id, nrank) - WRITE(*,*) "grid rank: nrank=",nrank - IF (nrank==2) THEN - WRITE(*,*) "target grid is a lat-lon grid" - ltarget_latlon = .TRUE. - status = NF_INQ_DIMID(ncid, 'nlon', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon) - status = NF_INQ_DIMID(ncid, 'nlat', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat) - status = NF_INQ_DIMID(ncid, 'lpole', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, lpole) - WRITE(*,*) "nlon=",nlon,"nlat=",nlat - IF (lpole) THEN - WRITE(*,*) "center of most Northern grid cell is lat=90; similarly for South pole" - ELSE - WRITE(*,*) "center of most Northern grid cell is NOT lat=90; similarly for South pole" - END IF - ELSE IF (nrank==1) THEN - ltarget_latlon = .FALSE. - ELSE - WRITE(*,*) "nrank out of range",nrank - STOP - ENDIF - - allocate ( target_corner_lon(ncorner,ntarget),stat=alloc_error) - allocate ( target_corner_lat(ncorner,ntarget),stat=alloc_error) - allocate ( target_corner_lon_deg(ncorner,ntarget),stat=alloc_error) - allocate ( target_corner_lat_deg(ncorner,ntarget),stat=alloc_error) - status = NF_INQ_VARID(ncid, 'grid_corner_lon', lonid) - status = NF_GET_VAR_DOUBLE(ncid, lonid,target_corner_lon) - ! - target_corner_lon_deg=target_corner_lon - ! - IF (maxval(target_corner_lon)>10.0) target_corner_lon = deg2rad*target_corner_lon - - status = NF_INQ_VARID(ncid, 'grid_corner_lat', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_corner_lat) - ! - target_corner_lat_deg=target_corner_lat - ! - IF (maxval(target_corner_lat)>10.0) target_corner_lat = deg2rad*target_corner_lat - ! - ! for writing remapped data on file at the end of the program - ! - allocate ( target_center_lon(ntarget),stat=alloc_error) - allocate ( target_center_lat(ntarget),stat=alloc_error) - allocate ( target_area (ntarget),stat=alloc_error)!dbg - - status = NF_INQ_VARID(ncid, 'grid_center_lon', lonid) - status = NF_GET_VAR_DOUBLE(ncid, lonid,target_center_lon) - - status = NF_INQ_VARID(ncid, 'grid_center_lat', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_center_lat) - - status = NF_INQ_VARID(ncid, 'grid_area', latid) - status = NF_GET_VAR_DOUBLE(ncid, latid,target_area) - - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - !**************************************************** - ! - ! get dimension of cubed-sphere grid - ! - !**************************************************** - ! - WRITE(*,*) "get dimension of cubed-sphere data from file" - !status = nf_open('USGS-topo-cube3000.nc', 0, ncid) - status = nf_open(trim(input_topography_file), 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - status = NF_INQ_DIMID(ncid, 'grid_size', dimid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimid, n) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - ncube = INT(SQRT(DBLE(n/6))) - WRITE(*,*) "cubed-sphere dimension: ncube = ",ncube - WRITE(*,*) "average grid-spacing at the Equator (degrees):" ,90.0/ncube - - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - !**************************************************** - ! - ! compute weights for remapping - ! - !**************************************************** - ! - jall = ncube*ncube*12*10 !anticipated number of weights (cab be tweaked) - jmax_segments = 100000 !can be tweaked - - allocate (weights_all(jall,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index_all(jall,3),stat=alloc_error ) - allocate (weights_lgr_index_all(jall),stat=alloc_error ) - CALL overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& - jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) - ! - !**************************************************** - ! - ! read cubed-sphere 3km data - ! - !**************************************************** - ! - WRITE(*,*) "read cubed-sphere 3km data from file" - status = nf_open('USGS-topo-cube3000.nc', 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - - status = NF_INQ_DIMID(ncid, 'grid_size', dimid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_INQ_DIMLEN(ncid, dimid, n) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - ncube = INT(SQRT(DBLE(n/6))) - WRITE(*,*) "cubed-sphere dimension, ncube: ",ncube - - allocate ( landm_coslat(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'LANDM_COSLAT', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,landm_coslat) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of landm_coslat",MINVAL(landm_coslat),MAXVAL(landm_coslat) - ! - ! read LANDFRAC - ! - allocate ( landfrac(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'LANDFRAC', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,landfrac) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of landfrac",MINVAL(landfrac),MAXVAL(landfrac) - ! - ! read terr - ! - allocate ( terr(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'terr', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,terr) - - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of terr",MINVAL(terr),MAXVAL(terr) - allocate ( lat_terr(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for lat_terr' - stop - end if - status = NF_INQ_VARID(ncid, 'lat', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - status = NF_GET_VAR_DOUBLE(ncid, landid,lat_terr) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of lat",MINVAL(lat_terr),MAXVAL(lat_terr) - - allocate ( lon_terr(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for lon_terr' - stop - end if - status = NF_INQ_VARID(ncid, 'lon', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,lon_terr) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of lon",MINVAL(lon_terr),MAXVAL(lon_terr) - ! - ! - ! - allocate ( sgh30(n),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - - status = NF_INQ_VARID(ncid, 'SGH30', landid) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - - status = NF_GET_VAR_DOUBLE(ncid, landid,sgh30) - IF (status .NE. NF_NOERR) CALL HANDLE_ERR(status) - WRITE(*,*) "min/max of sgh30",MINVAL(sgh30),MAXVAL(sgh30) - - print *,"close file" - status = nf_close (ncid) - if (status .ne. NF_NOERR) call handle_err(status) - - WRITE(*,*) 'done reading in LANDM_COSLAT data from netCDF file' - ! - !********************************************************* - ! - ! do actual remapping - ! - !********************************************************* - ! - allocate (terr_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for terr_target' - stop - end if - allocate (landfrac_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac_target' - stop - end if - allocate (landm_coslat_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac_target' - stop - end if - allocate (sgh30_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for sgh30_target' - stop - end if - allocate (area_target(ntarget),stat=alloc_error ) - terr_target = 0.0 - landfrac_target = 0.0 - sgh30_target = 0.0 - landm_coslat_target = 0.0 - area_target = 0.0 - - tmp = 0.0 - do count=1,jall - i = weights_lgr_index_all(count) - wt = weights_all(count,1) - area_target (i) = area_target(i) + wt - end do - - - do count=1,jall - i = weights_lgr_index_all(count) - - ix = weights_eul_index_all(count,1) - iy = weights_eul_index_all(count,2) - ip = weights_eul_index_all(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix - - wt = weights_all(count,1) - terr_target (i) = terr_target (i) + wt*terr (ii)/area_target(i) - landfrac_target (i) = landfrac_target (i) + wt*landfrac (ii)/area_target(i) - landm_coslat_target(i) = landm_coslat_target(i) + wt*landm_coslat(ii)/area_target(i) - sgh30_target (i) = sgh30_target (i) + wt*sgh30 (ii)/area_target(i) - tmp = tmp+wt*terr(ii) - end do - ! - write(*,*) "tmp", tmp - WRITE(*,*) "max difference between target grid area and remapping software area",& - MAXVAL(target_area-area_target) - - do count=1,ntarget - if (terr_target(count)>8848.0) then - ! - ! max height is higher than Mount Everest - ! - write(*,*) "FATAL error: max height is higher than Mount Everest!" - write(*,*) "terr_target",count,terr_target(count) - write(*,*) "(lon,lat) locations of vertices of cell with excessive max height::" - do i=1,ncorner - write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) - end do - STOP - else if (terr_target(count)<-423.0) then - ! - ! min height is lower than Dead Sea - ! - write(*,*) "FATAL error: min height is lower than Dead Sea!" - write(*,*) "terr_target",count,terr_target(count) - write(*,*) "(lon,lat) locations of vertices of cell with excessive min height::" - do i=1,ncorner - write(*,*) target_corner_lon(i,count),target_corner_lat(i,count) - end do - STOP - else - - end if - end do - WRITE(*,*) "Elevation data passed min/max consistency check!" - WRITE(*,*) - - WRITE(*,*) "min/max of unsmoothed terr_target : ",MINVAL(terr_target ),MAXVAL(terr_target ) - WRITE(*,*) "min/max of landfrac_target : ",MINVAL(landfrac_target),MAXVAL(landfrac_target) - WRITE(*,*) "min/max of landm_coslat_target : ",& - MINVAL(landm_coslat_target),MAXVAL(landm_coslat_target) - WRITE(*,*) "min/max of var30_target : ",MINVAL(sgh30_target ),MAXVAL(sgh30_target ) - ! - ! compute mean height (globally) of topography about sea-level for target grid unfiltered elevation - ! - vol_target_un = 0.0 - area_target_total = 0.0 - DO i=1,ntarget - area_target_total = area_target_total+area_target(i) - vol_target_un = vol_target_un+terr_target(i)*area_target(i) - END DO - WRITE(*,*) "mean height (globally) of topography about sea-level for target grid unfiltered elevation",& - vol_target_un/area_target_total - - ! - ! diagnostics - ! - vol_source = 0.0 - allocate ( dA(ncube,ncube),stat=alloc_error ) - CALL EquiangularAllAreas(ncube, dA) - DO jp=1,6 - DO jy=1,ncube - DO jx=1,ncube - ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx - vol_source = vol_source+terr(ii)*dA(jx,jy) - END DO - END DO - END DO - WRITE(*,*) "volume of input cubed-sphere terrain :",vol_source - WRITE(*,*) "average elevation of input cubed-sphere terrain:",vol_source/(4.0*pi) - - DEALLOCATE(dA) - ! - ! - ! - allocate (sgh_target(ntarget),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for sgh_target' - stop - end if - ! - ! compute variance with respect to cubed-sphere data - ! - WRITE(*,*) "compute variance with respect to 3km cubed-sphere data: SGH" - - IF (lsmooth_terr) THEN - WRITE(*,*) "smoothing PHIS" - IF (lexternal_smooth_terr) THEN - WRITE(*,*) "using externally generated smoothed topography" - - status = nf_open(trim(smoothed_topography_file), 0, ncid) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - status = nf_close(ncid) - !status = nf_open('phis-smooth.nc', 0, ncid) - !IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS) - ! - IF (.NOT.ltarget_latlon) THEN - ! - !********************************************************* - ! - ! read in smoothed topography - ! - !********************************************************* - ! - status = NF_INQ_DIMID (ncid, 'ncol', ntarget_id ) - status = NF_INQ_DIMLEN(ncid, ntarget_id , ntarget_smooth) - IF (ntarget.NE.ntarget_smooth) THEN - WRITE(*,*) "mismatch in smoothed data-set and target grid specification" - WRITE(*,*) ntarget, ntarget_smooth - STOP - END IF - status = NF_INQ_VARID(ncid, 'PHIS', phisid) - ! - ! overwrite terr_target with smoothed version - ! - status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_target) - terr_target = terr_target/9.80616 - ELSE - ! - ! read in smoothed lat-lon topography - ! - status = NF_INQ_DIMID(ncid, 'lon', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlon_smooth) - status = NF_INQ_DIMID(ncid, 'lat', ntarget_id) - status = NF_INQ_DIMLEN(ncid, ntarget_id, nlat_smooth) - IF (nlon.NE.nlon_smooth.OR.nlat.NE.nlat_smooth) THEN - WRITE(*,*) "smoothed topography dimensions do not match target grid dimensions" - WRITE(*,*) "target grid : nlon ,nlat =",nlon,nlat - WRITE(*,*) "smoothed topo: nlon_smooth,nlat_smooth =",nlon_smooth,nlat_smooth - STOP - END IF - ALLOCATE(terr_smooth(nlon_smooth,nlat_smooth),stat=alloc_error) - status = NF_INQ_VARID(ncid, 'PHIS', phisid) - status = NF_GET_VAR_DOUBLE(ncid, phisid,terr_smooth) - ! - ! overwrite terr_target with smoothed version - ! - ii=1 - DO j=1,nlat - DO i=1,nlon - terr_target(ii) = terr_smooth(i,j)/9.80616 - ii=ii+1 - END DO - END DO - DEALLOCATE(terr_smooth) - END IF - ELSE - WRITE(*,*) "unstested software - uncomment this line of you know what you are doing!" - STOP - ! - !***************************************************** - ! - ! smoothing topography internally - ! - !***************************************************** - ! - WRITE(*,*) "internally smoothing orography" - ! CALL smooth(terr_target,ntarget,target_corner_lon,target_corner_lat) - ! - ! smooth topography internally - ! - ncoarse = n/(factor*factor) - ! - ! - ! - ncube_coarse = ncube/factor - WRITE(*,*) "resolution of coarse grid", 90.0/ncube_coarse - allocate ( terr_coarse(ncoarse),stat=alloc_error ) - if( alloc_error /= 0 ) then - print*,'Program could not allocate space for landfrac' - stop - end if - WRITE(*,*) "coarsening" - allocate ( dA_coarse(ncube_coarse,ncube_coarse),stat=alloc_error ) - CALL coarsen(terr,terr_coarse,factor,n,dA_coarse) - ! - ! - ! - vol_tmp = 0.0 - DO jp=1,6 - DO jy=1,ncube_coarse - DO jx=1,ncube_coarse - ii = (jp-1)*ncube_coarse*ncube_coarse+(jy-1)*ncube_coarse+jx - vol_tmp = vol_tmp+terr_coarse(ii)*dA_coarse(jx,jy) - END DO - END DO - END DO - WRITE(*,*) "volume of coarsened cubed-sphere terrain :",vol_source - WRITE(*,*) "difference between coarsened cubed-sphere data and input cubed-sphere data",& - vol_tmp-vol_source - - - - WRITE(*,*) "done coarsening" - - nreconstruction = 1 - IF (norder>1) THEN - IF (norder == 2) THEN - nreconstruction = 3 - ELSEIF (norder == 3) THEN - nreconstruction = 6 - END IF - ALLOCATE(recons (nreconstruction, ncoarse), STAT=status) - ALLOCATE(centroids(nreconstruction, ncoarse), STAT=status) - CALL get_reconstruction(terr_coarse,norder, nmono, recons, npd,da_coarse,& - ncube_coarse+1,nreconstruction,centroids) - SELECT CASE (nmono) - CASE (0) - WRITE(*,*) "coarse grid reconstructions are not filtered with shape-preesrving filter" - CASE (1) - WRITE(*,*) "coarse grid reconstructions are filtered with shape-preserving filter" - CASE DEFAULT - WRITE(*,*) "nmono out of range: ",nmono - STOP - END SELECT - SELECT CASE (0) - CASE (0) - WRITE(*,*) "coarse grid reconstructions are not filtered with positive definite filter" - CASE (1) - WRITE(*,*) "coarse grid reconstructions filtered with positive definite filter" - CASE DEFAULT - WRITE(*,*) "npd out of range: ",npd - STOP - END SELECT - END IF - - jall_coarse = (ncube*ncube*12) !anticipated number of weights - jmax_segments_coarse = jmax_segments!/factor ! - WRITE(*,*) "anticipated",jall_coarse - allocate (weights_all_coarse(jall_coarse,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index_all_coarse(jall_coarse,3),stat=alloc_error ) - allocate (weights_lgr_index_all_coarse(jall_coarse),stat=alloc_error ) - ! - ! - ! - CALL overlap_weights(weights_lgr_index_all_coarse,weights_eul_index_all_coarse,weights_all_coarse,& - jall_coarse,ncube_coarse,ngauss,ntarget,ncorner,jmax_segments_coarse,target_corner_lon,& - target_corner_lat,nreconstruction) - - WRITE(*,*) "MIN/MAX of area-weight [0:1]: ",& - MINVAL(weights_all_coarse(:,1)),MAXVAL(weights_all_coarse(:,1)) - ! - ! compute new weights - ! - - ! - ! do mapping - ! - terr_target = 0.0 - tmp = 0.0 - allocate ( area_target_coarse(ntarget),stat=alloc_error) - all_weights = 0.0 - area_target_coarse = 0.0 - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - wt = weights_all_coarse(count,1) - area_target_coarse (i) = area_target_coarse(i) + wt - all_weights = all_weights+wt - end do - WRITE(*,*) "sum of all weights (coarse to target) minus area of sphere : ",all_weights-4.0*pi - WRITE(*,*) "MIN/MAX of area_target_coarse [0:1]:",& - MINVAL(area_target_coarse),MAXVAL(area_target_coarse) - IF (norder==1) THEN - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - wt = weights_all_coarse(count,1) - - terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) - tmp = tmp+wt*terr_coarse(ii) - end do - ELSE IF (norder==2) THEN - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - IF (i>jall_coarse.OR.i<1) THEN - WRITE(*,*) i,jall_coarse - STOP - END IF - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& - ! - ! all constant terms - ! - terr_coarse(ii) & - - recons(1,ii)*centroids(1,ii) & - - recons(2,ii)*centroids(2,ii) & - ! - ! + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& - ! + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& - ! - ! + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& - )+& - ! - ! linear terms - ! - weights_all_coarse(count,2)*(& - - recons(1,ii)& - - ! - recons(3,ii)*2.0*centroids(1,ii)& - ! - recons(5,ii)* centroids(2,ii)& - )+& - ! - weights_all_coarse(count,3)*(& - recons(2,ii)& - ! - ! - recons(4,ii)*2.0*centroids(2,ii)& - ! - recons(5,ii)* centroids(1,ii)& - )& - ! - ! quadratic terms - ! - ! weights_all_coarse(count,4)*recons(3,ii)+& - ! weights_all_coarse(count,5)*recons(4,ii)+& - ! weights_all_coarse(count,6)*recons(5,ii) - )/area_target_coarse(i) - end do - DEALLOCATE(centroids) - DEALLOCATE(recons) - DEALLOCATE(weights_all_coarse) - - ELSE IF (norder==3) THEN - ! recons(4,:) = 0.0 - ! recons(5,:) = 0.0 - do count=1,jall_coarse - i = weights_lgr_index_all_coarse(count) - IF (i>jall_coarse.OR.i<1) THEN - WRITE(*,*) i,jall_coarse - STOP - END IF - ix = weights_eul_index_all_coarse(count,1) - iy = weights_eul_index_all_coarse(count,2) - ip = weights_eul_index_all_coarse(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube_coarse*ncube_coarse+(iy-1)*ncube_coarse+ix - - ! terr_target(i) = terr_target(i) + wt*terr_coarse(ii)/area_target_coarse(i) - - ! WRITE(*,*) count,area_target_coarse(i) - ! terr_target(i) = terr_target(i) + area_target_coarse(i) - ! - terr_target(i) = terr_target(i) + (weights_all_coarse(count,1)*(& - - - ! centroids(5,ii))/area_target_coarse(i)) - ! centroids(1,ii)/area_target_coarse(i)) - ! /area_target_coarse(i)) - - - - - ! - ! all constant terms - ! - terr_coarse(ii) & - - recons(1,ii)*centroids(1,ii) & - - recons(2,ii)*centroids(2,ii) & - ! - + recons(3,ii)*(2.0*centroids(1,ii)**2-centroids(3,ii))& - + recons(4,ii)*(2.0*centroids(2,ii)**2-centroids(4,ii))& - ! - + recons(5,ii)*(2.0*centroids(1,ii)*centroids(2,ii)-centroids(5,ii))& - )+& - ! - ! linear terms - ! - weights_all_coarse(count,2)*(& - - recons(1,ii)& - - - recons(3,ii)*2.0*centroids(1,ii)& - - recons(5,ii)* centroids(2,ii)& - )+& - ! - weights_all_coarse(count,3)*(& - recons(2,ii)& - ! - - recons(4,ii)*2.0*centroids(2,ii)& - - recons(5,ii)* centroids(1,ii)& - )+& - ! - ! quadratic terms - ! - weights_all_coarse(count,4)*recons(3,ii)+& - weights_all_coarse(count,5)*recons(4,ii)+& - weights_all_coarse(count,6)*recons(5,ii))/area_target_coarse(i) - end do - DEALLOCATE(centroids) - DEALLOCATE(recons) - DEALLOCATE(weights_all_coarse) - END IF - DEALLOCATE(area_target_coarse) - WRITE(*,*) "done smoothing" - END IF - ! - ! compute mean height (globally) of topography about sea-level for target grid filtered elevation - ! - vol_target = 0.0 - DO i=1,ntarget - vol_target = vol_target+terr_target(i)*area_target(i) - ! if (ABS(area_target(i)-area_target_coarse(i))>0.000001) THEN - ! WRITE(*,*) "xxx",area_target(i),area_target_coarse(i),area_target(i)-area_target_coarse(i) - ! STOP - ! END IF - END DO - WRITE(*,*) "mean height (globally) of topography about sea-level for target grid filtered elevation",& - vol_target/area_target_total - WRITE(*,*) "percentage change in mean height between filtered and unfiltered elevations",& - 100.0*(vol_target-vol_target_un)/vol_target_un - WRITE(*,*) "percentage change in mean height between input cubed-sphere and unfiltered elevations",& - 100.0*(vol_source-vol_target_un)/vol_source - - END IF - ! - ! Done internal smoothing - ! - WRITE(*,*) "min/max of terr_target : ",MINVAL(terr_target),MAXVAL(terr_target) - - if (lzero_out_ocean_point_phis) then - WRITE(*,*) "if ocean mask PHIS=0.0" - end if - - - sgh_target=0.0 - do count=1,jall - i = weights_lgr_index_all(count)!! - ! - ix = weights_eul_index_all(count,1) - iy = weights_eul_index_all(count,2) - ip = weights_eul_index_all(count,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - - wt = weights_all(count,1) - - if (lzero_out_ocean_point_phis.AND.landfrac_target(i).lt.0.01_r8) then - terr_target(i) = 0.0_r8 !5*terr_target(i) - end if - sgh_target(i) = sgh_target(i)+wt*((terr_target(i)-terr(ii))**2)/area_target(i) - end do - - - - - ! - ! zero out small values - ! - DO i=1,ntarget - IF (landfrac_target(i)<.001_r8) landfrac_target(i) = 0.0 - IF (sgh_target(i)<0.5) sgh_target(i) = 0.0 - IF (sgh30_target(i)<0.5) sgh30_target(i) = 0.0 - END DO - sgh_target = SQRT(sgh_target) - sgh30_target = SQRT(sgh30_target) - -!for centroid of mass -!wt is useful proxy for dA -print*,"cal oa" -allocate(oa_target(ntarget,nvar_dirOA),stat=alloc_error) -call OAdir(terr,ntarget,ncube,n,nvar_dirOA,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,target_center_lon,target_center_lat,lon_terr,lat_terr,area_target,oa_target)!OAx,OAy) -!call OAorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,lon_terr,lat_terr,area_target,oa_target) -!par -!OC - print*,"cal oc" - allocate(oc_target(ntarget),stat=alloc_error) - oc_target=0.0_r8 - call OC(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,area_target,sgh_target,terr_target,oc_target) - -!OL - print*,"cal ol" - allocate(ol_target(ntarget,nvar_dirOL),stat=alloc_error) - ol_target=0.0_r8 - !call OLorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,lon_terr,lat_terr,area_target,sgh_target,target_center_lat,target_center_lon,target_corner_lat_deg,target_corner_lon_deg,ol_target) - allocate(indexb(ntarget),stat=alloc_error) - indexb=0.0_r8 - do count=1,jall - i = weights_lgr_index_all(count) - indexb(i)=indexb(i)+1 - enddo - allocate(terrout(4,ntarget,maxval(indexb)),stat=alloc_error) - allocate(dxy(ntarget,nvar_dirOL),stat=alloc_error) - call OLdir(terr,ntarget,ncube,n,jall,nlon,nlat,maxval(indexb),nvar_dirOL,weights_lgr_index_all,weights_eul_index_all(:,1),weights_eul_index_all(:,2),weights_eul_index_all(:,3),weights_all,landfrac_target,target_center_lon,target_center_lat,target_corner_lon_deg,target_corner_lat_deg,lon_terr,lat_terr,sgh_target,area_target,ol_target,terrout,dxy) -!par - - WRITE(*,*) "min/max of sgh_target : ",MINVAL(sgh_target),MAXVAL(sgh_target) - WRITE(*,*) "min/max of sgh30_target : ",MINVAL(sgh30_target),MAXVAL(sgh30_target) - - DEALLOCATE(terr,weights_all,weights_eul_index_all,landfrac,landm_coslat) - - - - IF (ltarget_latlon) THEN -!#if 0 -! CALL wrtncdf_rll(nlon,nlat,lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& -! landm_coslat_target,target_center_lon,target_center_lat,.true.) -!#endif -print*,"output rll" - CALL wrtncdf_rll(nlon,nlat,nvar_dirOA,nvar_dirOL,maxval(indexb),lpole,ntarget,terr_target,landfrac_target,sgh_target,sgh30_target, oc_target,oa_target,ol_target,terrout,dxy,& - landm_coslat_target,target_center_lon,target_center_lat,.false.,output_topography_file) - - ELSE -!#if 0 -! CALL wrtncdf_unstructured(ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,& -! landm_coslat_target,target_center_lon,target_center_lat) -!#endif - print*,"output unstructure" - CALL wrtncdf_unstructured(nvar_dirOA,nvar_dirOL,maxval(indexb),ntarget,terr_target,landfrac_target,sgh_target,sgh30_target,oc_target,oa_target,ol_target,terrout,dxy,landm_coslat_target,target_center_lon,target_center_lat,output_topography_file) - END IF - - DEALLOCATE(terr_target,landfrac_target,sgh30_target,sgh_target,landm_coslat_target) -DEALLOCATE(oc_target) - -end program convterr - -! -! -! -!#if 0 -!subroutine wrtncdf_unstructured(n,terr,landfrac,sgh,sgh30,landm_coslat,lon,lat) -!#endif -subroutine wrtncdf_unstructured(nvar_dirOA,nvar_dirOL,indexb,n,terr,landfrac,sgh,sgh30,oc_in,oa_in,ol_in,terrout,dxy_in,landm_coslat,lon,lat,output) - - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - -# include - - ! - ! Dummy arguments - ! - integer, intent(in) :: n - real(r8),dimension(n) , intent(in) :: terr, landfrac,sgh,sgh30,lon, lat, landm_coslat - ! - ! Local variables - ! - character (len=512) :: fout ! NetCDF output file - - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: terrid,nid - integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid - integer :: status ! return value for error control of netcdf routin - integer :: i,j - integer, dimension(2) :: nc_lat_vid,nc_lon_vid - character (len=8) :: datestring - integer :: nc_gridcorn_id, lat_vid, lon_vid - - real(r8), parameter :: fillvalue = 1.d36 - integer, intent(in) :: nvar_dirOA,nvar_dirOL,indexb - character(len=512) :: output - integer :: ocid,varid,var2id,indexbid,terroutid(4) - integer :: oaid,olid,dxyid - integer :: oa1id,oa2id,oa3id,oa4id - integer :: ol1id,ol2id,ol3id,ol4id - integer, dimension(2) :: ocdim - integer, dimension(3) :: oadim,oldim,terroutdim - real(r8),dimension(n) , intent(in) :: oc_in - real(r8),dimension(n,nvar_dirOA) , intent(in) :: oa_in - real(r8),dimension(n,nvar_dirOL) , intent(in) :: ol_in - real(r8),dimension(4,n,indexb),intent(in) :: terrout - real(r8),dimension(n,nvar_dirOL),intent(in) :: dxy_in - character*20,dimension(4) :: terroutchar - real(r8),dimension(n) :: oc - real(r8),dimension(n,nvar_dirOA) :: oa - real(r8),dimension(n,nvar_dirOL) :: ol - real(r8),dimension(n,nvar_dirOL) :: dxy - character*20 :: numb - write(numb,"(i0.1)") nvar_dirOL - print*,"dir number", nvar_dirOL - !fout='final-'//adjustl(trim(numb))//'.nc' - fout=output - oc=oc_in - oa=oa_in - ol=ol_in - dxy=dxy_in - ! - ! Create NetCDF file for output - ! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create dimensions for output - ! - status = nf_def_dim (foutid, 'ncol', n, nid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'nvar_dirOA', nvar_dirOA, varid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'nvar_dirOL', nvar_dirOL, var2id) - if (status .ne. NF_NOERR) call handle_err(status) - !status = nf_def_dim (foutid, 'indexb',23, indexbid) - status = nf_def_dim (foutid, 'indexb', indexb, indexbid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create variable for output - ! - print *,"Create variable for output" - status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 1, nid, terrid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 1, nid, landfracid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'SGH', NF_DOUBLE, 1, nid, sghid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 1, nid, sgh30id) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 1, nid, landm_coslatid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, nid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, nid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_var (foutid,'OC', NF_DOUBLE, 1, nid, ocid) - oadim(1)=nid - oadim(2)=varid - status = nf_def_var (foutid,'OA', NF_DOUBLE, 2, oadim, oaid) - oldim(1)=nid - oldim(2)=var2id - status = nf_def_var (foutid,'OL', NF_DOUBLE, 2, oldim, olid) -!#if 0 -! terroutdim(1)=nid -! terroutdim(2)=indexbid -! !name -! terroutchar(1)="terr" -! terroutchar(2)="terrx" -! terroutchar(3)="terry" -! terroutchar(4)="wt" -! do i=1,4 -! status = nf_def_var (foutid, terroutchar(i), NF_DOUBLE, 2, & -! terroutdim, terroutid(i)) -! enddo -! !dxy -! status = nf_def_var (foutid,'dxy', NF_DOUBLE, 2, oldim, dxyid) -!#endif - ! - ! Create attributes for output variables - ! - status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') - status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') - status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) - ! status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from USGS 30-sec data') - - status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & - 'standard deviation of 3km cubed-sphere elevation and target grid elevation') - status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') - ! status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & - 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') - status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') - ! status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') - status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') - ! status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') - - - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 50, 'USGS 30-sec dataset binned to ncube3000 (cube-sphere) grid') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,oaid,'note', 40, '(2)+1 in nvar_dirOA to avoid bug in io') -!#if 0 -! do i=1,4 -! status = nf_put_att_double (foutid, terroutid(i),& -! 'missing_value', nf_double, 1,fillvalue) -! status = nf_put_att_double (foutid, terroutid(i),& -! '_FillValue' , nf_double, 1,fillvalue) -! enddo -!#endif - ! - ! End define mode for output file - ! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Write variable for output - ! - print*,"writing oc data",MINVAL(oc),MAXVAL(oc) - status = nf_put_var_double (foutid, ocid, oc) - if (status .ne. NF_NOERR) call handle_err(status) - !oa,ol - print*,"writing oa data",MINVAL(oa),MAXVAL(oa) - status = nf_put_var_double (foutid, oaid, oa) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"writing ol data",MINVAL(ol),MAXVAL(ol) - status = nf_put_var_double (foutid, olid, ol) - if (status .ne. NF_NOERR) call handle_err(status) -!#if 0 -! do i=1,4 -! status = nf_put_att_double (foutid, terroutid(i),& -! 'missing_value', nf_double, 1,fillvalue) -! status = nf_put_att_double (foutid, terroutid(i),& -! '_FillValue' , nf_double, 1,fillvalue) -! print*,"writing"//terroutchar(i)//" data",& -! MINVAL(terrout(i,:,:)),MAXVAL(terrout(i,:,:)) -! status = nf_put_var_double (foutid, terroutid(i), terrout(i,:,:)) -! if (status .ne. NF_NOERR) call handle_err(status) -! enddo -!#endif -!#if 0 -! print*,"writing dxy data",MINVAL(dxy),MAXVAL(dxy) -! status = nf_put_var_double (foutid, dxyid, dxy) -! if (status .ne. NF_NOERR) call handle_err(status) -!#endif - print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) - status = nf_put_var_double (foutid, terrid, terr*9.80616) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" - - print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) - status = nf_put_var_double (foutid, landfracid, landfrac) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing landfrac data" - - print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) - status = nf_put_var_double (foutid, sghid, sgh) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh data" - - print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) - status = nf_put_var_double (foutid, sgh30id, sgh30) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - - print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) - status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - ! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, lat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lon) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" - ! - ! Close output file - ! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -end subroutine wrtncdf_unstructured -! -!************************************************************** -! -! if target grid is lat-lon output structured -! -!************************************************************** -! - -!#if 0 -!subroutine wrtncdf_rll(nlon,nlat,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine) -!#endif -subroutine wrtncdf_rll(nlon,nlat,nvar_dirOA,nvar_dirOL,indexb,lpole,n,terr_in,landfrac_in,sgh_in,sgh30_in,oc_in,oa_in,ol_in,terrout,dxy_in,landm_coslat_in,lon,lat,lprepare_fv_smoothing_routine,output) - - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - -# include - - ! - ! Dummy arguments - ! - integer, intent(in) :: n,nlon,nlat,nvar_dirOA,nvar_dirOL,indexb - ! - ! lprepare_fv_smoothing_routine is to make a NetCDF file that can be used with the CAM-FV smoothing software - ! - logical , intent(in) :: lpole,lprepare_fv_smoothing_routine - real(r8),dimension(n) , intent(in) :: terr_in, landfrac_in,sgh_in,sgh30_in,lon, lat, landm_coslat_in - real(r8),dimension(n) , intent(in) :: oc_in - real(r8),dimension(n,nvar_dirOA) , intent(in) :: oa_in - real(r8),dimension(n,nvar_dirOL) , intent(in) :: ol_in - real(r8),dimension(4,n,indexb),intent(in) :: terrout - real(r8),dimension(n,nvar_dirOL),intent(in) :: dxy_in - character*20,dimension(4) :: terroutchar - character(len=512),intent(in) :: output - ! - ! Local variables - ! - character (len=512):: fout ! NetCDF output file - integer :: foutid ! Output file id - integer :: lonid, lonvid - integer :: latid, latvid - integer :: terrid,nid - integer :: ocid,varid,var2id,indexbid,terroutid(4) - integer :: oaid,olid,dxyid - integer :: oa1id,oa2id,oa3id,oa4id - integer :: ol1id,ol2id,ol3id,ol4id - integer :: terrdim,landfracid,sghid,sgh30id,landm_coslatid - integer :: status ! return value for error control of netcdf routin - integer :: i,j - integer, dimension(2) :: nc_lat_vid,nc_lon_vid - character (len=8) :: datestring - integer :: nc_gridcorn_id, lat_vid, lon_vid - real(r8), parameter :: fillvalue = 1.d36 - real(r8) :: ave - - real(r8),dimension(nlon) :: lonar ! longitude array - real(r8),dimension(nlat) :: latar ! latitude array - - integer, dimension(2) :: htopodim,landfdim,sghdim,sgh30dim,landmcoslatdim -integer, dimension(2) :: ocdim -integer, dimension(3) :: oadim,oldim,terroutdim - real(r8),dimension(n) :: terr, landfrac,sgh,sgh30,landm_coslat - real(r8),dimension(n) :: oc - real(r8),dimension(n,nvar_dirOA) :: oa - real(r8),dimension(n,nvar_dirOL) :: ol - real(r8),dimension(n,nvar_dirOL) :: dxy - character*20 :: numb -!print*,"nlon nlat n",nlon, nlat, n - IF (nlon*nlat.NE.n) THEN - WRITE(*,*) "inconsistent input for wrtncdf_rll" - STOP - END IF - ! - ! we assume that the unstructured layout of the lat-lon grid is ordered in latitude rows, that is, - ! unstructured index n is given by - ! - ! n = (j-1)*nlon+i - ! - ! where j is latitude index and i longitude index - ! - do i = 1,nlon - lonar(i)= lon(i) - enddo - do j = 1,nlat - latar(j)= lat((j-1)*nlon+1) - enddo - - terr = terr_in - sgh=sgh_in - sgh30 =sgh30_in - landfrac = landfrac_in - landm_coslat = landm_coslat_in - oc=oc_in - oa=oa_in - ol=ol_in - dxy=dxy_in - - if (lpole) then - write(*,*) "average pole control volume" - ! - ! North pole - terr - ! - ave = 0.0 - do i=1,nlon - ave = ave + terr_in(i) - end do - terr(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + terr_in(i) - end do - terr(n-(nlon+1):n) = ave/DBLE(nlon) - !oc - ! North pole - terr - ave = 0.0 - do i=1,nlon - ave = ave + oc_in(i) - end do - oc(1:nlon) = ave/DBLE(nlon) - ! South pole - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + oc_in(i) - end do - oc(n-(nlon+1):n) = ave/DBLE(nlon) - !oa - ! North pole - terr -do j =1,nvar_dirOA - ave = 0.0 - do i=1,nlon - ave = ave + oa_in(i,j) - end do - oa(1:nlon,j) = ave/DBLE(nlon) - ! South pole - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + oa_in(i,j) - end do - oa(n-(nlon+1):n,j) = ave/DBLE(nlon) -enddo - !ol -!#if 0 -! North pole - terr -do j =1,nvar_dirOL - ave = 0.0 - do i=1,nlon - ave = ave + ol_in(i,j) - end do - ol(1:nlon,j) = ave/DBLE(nlon) - ! South pole - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + ol_in(j,i) - end do - ol(n-(nlon+1):n,j) = ave/DBLE(nlon) -enddo -!#endif - - ! - ! North pole - sgh - ! - ave = 0.0 - do i=1,nlon - ave = ave + sgh_in(i) - end do - sgh(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + sgh_in(i) - end do - sgh(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - sgh30 - ! - ave = 0.0 - do i=1,nlon - ave = ave + sgh30_in(i) - end do - sgh30(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + sgh30_in(i) - end do - sgh30(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - landfrac - ! - ave = 0.0 - do i=1,nlon - ave = ave + landfrac_in(i) - end do - landfrac(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + landfrac_in(i) - end do - landfrac(n-(nlon+1):n) = ave/DBLE(nlon) - - ! - ! North pole - landm_coslat - ! - ave = 0.0 - do i=1,nlon - ave = ave + landm_coslat_in(i) - end do - landm_coslat(1:nlon) = ave/DBLE(nlon) - ! - ! South pole - ! - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + landm_coslat_in(i) - end do - landm_coslat(n-(nlon+1):n) = ave/DBLE(nlon) - -!dxy - do j=1,4 - ave = 0.0 - do i=n-(nlon+1),n - ave = ave + dxy(j,i) - end do - dxy(j,n-(nlon+1):n) = ave/DBLE(nlon) - enddo -!dxy - end if - ! - write(numb,"(i0.1)") nvar_dirOL - print*,"dir number", nvar_dirOL - - - !fout='final-'//adjustl(trim(numb))//'.nc' - fout=output - ! - ! Create NetCDF file for output - ! - print *,"Create NetCDF file for output" - status = nf_create (fout, NF_64BIT_OFFSET , foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create dimensions for output - ! - print *,"Create dimensions for output" - status = nf_def_dim (foutid, 'lon', nlon, lonid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'lat', nlat, latid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'nvar_dirOA', nvar_dirOA, varid) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'nvar_dirOL', nvar_dirOL, var2id) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_def_dim (foutid, 'indexb', indexb, indexbid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Create variable for output - ! - print *,"Create variable for output" - ocdim(1)=lonid - ocdim(2)=latid - status = nf_def_var (foutid,'OC', NF_DOUBLE, 2, ocdim, ocid) - oadim(1)=lonid - oadim(2)=latid - oadim(3)=varid - status = nf_def_var (foutid,'OA', NF_DOUBLE, 3, oadim, oaid) - oldim(1)=lonid - oldim(2)=latid - oldim(3)=var2id - status = nf_def_var (foutid,'OL', NF_DOUBLE, 3, oldim, olid) - terroutdim(1)=lonid - terroutdim(2)=latid - terroutdim(3)=indexbid - !name - terroutchar(1)="terr" - terroutchar(2)="terrx" - terroutchar(3)="terry" - terroutchar(4)="wt" -!#if 0 - do i=1,4 - status = nf_def_var (foutid, terroutchar(i), NF_DOUBLE, 3, & - terroutdim, terroutid(i)) - enddo -!#endif - !dxy - status = nf_def_var (foutid,'dxy', NF_DOUBLE, 3, oldim, dxyid) -!#endif - -!#if 0 -! status = nf_def_var (foutid,'OL1', NF_DOUBLE, 2, ocdim, ol1id) -! status = nf_def_var (foutid,'OL2', NF_DOUBLE, 2, ocdim, ol2id) -! status = nf_def_var (foutid,'OL3', NF_DOUBLE, 2, ocdim, ol3id) -! status = nf_def_var (foutid,'OL4', NF_DOUBLE, 2, ocdim, ol4id) -! status = nf_def_var (foutid,'OA1', NF_DOUBLE, 2, ocdim, oa1id) -! status = nf_def_var (foutid,'OA2', NF_DOUBLE, 2, ocdim, oa2id) -! status = nf_def_var (foutid,'OA3', NF_DOUBLE, 2, ocdim, oa3id) -! status = nf_def_var (foutid,'OA4', NF_DOUBLE, 2, ocdim, oa4id) -!#endif - - htopodim(1)=lonid - htopodim(2)=latid - - if (lprepare_fv_smoothing_routine) then - status = nf_def_var (foutid,'htopo', NF_DOUBLE, 2, htopodim, terrid) - else - status = nf_def_var (foutid,'PHIS', NF_DOUBLE, 2, htopodim, terrid) - end if - if (status .ne. NF_NOERR) call handle_err(status) - - landfdim(1)=lonid - landfdim(2)=latid - - if (lprepare_fv_smoothing_routine) then - status = nf_def_var (foutid,'ftopo', NF_DOUBLE, 2, landfdim, landfracid) - else - status = nf_def_var (foutid,'LANDFRAC', NF_DOUBLE, 2, landfdim, landfracid) - end if - - if (status .ne. NF_NOERR) call handle_err(status) - - sghdim(1)=lonid - sghdim(2)=latid - - status = nf_def_var (foutid,'SGH', NF_DOUBLE, 2, sghdim, sghid) - if (status .ne. NF_NOERR) call handle_err(status) - - sgh30dim(1)=lonid - sgh30dim(2)=latid - - status = nf_def_var (foutid,'SGH30', NF_DOUBLE, 2, sgh30dim, sgh30id) - if (status .ne. NF_NOERR) call handle_err(status) - - landmcoslatdim(1)=lonid - landmcoslatdim(2)=latid - - status = nf_def_var (foutid,'LANDM_COSLAT', NF_DOUBLE, 2, landmcoslatdim, landm_coslatid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lat', NF_DOUBLE, 1, latid, latvid) - if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_def_var (foutid,'lon', NF_DOUBLE, 1, lonid, lonvid) - if (status .ne. NF_NOERR) call handle_err(status) - - ! - ! Create attributes for output variables - ! - status = nf_put_att_text (foutid,terrid,'long_name', 21, 'surface geopotential') - status = nf_put_att_text (foutid,terrid,'units', 5, 'm2/s2') - status = nf_put_att_text (foutid,terrid,'filter', 35, 'area averaged from ncube3000 data') - status = nf_put_att_double (foutid, terrid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, terrid, '_FillValue' , nf_double, 1, fillvalue) - - - status = nf_put_att_double (foutid, sghid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sghid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sghid, 'long_name' , 48, & - 'standard deviation of 3km cubed-sphere elevation and target grid elevation') - status = nf_put_att_text (foutid, sghid, 'units' , 1, 'm') - status = nf_put_att_text (foutid, sghid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, sgh30id, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, sgh30id, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, sgh30id, 'long_name' , 49, & - 'standard deviation of 30s elevation from 3km cubed-sphere cell average height') - status = nf_put_att_text (foutid, sgh30id, 'units' , 1, 'm') - status = nf_put_att_text (foutid, sgh30id, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landm_coslatid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landm_coslatid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landm_coslatid, 'long_name' , 23, 'smoothed land fraction') - status = nf_put_att_text (foutid, landm_coslatid, 'filter' , 4, 'none') - - status = nf_put_att_double (foutid, landfracid, 'missing_value', nf_double, 1, fillvalue) - status = nf_put_att_double (foutid, landfracid, '_FillValue' , nf_double, 1, fillvalue) - status = nf_put_att_text (foutid, landfracid, 'long_name', 21, 'gridbox land fraction') - status = nf_put_att_text (foutid, landfracid, 'filter', 40, 'area averaged from 30-sec USGS raw data') - - - status = nf_put_att_text (foutid,latvid,'long_name', 8, 'latitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,latvid,'units', 13, 'degrees_north') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,latvid,'units', 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,lonvid,'long_name', 9, 'longitude') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,lonvid,'units', 12, 'degrees_east') - if (status .ne. NF_NOERR) call handle_err(status) - ! status = nf_put_att_text (foutid,lonvid,'units' , 21, 'cell center locations') - ! if (status .ne. NF_NOERR) call handle_err(status) - - status = nf_put_att_text (foutid,NF_GLOBAL,'source', 27, 'USGS 30-sec dataset GTOPO30') - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,NF_GLOBAL,'title', 24, '30-second USGS topo data') - if (status .ne. NF_NOERR) call handle_err(status) - call DATE_AND_TIME(DATE=datestring) - status = nf_put_att_text (foutid,NF_GLOBAL,'history',25, 'Written on date: ' // datestring ) - if (status .ne. NF_NOERR) call handle_err(status) - status = nf_put_att_text (foutid,oaid,'note', 40, '(2)+1 in nvar_dirOA to avoid bug in io') - do i=1,4 - status = nf_put_att_double (foutid, terroutid(i),& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, terroutid(i),& - '_FillValue' , nf_double, 1,fillvalue) - enddo - - status = nf_put_att_double (foutid, oa1id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa1id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa2id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa2id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa3id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa3id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa4id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, oa4id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol1id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol1id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol2id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol2id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol3id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol3id,& - '_FillValue' , nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol4id,& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, ol4id,& - '_FillValue' , nf_double, 1,fillvalue) - ! - ! End define mode for output file - ! - status = nf_enddef (foutid) - if (status .ne. NF_NOERR) call handle_err(status) - ! - ! Write variable for output -print*,"writing oc data",MINVAL(oc),MAXVAL(oc) -status = nf_put_var_double (foutid, ocid, oc) -if (status .ne. NF_NOERR) call handle_err(status) -!oa,ol -print*,"writing oa data",MINVAL(oa),MAXVAL(oa) -status = nf_put_var_double (foutid, oaid, oa) -if (status .ne. NF_NOERR) call handle_err(status) -print*,"writing ol data",MINVAL(ol),MAXVAL(ol) -status = nf_put_var_double (foutid, olid, ol) - -!============ -#if 0 -print*,"writing oa1 data",MINVAL(oa),MAXVAL(oa) -status = nf_put_var_double (foutid, oa1id, oa(:,1)) -if (status .ne. NF_NOERR) call handle_err(status) -print*,"writing ol1 data",MINVAL(ol),MAXVAL(ol) -status = nf_put_var_double (foutid, ol1id, ol(:,1)) -print*,"writing oa2 data",MINVAL(oa),MAXVAL(oa) -status = nf_put_var_double (foutid, oa2id, oa(:,2)) -if (status .ne. NF_NOERR) call handle_err(status) -print*,"writing ol2 data",MINVAL(ol),MAXVAL(ol) -status = nf_put_var_double (foutid, ol2id, ol(:,2)) -print*,"writing oa3 data",MINVAL(oa),MAXVAL(oa) -status = nf_put_var_double (foutid, oa3id, oa(:,3)) -if (status .ne. NF_NOERR) call handle_err(status) -print*,"writing ol3 data",MINVAL(ol),MAXVAL(ol) -status = nf_put_var_double (foutid, ol3id, ol(:,3)) -print*,"writing oa4 data",MINVAL(oa),MAXVAL(oa) -status = nf_put_var_double (foutid, oa4id, oa(:,4)) -if (status .ne. NF_NOERR) call handle_err(status) -print*,"writing ol4 data",MINVAL(ol),MAXVAL(ol) -status = nf_put_var_double (foutid, ol4id, ol(:,4)) -#endif -!=========== - - -if (status .ne. NF_NOERR) call handle_err(status) -!#if 0 - do i=1,4 - status = nf_put_att_double (foutid, terroutid(i),& - 'missing_value', nf_double, 1,fillvalue) - status = nf_put_att_double (foutid, terroutid(i),& - '_FillValue' , nf_double, 1,fillvalue) - print*,"writing"//terroutchar(i)//" data",& - MINVAL(terrout(i,:,:)),MAXVAL(terrout(i,:,:)) - status = nf_put_var_double (foutid, terroutid(i), terrout(i,:,:)) - if (status .ne. NF_NOERR) call handle_err(status) - enddo -!#endif - -!#if 0 - print*,"writing dxy data",MINVAL(dxy),MAXVAL(dxy) - status = nf_put_var_double (foutid, dxyid, dxy) - if (status .ne. NF_NOERR) call handle_err(status) -!#endif - ! - print*,"writing terrain data",MINVAL(terr),MAXVAL(terr) - if (lprepare_fv_smoothing_routine) then - status = nf_put_var_double (foutid, terrid, terr) - else - status = nf_put_var_double (foutid, terrid, terr*9.80616) - end if - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing terrain data" - - print*,"writing landfrac data",MINVAL(landfrac),MAXVAL(landfrac) - status = nf_put_var_double (foutid, landfracid, landfrac) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing landfrac data" - - print*,"writing sgh data",MINVAL(sgh),MAXVAL(sgh) - status = nf_put_var_double (foutid, sghid, sgh) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh data" - - print*,"writing sgh30 data",MINVAL(sgh30),MAXVAL(sgh30) - status = nf_put_var_double (foutid, sgh30id, sgh30) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - - print*,"writing landm_coslat data",MINVAL(landm_coslat),MAXVAL(landm_coslat) - status = nf_put_var_double (foutid, landm_coslatid, landm_coslat) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing sgh30 data" - ! - print*,"writing lat data" - status = nf_put_var_double (foutid, latvid, latar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lat data" - - print*,"writing lon data" - status = nf_put_var_double (foutid, lonvid, lonar) - if (status .ne. NF_NOERR) call handle_err(status) - print*,"done writing lon data" - ! - ! Close output file - ! - print *,"close file" - status = nf_close (foutid) - if (status .ne. NF_NOERR) call handle_err(status) -end subroutine wrtncdf_rll -!************************************************************************ -!!handle_err -!************************************************************************ -! -!!ROUTINE: handle_err -!!DESCRIPTION: error handler -!-------------------------------------------------------------------------- - -subroutine handle_err(status) - - implicit none - -# include - - integer status - - if (status .ne. nf_noerr) then - print *, nf_strerror(status) - stop 'Stopped' - endif - -end subroutine handle_err - - -SUBROUTINE coarsen(f,fcoarse,nf,n,dA_coarse) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (R8), DIMENSION(n) , INTENT(IN) :: f - REAL (R8), DIMENSION(n/nf), INTENT(OUT) :: fcoarse - INTEGER, INTENT(in) :: n,nf - REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf),INTENT(OUT) :: dA_coarse - !must be an even number - ! - ! local workspace - ! - ! ncube = INT(SQRT(DBLE(n/6))) - - REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6))),INT(SQRT(DBLE(n/6)))):: dA - REAL (R8) :: sum, sum_area,tmp - INTEGER :: jx,jy,jp,ii,ii_coarse,coarse_ncube,ncube - INTEGER :: jx_coarse,jy_coarse,jx_s,jy_s - - - ! REAL(R8), DIMENSION(INT(SQRT(DBLE(n/6)))/nf,INT(SQRT(DBLE(n/6)))/nf) :: dAtmp - - ncube = INT(SQRT(DBLE(n/6))) - coarse_ncube = ncube/nf - - IF (ABS(DBLE(ncube)/DBLE(nf)-coarse_ncube)>0.000001) THEN - WRITE(*,*) "ncube/nf must be an integer" - WRITE(*,*) "ncube and nf: ",ncube,nf - STOP - END IF - - da_coarse = 0.0 - - WRITE(*,*) "compute all areas" - CALL EquiangularAllAreas(ncube, dA) - ! CALL EquiangularAllAreas(coarse_ncube, dAtmp)!dbg - tmp = 0.0 - DO jp=1,6 - DO jy_coarse=1,coarse_ncube - DO jx_coarse=1,coarse_ncube - ! - ! inner loop - ! - sum = 0.0 - sum_area = 0.0 - DO jy_s=1,nf - jy = (jy_coarse-1)*nf+jy_s - DO jx_s=1,nf - jx = (jx_coarse-1)*nf+jx_s - ii = (jp-1)*ncube*ncube+(jy-1)*ncube+jx - sum = sum +f(ii)*dA(jx,jy) - sum_area = sum_area+dA(jx,jy) - ! WRITE(*,*) "jx,jy",jx,jy - END DO - END DO - tmp = tmp+sum_area - da_coarse(jx_coarse,jy_coarse) = sum_area - ! WRITE(*,*) "jx_coarse,jy_coarse",jx_coarse,jy_coarse,& - ! da_coarse(jx_coarse,jy_coarse)-datmp(jx_coarse,jy_coarse) - ii_coarse = (jp-1)*coarse_ncube*coarse_ncube+(jy_coarse-1)*coarse_ncube+jx_coarse - fcoarse(ii_coarse) = sum/sum_area - END DO - END DO - END DO - WRITE(*,*) "coarsened surface area",tmp-4.0*3.141592654 -END SUBROUTINE COARSEN - -SUBROUTINE overlap_weights(weights_lgr_index_all,weights_eul_index_all,weights_all,& - jall,ncube,ngauss,ntarget,ncorner,jmax_segments,target_corner_lon,target_corner_lat,nreconstruction) - use shr_kind_mod, only: r8 => shr_kind_r8 - use remap - IMPLICIT NONE - - - INTEGER, INTENT(INOUT) :: jall !anticipated number of weights - INTEGER, INTENT(IN) :: ncube, ngauss, ntarget, jmax_segments, ncorner, nreconstruction - - INTEGER, DIMENSION(jall,3), INTENT(OUT) :: weights_eul_index_all - REAL(R8), DIMENSION(jall,nreconstruction) , INTENT(OUT) :: weights_all - INTEGER, DIMENSION(jall) , INTENT(OUT) :: weights_lgr_index_all - - REAL(R8), DIMENSION(ncorner,ntarget), INTENT(IN) :: target_corner_lon, target_corner_lat - - INTEGER, DIMENSION(ncorner+1) :: ipanel_array, ipanel_tmp - REAL(R8), DIMENSION(ncorner) :: lat, lon - REAL(R8), DIMENSION(0:ncube+2):: xgno, ygno - REAL(R8), DIMENSION(0:ncorner+1) :: xcell, ycell - - REAL(R8), DIMENSION(ngauss) :: gauss_weights, abscissae - - REAL(R8) :: da, tmp, alpha, beta - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: pih = 0.50*pi - INTEGER :: i, j,ncorner_this_cell,k,ip,ipanel,ii,jx,jy,jcollect - integer :: alloc_error - - REAL (r8), PARAMETER :: rad2deg = 180.0/pi - - real(r8), allocatable, dimension(:,:) :: weights - integer , allocatable, dimension(:,:) :: weights_eul_index - - - LOGICAL:: ldbg = .FAlSE. - - INTEGER :: jall_anticipated - - jall_anticipated = jall - - ipanel_array = -99 - ! - da = pih/DBLE(ncube) - xgno(0) = -bignum - DO i=1,ncube+1 - xgno(i) = TAN(-piq+(i-1)*da) - END DO - xgno(ncube+2) = bignum - ygno = xgno - - CALL glwp(ngauss,gauss_weights,abscissae) - - - allocate (weights(jmax_segments,nreconstruction),stat=alloc_error ) - allocate (weights_eul_index(jmax_segments,2),stat=alloc_error ) - - tmp = 0.0 - jall = 1 - DO i=1,ntarget - WRITE(*,*) "cell",i," ",100.0*DBLE(i)/DBLE(ntarget),"% done" - ! - !--------------------------------------------------- - ! - ! determine how many vertices the cell has - ! - !--------------------------------------------------- - ! - CALL remove_duplicates_latlon(ncorner,target_corner_lon(:,i),target_corner_lat(:,i),& - ncorner_this_cell,lon,lat,1.0E-10,ldbg) - - IF (ldbg) THEN - WRITE(*,*) "number of vertices ",ncorner_this_cell - WRITE(*,*) "vertices locations lon,",lon(1:ncorner_this_cell)*rad2deg - WRITE(*,*) "vertices locations lat,",lat(1:ncorner_this_cell)*rad2deg - DO j=1,ncorner_this_cell - WRITE(*,*) lon(j)*rad2deg, lat(j)*rad2deg - END DO - WRITE(*,*) " " - END IF - ! - !--------------------------------------------------- - ! - ! determine how many and which panels the cell spans - ! - !--------------------------------------------------- - ! - DO j=1,ncorner_this_cell - CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ipanel_tmp(j), .TRUE.) - IF (ldbg) WRITE(*,*) "ipanel for corner ",j," is ",ipanel_tmp(j) - END DO - ipanel_tmp(ncorner_this_cell+1) = ipanel_tmp(1) - ! make sure to include possible overlap areas not on the face the vertices are located - IF (MINVAL(lat(1:ncorner_this_cell))<-pi/6.0) THEN - ! include South-pole panel in search - ipanel_tmp(ncorner_this_cell+1) = 5 - IF (ldbg) WRITE(*,*) "add panel 5 to search" - END IF - IF (MAXVAL(lat(1:ncorner_this_cell))>pi/6.0) THEN - ! include North-pole panel in search - ipanel_tmp(ncorner_this_cell+1) = 6 - IF (ldbg) WRITE(*,*) "add panel 6 to search" - END IF - ! - ! remove duplicates in ipanel_tmp - ! - CALL remove_duplicates_integer(ncorner_this_cell+1,ipanel_tmp(1:ncorner_this_cell+1),& - k,ipanel_array(1:ncorner_this_cell+1)) - ! - !--------------------------------------------------- - ! - ! loop over panels with possible overlap areas - ! - !--------------------------------------------------- - ! - DO ip = 1,k - ipanel = ipanel_array(ip) - DO j=1,ncorner_this_cell - ii = ipanel - CALL CubedSphereABPFromRLL(lon(j), lat(j), alpha, beta, ii,.FALSE.) - IF (j==1) THEN - jx = CEILING((alpha + piq) / da) - jy = CEILING((beta + piq) / da) - END IF - xcell(ncorner_this_cell+1-j) = TAN(alpha) - ycell(ncorner_this_cell+1-j) = TAN(beta) - END DO - xcell(0) = xcell(ncorner_this_cell) - ycell(0) = ycell(ncorner_this_cell) - xcell(ncorner_this_cell+1) = xcell(1) - ycell(ncorner_this_cell+1) = ycell(1) - - jx = MAX(MIN(jx,ncube+1),0) - jy = MAX(MIN(jy,ncube+1),0) - - CALL compute_weights_cell(xcell(0:ncorner_this_cell+1),ycell(0:ncorner_this_cell+1),& - jx,jy,nreconstruction,xgno,ygno,& - 1, ncube+1, 1,ncube+1, tmp,& - ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& - ncube,0,ncorner_this_cell,ldbg) - - weights_all(jall:jall+jcollect-1,1:nreconstruction) = weights(1:jcollect,1:nreconstruction) - - weights_eul_index_all(jall:jall+jcollect-1,1:2) = weights_eul_index(1:jcollect,:) - weights_eul_index_all(jall:jall+jcollect-1, 3) = ipanel - weights_lgr_index_all(jall:jall+jcollect-1 ) = i - - jall = jall+jcollect - IF (jall>jall_anticipated) THEN - WRITE(*,*) "more weights than anticipated" - WRITE(*,*) "increase jall" - STOP - END IF - IF (ldbg) WRITE(*,*) "jcollect",jcollect - END DO - END DO - jall = jall-1 - WRITE(*,*) "sum of all weights divided by surface area of sphere =",tmp/(4.0*pi) - WRITE(*,*) "actual number of weights",jall - WRITE(*,*) "anticipated number of weights",jall_anticipated - IF (jall>jall_anticipated) THEN - WRITE(*,*) "anticipated number of weights < actual number of weights" - WRITE(*,*) "increase jall!" - STOP - END IF - WRITE(*,*) MINVAL(weights_all(1:jall,1)),MAXVAL(weights_all(1:jall,1)) - IF (ABS(tmp/(4.0*pi))-1.0>0.001) THEN - WRITE(*,*) "sum of all weights does not match the surface area of the sphere" - WRITE(*,*) "sum of all weights is : ",tmp - WRITE(*,*) "surface area of sphere: ",4.0*pi - STOP - END IF -END SUBROUTINE overlap_weights - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromRLL -! -! Description: -! Determine the (alpha,beta,panel) coordinate of a point on the sphere from -! a given regular lat lon coordinate. -! -! Parameters: -! lon - Coordinate longitude -! lat - Coordinate latitude -! alpha (OUT) - Alpha coordinate -! beta (OUT) - Beta coordinate -! ipanel (OUT) - Face panel -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (R8), INTENT(IN) :: lon, lat - REAL (R8), INTENT(OUT) :: alpha, beta - INTEGER :: ipanel - LOGICAL, INTENT(IN) :: ldetermine_panel - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rotate_cube = 0.0 - - ! Local variables - REAL (R8) :: xx, yy, zz, pm - REAL (R8) :: sx, sy, sz - INTEGER :: ix, iy, iz - - ! Translate to (x,y,z) space - xx = COS(lon-rotate_cube) * COS(lat) - yy = SIN(lon-rotate_cube) * COS(lat) - zz = SIN(lat) - - pm = MAX(ABS(xx), ABS(yy), ABS(zz)) - - ! Check maximality of the x coordinate - IF (pm == ABS(xx)) THEN - IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF - ELSE - ix = 0 - ENDIF - - ! Check maximality of the y coordinate - IF (pm == ABS(yy)) THEN - IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF - ELSE - iy = 0 - ENDIF - - ! Check maximality of the z coordinate - IF (pm == ABS(zz)) THEN - IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF - ELSE - iz = 0 - ENDIF - - ! Panel assignments - IF (ldetermine_panel) THEN - IF (iz == 1) THEN - ipanel = 6; sx = yy; sy = -xx; sz = zz - - ELSEIF (iz == -1) THEN - ipanel = 5; sx = yy; sy = xx; sz = -zz - - ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN - ipanel = 1; sx = yy; sy = zz; sz = xx - - ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN - ipanel = 3; sx = -yy; sy = zz; sz = -xx - - ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN - ipanel = 2; sx = -xx; sy = zz; sz = yy - - ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN - ipanel = 4; sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' - WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' - WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' - STOP - ENDIF - ELSE - IF (ipanel == 6) THEN - sx = yy; sy = -xx; sz = zz - ELSEIF (ipanel == 5) THEN - sx = yy; sy = xx; sz = -zz - ELSEIF (ipanel == 1) THEN - sx = yy; sy = zz; sz = xx - ELSEIF (ipanel == 3) THEN - sx = -yy; sy = zz; sz = -xx - ELSEIF (ipanel == 2) THEN - sx = -xx; sy = zz; sz = yy - ELSEIF (ipanel == 4) THEN - sx = xx; sy = zz; sz = -yy - ELSE - WRITE(*,*) "ipanel out of range",ipanel - STOP - END IF - END IF - - ! Use panel information to calculate (alpha, beta) coords - alpha = ATAN(sx / sz) - beta = ATAN(sy / sz) - -END SUBROUTINE CubedSphereABPFromRLL - -!------------------------------------------------------------------------------ -! SUBROUTINE EquiangularAllAreas -! -! Description: -! Compute the area of all cubed sphere grid cells, storing the results in -! a two dimensional array. -! -! Parameters: -! icube - Resolution of the cubed sphere -! dA (OUT) - Output array containing the area of all cubed sphere grid cells -!------------------------------------------------------------------------------ -SUBROUTINE EquiangularAllAreas(icube, dA) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: icube - REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA - - ! Local variables - INTEGER :: k, k1, k2 - REAL (r8) :: a1, a2, a3, a4 - REAL (r8), DIMENSION(icube+1,icube+1) :: ang - REAL (r8), DIMENSION(icube+1) :: gp - - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - - !#ifdef DBG - REAL (r8) :: dbg1 !DBG - !#endif - - ! Recall that we are using equi-angular spherical gridding - ! Compute the angle between equiangular cubed sphere projection grid lines. - DO k = 1, icube+1 - gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) - ENDDO - - DO k2=1,icube+1 - DO k1=1,icube+1 - ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) - ENDDO - ENDDO - - DO k2=1,icube - DO k1=1,icube - a1 = ang(k1 , k2 ) - a2 = pi - ang(k1+1, k2 ) - a3 = pi - ang(k1 , k2+1) - a4 = ang(k1+1, k2+1) - ! area = r*r*(-2*pi+sum(interior angles)) - DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 - ENDDO - ENDDO - - !#ifdef DBG - ! Only for debugging - test consistency - dbg1 = 0.0 !DBG - DO k2=1,icube - DO k1=1,icube - dbg1 = dbg1 + DA(k1,k2) !DBG - ENDDO - ENDDO - write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG - !#endif -END SUBROUTINE EquiangularAllAreas - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereRLLFromABP -! -! Description: -! Determine the lat lon coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! lon (OUT) - Calculated longitude -! lat (OUT) - Calculated latitude -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: lon, lat - ! Local variables - REAL (r8) :: xx, yy, zz, rotate_cube - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - rotate_cube = 0.0 - ! Convert to cartesian coordinates - CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - ! Convert back to lat lon - lat = ASIN(zz) - if (xx==0.0.and.yy==0.0) THEN - lon = 0.0 - else - lon = ATAN2(yy, xx) +rotate_cube - IF (lon<0.0) lon=lon+2.0*pi - IF (lon>2.0*pi) lon=lon-2.0*pi - end if -END SUBROUTINE CubedSphereRLLFromABP - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereXYZFromABP -! -! Description: -! Determine the Cartesian coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! xx (OUT) - Calculated x coordinate -! yy (OUT) - Calculated y coordinate -! zz (OUT) - Calculated z coordinate -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: xx, yy, zz - ! Local variables - REAL (r8) :: a1, b1, pm - REAL (r8) :: sx, sy, sz - - ! Convert to Cartesian coordinates - a1 = TAN(alpha) - b1 = TAN(beta) - - sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - ! Panel assignments - IF (ipanel == 6) THEN - yy = sx; xx = -sy; zz = sz - ELSEIF (ipanel == 5) THEN - yy = sx; xx = sy; zz = -sz - ELSEIF (ipanel == 1) THEN - yy = sx; zz = sy; xx = sz - ELSEIF (ipanel == 3) THEN - yy = -sx; zz = sy; xx = -sz - ELSEIF (ipanel == 2) THEN - xx = -sx; zz = sy; yy = sz - ELSEIF (ipanel == 4) THEN - xx = sx; zz = sy; yy = -sz - ELSE - WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' - WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' - STOP - ENDIF -END SUBROUTINE CubedSphereXYZFromABP - - -SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - integer,dimension(n_in), intent(in) :: f_in - integer, intent(out) :: n_out - integer,dimension(n_in), intent(out) :: f_out - ! - ! local work space - ! - integer :: k,i,j - ! - ! remove duplicates in ipanel_tmp - ! - k = 1 - f_out(1) = f_in(1) - outer: do i=2,n_in - do j=1,k - ! if (f_out(j) == f_in(i)) then - if (ABS(f_out(j)-f_in(i))<1.0E-10) then - ! Found a match so start looking again - cycle outer - end if - end do - ! No match found so add it to the output - k = k + 1 - f_out(k) = f_in(i) - end do outer - n_out = k -END SUBROUTINE remove_duplicates_integer - -SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in - real, intent(in) :: tiny - integer, intent(out) :: n_out - real(r8),dimension(n_in), intent(out) :: lon_out,lat_out - logical :: ldbg - ! - ! local work space - ! - integer :: k,i,j - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: pih = 0.50*pi - ! - ! for pole points: make sure the longitudes are identical so that algorithm below works properly - ! - do i=2,n_in - if (abs(lat_in(i)-pih) ' - print *, ' ' - print *, 'REQUIRED ARGUMENTS: ' - print *, ' --target-grid Target grid descriptor in SCRIP format ' - print *, ' --input-topography Input USGS topography on cube sphere ' - print *, ' --output-topography Output topography on target grid ' - print *, ' ' - print *, 'OPTIONAL ARGUMENTS: ' - print *, ' --smoothed-topography Input smoothed topography (for surface ' - print *, ' roughness calculation). If present, ' - print *, ' output will contain estimate of subgrid' - print *, ' surface roughness (SGH). Note that the ' - print *, ' variance in elevation from the 30s to ' - print *, ' 3km grid (SGH30) is also downscaled, ' - print *, ' but does not depend on the smoothing. ' - print *, ' ' - print *, 'DESCRIPTION: ' - print *, 'This code performs rigorous remapping of topography variables on a cubed- ' - print *, 'sphere grid to any target grid. The code is documented in: ' - print *, ' ' - print *, ' Lauritzen, Nair and Ullrich, 2010, J. Comput. Phys. ' - print *, ' ' - print *, 'AUTHOR: ' - print *, ' Peter Hjort Lauritzen (pel@ucar.edu), AMP/CGD/NESL/NCAR ' - print *, ' ' -end subroutine usage diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl b/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl deleted file mode 100755 index f36183d66e83..000000000000 --- a/components/eam/tools/topo_tool/orographic_drag_toolkit/make.ncl +++ /dev/null @@ -1,10 +0,0 @@ -begin -;; -fil1="USGS-gtopo30_ne30np4pg2_16xdel2_forOroDrag.c20241029.nc" -fil2="USGS-gtopo30_ne30np4pg2_x6t-SGH.c20210614.nc" -fil3="final-180.nc" -system("rm -r "+fil1) -system("cp -r "+fil2+" "+fil1) -system("ncks -A -v OA,OC,OL "+fil3+" "+fil1) -;; -end diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 b/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 deleted file mode 100755 index 0ffb3c0bfec9..000000000000 --- a/components/eam/tools/topo_tool/orographic_drag_toolkit/ogwd_sub.F90 +++ /dev/null @@ -1,900 +0,0 @@ -Module ogwd_sub -use shr_kind_mod, only: r8 => shr_kind_r8 -!use transform - -contains -!#if 0 -subroutine OAdir(terr,ntarget,ncube,n,nvar_dir,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_cen,lat_cen,lon_terr,lat_terr,area_target,oa_target) -!use shr_kind_mod, only: r8 => shr_kind_r8 -IMPLICIT NONE -integer ,intent(in) :: ncube,ntarget,n,nvar_dir,jall,weights_lgr_index_all(jall) -integer ,intent(in) :: weights_eul_index_all1(jall),& - weights_eul_index_all2(jall),& - weights_eul_index_all3(jall) -real(r8),intent(in) :: weights_all(jall,1),landfrac_target(ntarget) -real(r8),intent(in) :: terr(n) -!real(r8),intent(in) :: lon_cen(ntarget),& -real(r8),intent(inout) :: lon_cen(ntarget),& - lat_cen(ntarget),& - area_target(ntarget) -real(r8),intent(in) :: lon_terr(n),lat_terr(n) -real(r8),intent(out) :: oa_target(ntarget,nvar_dir) -!local -integer :: count,i,ix,iy,ip,ii,ip2,ip3 -real(r8) :: xxterr,yyterr,zzterr,ix2,iy2,xx3,yy3,zz3,ix3,iy3 -real(r8) :: wt,xhds(ntarget),yhds(ntarget),zhds(ntarget),hds(ntarget),OAx_var(ntarget),OAy_var(ntarget),OAz_var(ntarget),OA_var(ntarget) -real(r8) :: xbar(ntarget),ybar(ntarget),zbar(ntarget),lon_bar(ntarget),lat_bar(ntarget) -real(r8) :: rad,theta1 -real(r8) :: OAlon(ntarget),OAlat(ntarget),OArad(ntarget),OAx1,OAy1,OAz1 - -real(r8) :: terr_anom(n),terr_avg(ntarget),weights_ano(jall),area_target_ano(ntarget) - -xhds=0.0_r8 -yhds=0.0_r8 -zhds=0.0_r8 -hds=0.0_r8 - -xbar=0.0_r8 -ybar=0.0_r8 -zbar=0.0_r8 -lon_bar=0.0_r8 -lat_bar=0.0_r8 -OA_var=0.0_r8 -OAx_var=0.0_r8 -OAy_var=0.0_r8 -OAz_var=0.0_r8 - - -!#if 0 -terr_anom=0.0_r8 -terr_avg=0.0_r8 -do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count) - ! convert to 1D indexing of cubed-sphere - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - ! - terr_avg(i)=terr_avg(i)+(wt/area_target(i))*terr(ii) - !terr(ii)*wt!(wt/area_target(i))*terr(ii) -enddo - -do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count) - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix - terr_anom(ii)=terr(ii)-terr_avg(i) -! -enddo -where(terr_anom.le.0) terr_anom=0.0_r8 - -do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count)!,3) - ! - ! convert to 1D indexing of cubed-sphere - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - rad=4.0_r8*atan(1.0_r8)/180.0_r8 - call CubedSphereABPFromRLL(lon_terr(ii)*rad,lat_terr(ii)*rad,ix2,iy2,ip2,.true.) - call CubedSphereXYZFromABP(ix2,iy2,ip2,xxterr,yyterr,zzterr) -!#if 0 - xhds(i)=xhds(i)+xxterr*terr_anom(ii)*wt - yhds(i)=yhds(i)+yyterr*terr_anom(ii)*wt - zhds(i)=zhds(i)+zzterr*terr_anom(ii)*wt - hds(i) =hds(i)+terr_anom(ii)*wt - - !masscenter for every coarse grid - !on Cartesian coord - !looking the h as ro - xbar(i)=xhds(i)/hds(i) - ybar(i)=yhds(i)/hds(i) - zbar(i)=zhds(i)/hds(i) - - call CubedSphereABPFromRLL(lon_cen(i)*rad,lat_cen(i)*rad,& - ix3,iy3,ip3,.true.) - call CubedSphereXYZFromABP(ix3,iy3,ip3,xx3,yy3,zz3) - !under Cartesian, the variability of the scale in the wind - !direction is the sqrt(x^2+y^2+z^2), the scale of the orthogonal - !3 directions - !then it is only a matter of using the original formula - !in the single direction - OA_var(i)=OA_var(i)+wt/area_target(i)& - *((xxterr-xx3)**2+(yyterr-yy3)**2+(zzterr-zz3)**2) - OAx_var(i)=OAx_var(i)+(wt/area_target(i))*(xxterr-xx3)**2 - OAy_var(i)=OAy_var(i)+(wt/area_target(i))*(yyterr-yy3)**2 - OAz_var(i)=OAz_var(i)+(wt/area_target(i))*(zzterr-zz3)**2 - OAx1=(xx3-xbar(i))/sqrt(OAx_var(i))!OA_var(i)) - OAy1=(yy3-ybar(i))/sqrt(OAy_var(i))!OA_var(i)) - OAz1=(zz3-zbar(i))/sqrt(OAz_var(i))!OA_var(i)) - !assuming a small change in lon_cen to lon_bar - !so it does not matter whether lon_cen or lon_bar - !thus we change onto lat-lon grid vector in target gridcell -#if 0 - OArad(i)= OAx1*sin(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& - +OAy1*sin(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& - +OAz1*cos(lat_cen(i)*rad) - OAlat(i)= OAx1*cos(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& - +OAy1*cos(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& - -OAz1*sin(lat_cen(i)*rad) - OAlon(i)=-OAx1*sin(lon_cen(i)*rad)& - +OAy1*cos(lon_cen(i)*rad) -#endif - !all lat_cen must use (90-lat_cen) since we only have - !latitude rather than colatitude - !this is equivalent to using induction formula sin(90-lat)=cos(lat) - !latitude is opposite of colatitude, thus OAlat is negative - OAlat(i)=-(OAx1*sin(lat_cen(i)*rad)*cos(lon_cen(i)*rad)& - +OAy1*sin(lat_cen(i)*rad)*sin(lon_cen(i)*rad)& - -OAz1*cos(lat_cen(i)*rad)) - OAlon(i)= -OAx1*sin(lon_cen(i)*rad)& - +OAy1*cos(lon_cen(i)*rad) -#if 0 - theta1=0. - oa_target(i,1) = OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) - theta1=90. - oa_target(i,2) = OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) - theta1=45. - oa_target(i,3)= OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) - theta1=360.-45. - oa_target(i,4)= OAlon(i)*cos(theta1*rad)+OAlat(i)*sin(theta1*rad) -#endif -!#if 0 - !reverse in order to be - !(2,ntarget),OAx,OAy - oa_target(i,1) = OAlon(i) - oa_target(i,2) = OAlat(i) - -!#endif - !landfrac may cause coastal area par to diminish - !oa_target(i,:) = oa_target(i,:)*landfrac_target(i) -enddo - !takeout abnormal values -!#if 0 - where(abs(oa_target)<.001_r8.or.& - abs(oa_target).gt.1e+7) oa_target=0.0_r8 - !where(abs(oa_target).gt.1) oa_target=1.0_r8 - where(oa_target.ne.oa_target) oa_target=0.0_r8 - -!#endif -end subroutine OAdir -!============================================================ -subroutine OAorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_terr,lat_terr,area_target,oa_target) -!use shr_kind_mod, only: r8 => shr_kind_r8 -IMPLICIT NONE -integer ,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) -real(r8),intent(in) :: weights_all(jall,1),terr(n) -real(r8),intent(in) :: landfrac_target(ntarget),lon_terr(n),lat_terr(n),area_target(ntarget) -real(r8),intent(out) :: oa_target(ntarget,4) -!local -real(r8) :: xh(ntarget),yh(ntarget),height(ntarget),modexcoords(ntarget),modeycoords(ntarget),avgx(ntarget),avgy(ntarget),varx(ntarget),vary(ntarget),OAx,OAy,theta1,rad -integer(r8) :: count,i,ix,iy,ip,ii -real(r8) :: wt - - xh=0.0_r8 - yh=0.0_r8 - height=0.0_r8 - modexcoords=0.0_r8 - modeycoords=0.0_r8 - avgx=0.0_r8 - avgy=0.0_r8 - varx=0.0_r8 - vary=0.0_r8 - OAx=0.0_r8 - OAy=0.0_r8 - theta1=0.0_r8 - rad=0.0_r8 - -do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count)!,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - !for OA - avgx(i)=avgx(i)+wt/area_target(i)*lon_terr(ii) - avgy(i)=avgy(i)+wt/area_target(i)*lat_terr(ii) -enddo - - -do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count)!,3) - ! - ! convert to 1D indexing of cubed-sphere - ! - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - !mode for both dim - xh(i)=xh(i)+wt/area_target(i)*lon_terr(ii)*terr(ii) - yh(i)=yh(i)+wt/area_target(i)*lat_terr(ii)*terr(ii) - height(i)=height(i)+wt/area_target(i)*terr(ii) - modexcoords(i)=xh(i)/(height(i))!+1e-14) - modeycoords(i)=yh(i)/(height(i))!+1e-14) - - varx(i)=varx(i)+(wt/area_target(i))*(lon_terr(ii)-avgx(i))**2 - vary(i)=vary(i)+(wt/area_target(i))*(lat_terr(ii)-avgy(i))**2 - !OAx,OAy - OAx=landfrac_target(i)*(avgx(i)-modexcoords(i))/sqrt(varx(i)) - OAy=landfrac_target(i)*(avgy(i)-modeycoords(i))/sqrt(vary(i)) - - rad=4.0*atan(1.0)/180.0 - theta1=0. - oa_target(i,1) = OAx*cos(theta1*rad)+OAy*sin(theta1*rad) - theta1=90. - oa_target(i,2) = OAx*cos(theta1*rad)+OAy*sin(theta1*rad) - theta1=45. - oa_target(i,3)= OAx*cos(theta1*rad)+OAy*sin(theta1*rad) - theta1=360.-45. - oa_target(i,4)= OAx*cos(theta1*rad)+OAy*sin(theta1*rad) - oa_target(i,:)= oa_target(i,:)*landfrac_target(i) -enddo - !takeout abnormal values - where(abs(oa_target)<.001_r8.or.abs(oa_target).gt.1e+7) oa_target=0.0 - where(abs(oa_target).gt.1) oa_target=0.0 - where(oa_target.ne.oa_target) oa_target=0.0 -end subroutine OAorig -!#endif -!=================================== -subroutine OC(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,area_target,sgh_target,terr_target,oc_target) -!use shr_kind_mod, only: r8 => shr_kind_r8 -IMPLICIT NONE -integer ,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) -real(r8),intent(in) :: weights_all(jall,1) -real(r8),intent(in) :: landfrac_target(ntarget),area_target(ntarget),sgh_target(ntarget),terr_target(ntarget),terr(n) -real(r8),intent(out) :: oc_target(ntarget) -!local -integer :: count,i,ix,iy,ip,ii -real(r8) :: wt - - oc_target=0.0_r8 - do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count)!,3) - ! convert to 1D indexing of cubed-sphere - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - oc_target(i) = oc_target(i)+(wt/area_target(i))*((terr_target(i)-terr(ii))**4)/(sgh_target(i)**4) - oc_target(i) = oc_target(i) * landfrac_target(i) - enddo - - where(abs(oc_target)<.001_r8.or.abs(oc_target).gt.1e+7) oc_target=0.0_r8 - where(abs(sgh_target).eq.0.0_r8) oc_target=0.0_r8 - where(oc_target<0.0_r8) oc_target=0.0_r8 -end subroutine OC -!======================== -subroutine OLorig(terr,ntarget,ncube,n,jall,weights_lgr_index_all,weights_eul_index_all1,weights_eul_index_all2,weights_eul_index_all3,weights_all,landfrac_target,lon_terr,lat_terr,area_target,sgh_target,target_center_lat,target_center_lon,target_corner_lat_deg,target_corner_lon_deg,ol_target) -!use shr_kind_mod, only: r8 => shr_kind_r8 -IMPLICIT NONE -integer,intent(in) :: ncube,ntarget,n,jall,weights_lgr_index_all(jall),weights_eul_index_all1(jall),weights_eul_index_all2(jall),weights_eul_index_all3(jall) -real(r8),intent(in) :: weights_all(jall,1) -real(r8),intent(in) :: landfrac_target(ntarget),area_target(ntarget),sgh_target(ntarget),terr(n),lon_terr(n),lat_terr(n) -real(r8),intent(in) :: target_center_lat(ntarget),target_center_lon(ntarget),target_corner_lat_deg(4,ntarget),target_corner_lon_deg(4,ntarget) -real(r8),intent(out) :: ol_target(ntarget,4) -!local -integer :: count,i,ix,iy,ip,ii -real(r8) :: wt,terr_if,Nw(4,ntarget),area_target_par(4,ntarget),j - - - ol_target=0.0_r8 - Nw=0.0_r8 - area_target_par=0.0_r8 - - do count=1,jall - i = weights_lgr_index_all(count) - ix = weights_eul_index_all1(count)!,1) - iy = weights_eul_index_all2(count)!,2) - ip = weights_eul_index_all3(count)!,3) - ! convert to 1D indexing of cubed-sphere - ii = (ip-1)*ncube*ncube+(iy-1)*ncube+ix! - wt = weights_all(count,1) - !determine terr_if - terr_if=0._r8 - if (terr(ii).GT.(1116.2-0.878*sgh_target(i))) terr_if=1. - ! (1): the lower left corner - ! (2): the lower right corner - ! (3): the upper right corner - ! (4): the upper left corner - !OL1 - if (lat_terr(ii) &!(ii)& - .GT.(target_corner_lat_deg(1,i)+target_center_lat(i))/2..and. & - lat_terr(ii) &!(ii)& - .LT.(target_corner_lat_deg(4,i)+target_center_lat(i))/2.) then - Nw(1,i)=Nw(1,i)+wt*terr_if - area_target_par(1,i)=area_target_par(1,i)+wt - endif - - !OL2 - if (lon_terr(ii) &!(ii)& - .GT.(target_corner_lon_deg(1,i)+target_center_lon(i))/2..and. & - lon_terr(ii) &!(ii)& - .LT.(target_corner_lon_deg(3,i)+target_center_lon(i))/2.) then - Nw(2,i)=Nw(2,i)+wt*terr_if - area_target_par(2,i)=area_target_par(2,i)+wt - end if - - - !OL3 - if (lon_terr(ii) &!(ii)& - .LT.target_center_lon(i).and. & - lat_terr(ii) &!(ii)& - .LT.target_center_lat(i).or. & - lon_terr(ii) &!(ii)& - .GT.target_center_lon(i).and. & - lat_terr(ii) &!(ii)& - .GT.target_center_lat(i)) then - Nw(3,i)=Nw(3,i)+wt*terr_if - area_target_par(3,i)=area_target_par(3,i)+wt - end if - - - !OL4 - if (lat_terr(ii) & !(ii)& - .GT.target_center_lat(i).and. & - lon_terr(ii) & !(ii)& - .LT.target_center_lon(i).or. & - lat_terr(ii) & !(ii)& - .LT.target_center_lat(i).and. & - lon_terr(ii) & !(ii)& - .GT.target_center_lon(i)) then - Nw(4,i)=Nw(4,i)+wt*terr_if - area_target_par(4,i)=area_target_par(4,i)+wt - end if - - !Nw(4,i)=Nw(4,i)+wt*terr_if - !area_target_par(4,i)=area_target_par(4,i)+wt - - - - do j=1,4 - ol_target(i,j)=Nw(j,i)/(area_target_par(j,i)+1e-14)!Nt(i)!/2.) - enddo - ol_target(i,:)=ol_target(i,:)*landfrac_target(i) - end do - where(abs(ol_target)<.001_r8.or.abs(ol_target).gt.1e+7) ol_target=0.0_r8 -end subroutine OLorig -!#endif -!===================== -!=================================================================== -!===================== -!#if 0 -subroutine OLgrid(terr,terrx,terry,wt,b,a,n,theta_in,hc,OLout) -!use physconst, only: rh2o,zvir,pi,rearth -!use abortutils -!Xie add -IMPLICIT NONE -integer,intent(in) :: n -real(r8),intent(in) :: hc,wt(n),terr(n),a,b,theta_in!a dy,b dx -real(r8),intent(in) :: terrx(n),terry(n) -real(r8),intent(out) :: OLout -real(r8) :: theta,theta1,theta2,rad,interval -real(r8) :: terr_count(n),terr_whole_count(n),cx(n),c1,c2 -!local -integer :: i -real(r8) :: j - terr_count=0.0_r8 - terr_whole_count=0.0_r8 - c1=0.0_r8 - c2=0.0_r8 - cx=0.0_r8 - !determine an acute theta in the triangle - !or minus 180 equilvalent acute angle - !then turn into radian - rad=4.0_r8*atan(1.0_r8)/180.0_r8 - interval=0.0_r8 - - !initialize - theta1=0.0_r8 - theta2=0.0_r8 - !set inside -360~360 - !this adds robustness of the scheme to different angle - theta1=MOD(theta_in,360._r8) - !set negative axis into 0~360 - if (theta1.ge.-360._r8.and.theta1.lt.0._r8) then - theta1=theta1+360._r8 - endif - !now we have only 0~360 angle - if (theta1.ge. 0._r8.and.theta1.le. 90._r8) then - theta=theta1*rad - theta2=theta1 - else if (theta1.gt. 90._r8.and.theta1.le. 180._r8) then - theta=(180._r8-theta1)*rad - theta2=180._r8-theta1 - else if (theta1.gt. 180._r8.and.theta1.le. 270._r8) then - theta=(theta1-180._r8)*rad - theta2=theta1-180._r8 - !we only use 0~180, so this makes similar to 1st and 2nd quadrant - else if (theta1.gt. 270._r8.and.theta1.le. 360._r8) then - theta=(360._r8-theta1)*rad - theta2=360._r8-theta1 - !we only use 0~180, so this makes similar to 1st and 2nd quadrant - endif - !we use theta2 to judge instead - !theta2=theta1 - !theta1=theta2 - !we restrict the angle in the first and second quadrant - !the third and fourth for OL are similar when theta is - !transformed by minus pi(180) - !two parallel lines are included - !xsin(theta)-ycos(theta)=c1 - !xsin(theta)-ycos(theta)=c2 - !xsin(theta)-ycos(theta)=cx,min(c1,c2) 0) .AND. (j < ncube_reconstruct)) THEN - beta = gp(j) - beta_next = gp(j+1) - ELSEIF (j == -1) THEN - beta = -piq - (gp(3) + piq) - beta_next = -piq - (gp(2) + piq) - ELSEIF (j == 0) THEN - beta = -piq - (gp(2) + piq) - beta_next = -piq - ELSEIF (j == ncube_reconstruct) THEN - beta = piq - beta_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (j == ncube_reconstruct+1) THEN - beta = piq + (piq - gp(ncube_reconstruct-1)) - beta_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - - DO i = -1, ncube_reconstruct+1 - IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN - alpha = gp(i) - alpha_next = gp(i+1) - ELSEIF (i == -1) THEN - alpha = -piq - (gp(3) + piq) - alpha_next = -piq - (gp(2) + piq) - ELSEIF (i == 0) THEN - alpha = -piq - (gp(2) + piq) - alpha_next = -piq - ELSEIF (i == ncube_reconstruct) THEN - alpha = piq - alpha_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (i == ncube_reconstruct+1) THEN - alpha = piq + (piq - gp(ncube_reconstruct-1)) - alpha_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - abp_centroid(1,i,j) = & - I_10_ab(alpha_next,beta_next)-I_10_ab(alpha ,beta_next)+& - I_10_ab(alpha ,beta )-I_10_ab(alpha_next,beta ) -! - ASINH(COS(alpha_next) * TAN(beta_next)) & -! + ASINH(COS(alpha_next) * TAN(beta)) & -! + ASINH(COS(alpha) * TAN(beta_next)) & -! - ASINH(COS(alpha) * TAN(beta)) - - abp_centroid(2,i,j) = & - I_01_ab(alpha_next,beta_next)-I_01_ab(alpha ,beta_next)+& - I_01_ab(alpha ,beta )-I_01_ab(alpha_next,beta ) -! - ASINH(TAN(alpha_next) * COS(beta_next)) & -! + ASINH(TAN(alpha_next) * COS(beta)) & -! + ASINH(TAN(alpha) * COS(beta_next)) & -! - ASINH(TAN(alpha) * COS(beta)) - - !ADD PHL START - IF (order>2) THEN - ! TAN(alpha)^2 component - abp_centroid(3,i,j) =& - I_20_ab(alpha_next,beta_next)-I_20_ab(alpha ,beta_next)+& - I_20_ab(alpha ,beta )-I_20_ab(alpha_next,beta ) - - ! TAN(beta)^2 component - abp_centroid(4,i,j) = & - I_02_ab(alpha_next,beta_next)-I_02_ab(alpha ,beta_next)+& - I_02_ab(alpha ,beta )-I_02_ab(alpha_next,beta ) - - ! TAN(alpha) TAN(beta) component - abp_centroid(5,i,j) = & - I_11_ab(alpha_next,beta_next)-I_11_ab(alpha ,beta_next)+& - I_11_ab(alpha ,beta )-I_11_ab(alpha_next,beta ) - ENDIF - !ADD PHL END - ENDDO - ENDDO - -! -! PHL outcommented below -! - ! High order calculations -! IF (order > 2) THEN -! DO k = 1, nlon -! DO i = 1, int_nx(nlat,k)-1 -! IF ((int_itype(i,k) > 4) .AND. (int_np(1,i,k) == 1)) THEN -! abp_centroid(3, int_a(i,k), int_b(i,k)) = & -! abp_centroid(3, int_a(i,k), int_b(i,k)) + int_wt_2a(i,k) -! abp_centroid(4, int_a(i,k), int_b(i,k)) = & -! abp_centroid(4, int_a(i,k), int_b(i,k)) + int_wt_2b(i,k) -! abp_centroid(5, int_a(i,k), int_b(i,k)) = & -! abp_centroid(5, int_a(i,k), int_b(i,k)) + int_wt_2c(i,k) -! ENDIF -! ENDDO -! ENDDO -! ENDIF - - ! Normalize with element areas - DO j = -1, ncube_reconstruct+1 - IF ((j > 0) .AND. (j < ncube_reconstruct)) THEN - beta = gp(j) - beta_next = gp(j+1) - ELSEIF (j == -1) THEN - beta = -piq - (gp(3) + piq) - beta_next = -piq - (gp(2) + piq) - ELSEIF (j == 0) THEN - beta = -piq - (gp(2) + piq) - beta_next = -piq - ELSEIF (j == ncube_reconstruct) THEN - beta = piq - beta_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (j == ncube_reconstruct+1) THEN - beta = piq + (piq - gp(ncube_reconstruct-1)) - beta_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - DO i = -1, ncube_reconstruct+1 - IF ((i > 0) .AND. (i < ncube_reconstruct)) THEN - alpha = gp(i) - alpha_next = gp(i+1) - ELSEIF (i == -1) THEN - alpha = -piq - (gp(3) + piq) - alpha_next = -piq - (gp(2) + piq) - ELSEIF (i == 0) THEN - alpha = -piq - (gp(2) + piq) - alpha_next = -piq - ELSEIF (i == ncube_reconstruct) THEN - alpha = piq - alpha_next = piq + (piq - gp(ncube_reconstruct-1)) - ELSEIF (i == ncube_reconstruct+1) THEN - alpha = piq + (piq - gp(ncube_reconstruct-1)) - alpha_next = piq + (piq - gp(ncube_reconstruct-2)) - ENDIF - - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - area = DAcube(i,j) - ELSE - area = EquiangularElementArea(alpha, alpha_next - alpha, & - beta, beta_next - beta) - ENDIF - - abp_centroid(1,i,j) = abp_centroid(1,i,j) / area - abp_centroid(2,i,j) = abp_centroid(2,i,j) / area - - IF (order > 2) THEN - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - abp_centroid(3,i,j) = abp_centroid(3,i,j) / area - abp_centroid(4,i,j) = abp_centroid(4,i,j) / area - abp_centroid(5,i,j) = abp_centroid(5,i,j) / area - ENDIF - ENDIF - ENDDO - ENDDO - - WRITE(*,*) '...Done computing ABP element centroids' - - END SUBROUTINE ComputeABPElementCentroids - -!------------------------------------------------------------------------------ -! FUNCTION EvaluateABPReconstruction -! -! Description: -! Evaluate the sub-grid scale reconstruction at the given point. -! -! Parameters: -! fcubehalo - Array of element values -! recons - Array of reconstruction coefficients -! a - Index of element in alpha direction (1 <= a <= ncube_reconstruct-1) -! b - Index of element in beta direction (1 <= b <= ncube_reconstruct-1) -! p - Panel index of element -! alpha - Alpha coordinate of evaluation point -! beta - Beta coordinate of evaluation point -! order - Order of the reconstruction -! value (OUT) - Result of function evaluation at given point -!------------------------------------------------------------------------------ - SUBROUTINE EvaluateABPReconstruction( & - fcubehalo, recons, a, b, p, alpha, beta, order, value) - IMPLICIT NONE - - ! Dummy variables - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(IN) :: recons - INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p - REAL (KIND=dbl_kind), INTENT(IN) :: alpha, beta - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), INTENT(OUT) :: value - - ! Evaluate constant order terms - value = fcubehalo(a,b,p) - - ! Evaluate linear order terms - IF (order > 1) THEN - value = value + recons(1,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) - value = value + recons(2,a,b,p) * (TAN(beta) - abp_centroid(2,a,b)) - ENDIF - - ! Evaluate second order terms - IF (order > 2) THEN - value = value + recons(3,a,b,p) * & - (abp_centroid(1,a,b)**2 - abp_centroid(3,a,b)) - value = value + recons(4,a,b,p) * & - (abp_centroid(2,a,b)**2 - abp_centroid(4,a,b)) - value = value + recons(5,a,b,p) * & - (abp_centroid(1,a,b) * abp_centroid(2,a,b) - & - abp_centroid(5,a,b)) - - value = value + recons(3,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b))**2 - value = value + recons(4,a,b,p) * (TAN(beta) - abp_centroid(2,a,b))**2 - value = value + recons(5,a,b,p) * (TAN(alpha) - abp_centroid(1,a,b)) & - * (TAN(beta) - abp_centroid(2,a,b)) - ENDIF - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ABPHaloMinMax -! -! Description: -! Calculate the minimum and maximum values of the cell-averaged function -! around the given element. -! -! Parameters: -! fcubehalo - Cell-averages for the cubed sphere -! a - Local element alpha index -! b - Local element beta index -! p - Local element panel index -! min_val (OUT) - Minimum value in the halo -! max_val (OUT) - Maximum value in the halo -! nomiddle - whether to not include the middle cell (index a,b) in the search. -! -! NOTE: Since this routine is not vectorized, it will likely be called MANY times. -! To speed things up, make sure to pass the first argument as the ENTIRE original -! array, not as a subset of it, since repeatedly cutting up that array and creating -! an array temporary (on some compilers) is VERY slow. -! ex: -! CALL APBHaloMinMax(zarg, a, ...) !YES -! CALL ABPHaloMinMax(zarg(-1:ncube_reconstruct+1,-1:ncube_reconstruct+1,:)) !NO -- slow -!------------------------------------------------------------------------------ - SUBROUTINE ABPHaloMinMax(fcubehalo, a, b, p, min_val, max_val, nomiddle) - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: a, b, p - REAL (KIND=dbl_kind), INTENT(OUT) :: min_val, max_val - LOGICAL, INTENT(IN) :: nomiddle - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, il, jl, inew, jnew - REAL (KIND=dbl_kind) :: value - - min_val = fcubehalo(a,b,p) - max_val = fcubehalo(a,b,p) - value = fcubehalo(a,b,p) - - DO il = a-1,a+1 - DO jl = b-1,b+1 - - i = il - j = jl - - inew = i - jnew = j - - IF (nomiddle .AND. i==a .AND. j==b) CYCLE - - !Interior - IF ((i > 0) .AND. (i < ncube_reconstruct) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - value = fcubehalo(i,j,p) - - ELSE - - - !The next 4.0 regions are cases in which a,b themselves lie in the panel's halo, and the cell's "halo" (in this usage the 8.0 cells surrounding it) might wrap around into another part of the halo. This happens for (a,b) = {(1,:0),(ncube_reconstruct-1,:0),(1,ncube_reconstruct:),(ncube_reconstruct-1,ncube_reconstruct:)} and for the transposes thereof ({(:0,1), etc.}). In these cases (i,j) could lie in the "Corners" where nothing should lie. We correct this by moving i,j to its appropriate position on the "facing" halo, and then the remainder of the routine then moves it onto the correct face. - -101 FORMAT("ERROR cannot find (i,j) = (", I4, ", ", I4, ") for (a,b,p) = ", I4, ",", I4, ",", I4, ")") -102 FORMAT("i,j,p = ", 3I4, " moved to " 2I4, " (CASE ", I1, ")") - !NOTE: we need the general case to be able to properly handle (0,0), (ncube_reconstruct,0), etc. Note that we don't need to bother with (0,0), etc. when a, b lie in the interior, since both sides of the (0,0) cell are already accounted for by this routine. - !LOWER LEFT - IF (i < 1 .AND. j < 1) THEN - IF (a < 1) THEN !(a,b) centered on left halo, cross to lower halo - inew = 1-j - jnew = i - ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to left halo - jnew = 1-i - inew = j - END IF -! WRITE(*,102) i, j, p, inew, jnew, 1 - !LOWER RIGHT - ELSE IF (i > ncube_reconstruct-1 .AND. j < 1) THEN - IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to lower halo - inew = ncube_reconstruct-1+j - jnew = ncube_reconstruct-i - ELSE IF (b < 1) THEN !(a,b) centered on lower halo, cross to right halo - jnew = 1+(i-ncube_reconstruct) - inew = ncube_reconstruct-j - END IF -! WRITE(*,102) i, j, p, inew, jnew, 2 - !UPPER LEFT - ELSE IF (i < 1 .AND. j > ncube_reconstruct-1) THEN - IF (a < 1) THEN! (a,b) centered on left halo, cross to upper halo - inew = 1-(j-ncube_reconstruct) - jnew = ncube_reconstruct-i - ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to left halo - inew = ncube_reconstruct-j - jnew = ncube_reconstruct-1-i - END IF -! WRITE(*,102) i, j, p, inew, jnew, 3 - !UPPER RIGHT - ELSE IF (i > ncube_reconstruct-1 .AND. j > ncube_reconstruct-1) THEN - IF (a > ncube_reconstruct-1) THEN !(a,b) centered on right halo, cross to upper halo - inew = ncube_reconstruct-1-(ncube_reconstruct-j) - jnew = i - ELSE IF (b > ncube_reconstruct-1) THEN !(a,b) centered on upper halo, cross to right halo - inew = j - jnew = ncube_reconstruct-1-(ncube_reconstruct-i) - END IF -! WRITE(*,102) i, j, p, inew, jnew, 4 - END IF - - i = inew - j = jnew - - - !Lower halo ("halo" meaning the panel's halo, not the nine-cell halo - IF ((i < 1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,4) - ELSEIF (p == 2) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,1) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,2) - ELSEIF (p == 4) THEN - value = fcubehalo(ncube_reconstruct-1+i,j,3) - ELSEIF (p == 5) THEN - value = fcubehalo(j,1-i,4) - ELSEIF (p == 6) THEN - value = fcubehalo(ncube_reconstruct-j,ncube_reconstruct-1+i,4) - ENDIF - - !Upper halo - ELSEIF ((i > ncube_reconstruct-1) .AND. (j > 0) .AND. (j < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,2) - ELSEIF (p == 2) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,3) - ELSEIF (p == 3) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,4) - ELSEIF (p == 4) THEN - value = fcubehalo(i-ncube_reconstruct+1,j,1) - ELSEIF (p == 5) THEN - value = fcubehalo(ncube_reconstruct-j,i-ncube_reconstruct+1,2) - ELSEIF (p == 6) THEN - value = fcubehalo(j,2*ncube_reconstruct-i-1,2) - ENDIF - - !Left halo - ELSEIF ((j < 1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i,ncube_reconstruct-1+j,5) - ELSEIF (p == 2) THEN - value = fcubehalo(ncube_reconstruct-1+j,ncube_reconstruct-i,5) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-i,1-j,5) - ELSEIF (p == 4) THEN - value = fcubehalo(1-j,i,5) - ELSEIF (p == 5) THEN - value = fcubehalo(ncube_reconstruct-i,1-j,3) - ELSEIF (p == 6) THEN - value = fcubehalo(i,ncube_reconstruct-1+j,1) - ENDIF - - !Right halo - ELSEIF ((j > ncube_reconstruct-1) .AND. (i > 0) .AND. (i < ncube_reconstruct)) THEN - IF (p == 1) THEN - value = fcubehalo(i,j-ncube_reconstruct+1,6) - ELSEIF (p == 2) THEN - value = fcubehalo(2*ncube_reconstruct-j-1,i,6) - ELSEIF (p == 3) THEN - value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,6) - ELSEIF (p == 4) THEN - value = fcubehalo(j-ncube_reconstruct+1,ncube_reconstruct-i,6) - ELSEIF (p == 5) THEN - value = fcubehalo(i,j-ncube_reconstruct+1,1) - ELSEIF (p == 6) THEN - value = fcubehalo(ncube_reconstruct-i, 2*ncube_reconstruct-j-1,3) - ENDIF - - ENDIF - - END IF - min_val = MIN(min_val, value) - max_val = MAX(max_val, value) - ENDDO - ENDDO - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE MonotonizeABPGradient -! -! Description: -! Apply a monotonic filter to the calculated ABP gradient. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! selective - whether to apply a simple form of selective limiting, - !which assumes that if a point is larger/smaller than ALL of its - !surrounding points, that the extremum is physical, and that - !filtering should not be applied to it. -! -! Remarks: -! This monotonizing scheme is based on the monotone scheme for unstructured -! grids of Barth and Jespersen (1989). -!------------------------------------------------------------------------------ - SUBROUTINE MonotonizeABPGradient(fcubehalo, order, recons, selective) - -! USE selective_limiting - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - LOGICAL, INTENT(IN) :: selective - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n, skip - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi - REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & - gamma - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - -! -! xxxxx -! -! IF (selective) THEN -! CALL smoothness2D(fcubehalo, gamma, 2) -! WRITE(*,*) 'gamma range: max ', MAXVAL(gamma), " min ", MINVAL(gamma) -! DO i=1,ncube_reconstruct-1 -! WRITE(*,*) gamma(i, i, 3) -! ENDDO -! skip = 0 -! END IF - - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - - - IF (selective) THEN - - CALL ABPHaloMinMax(gamma, i, j, k, gamma_min, gamma_max, .FALSE.) - - IF (gamma_max/(gamma_min + tiny) < lammax) THEN - skip = skip + 1 - CYCLE - END IF - - END IF - - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - ENDIF - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - IF (order > 2) THEN - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - ENDDO - ENDDO - ENDDO - - IF (selective) WRITE(*,*) 'skipped ', skip, ' points out of ', 6*(ncube_reconstruct-1)**2 - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE PosDefABPGradient -! -! Description: -! Scale the reconstructions so they are positive definite -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! This monotonizing scheme is based on the monotone scheme for unstructured -! grids of Barth and Jespersen (1989), but simpler. This simply finds the -! minimum and then scales the reconstruction so that it is 0. -!------------------------------------------------------------------------------ - SUBROUTINE PosDefABPGradient(fcubehalo, order, recons) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi - REAL (KIND=dbl_kind) :: disc, mx, my, lam, gamma_min, gamma_max - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: & - gamma - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - - !If the average value in the cell is 0.0, then we should skip - !all of the scaling and just set the reconstruction to 0.0 -! IF (ABS(fcubehalo(i,j,k)) < tiny) THEN -! recons(:,i,j,k) = 0.0 -! CYCLE -! END IF - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - - !This allowance for miniscule negative values appearing around the cell being - !filtered/limited. Before this, negative values would be caught in adjust_limiter - !and would stop the model. Doing this only causes minor negative values; no blowing - !up is observed. The rationale is the same as for the monotone filter, which does - !allow miniscule negative values due to roundoff error --- of the order E-10 --- - !in flux-form methods (and E-17 in the s-L method, indicating that roundoff error - !is more severe in the flux-form method, as we expect since we are often subtracting - !2.0 values which are very close together. - local_min = MIN(0.0,local_min) - local_max = bignum !prevents scaling upward; for positive - !definite limiting we don't care about the upper bound - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), & - local_min, local_max, min_phi) - ENDDO - ENDIF - ENDIF - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - IF (order > 2) THEN - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - - ENDDO - ENDDO - ENDDO - - - END SUBROUTINE PosDefABPGradient - -!------------------------------------------------------------------------------ -! SUBROUTINE MonotonizeABPGradient_New -! -! Description: -! Apply a monotonic filter to the calculated ABP gradient. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! This monotonizing scheme is similar to the one in MonotonizeABPGradient, -! except the second order derivatives are limited after the first order -! derivatives. -!------------------------------------------------------------------------------ - SUBROUTINE MonotonizeABPGradient_New(fcubehalo, order, recons) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, linval - REAL (KIND=dbl_kind) :: disc, mx, my - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max, .FALSE.) - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point, only taking into - ! account the linear component of the reconstruction. - value = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - CALL AdjustLimiter( & - value, fcubehalo(i,j,k), local_min, local_max, min_phi) - ENDDO - ENDDO - - ! Apply monotone limiter to all reconstruction coefficients - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - ! For the third order method, the minima and maxima may occur along - ! the line segments given by du/dx = 0 and du/dy = 0. Also check - ! for the presence of a maxima / minima of the quadratic within - ! the domain. - IF (order == 3) THEN - ! Reset the limiter - min_phi = one - - ! Calculate discriminant, which we use to determine the absolute - ! minima/maxima of the paraboloid - disc = recons(5,i,j,k)**2 - 4.0 * recons(4,i,j,k) * recons(3,i,j,k) - - ! Check if the quadratic is minimized within the element - IF (ABS(disc) > tiny) THEN - mx = - recons(5,i,j,k) * recons(2,i,j,k) & - + 2.0 * recons(4,i,j,k) * recons(1,i,j,k) - my = - recons(5,i,j,k) * recons(1,i,j,k) & - + 2.0 * recons(3,i,j,k) * recons(2,i,j,k) - - mx = mx / disc + abp_centroid(1,i,j) - my = my / disc + abp_centroid(2,i,j) - - IF ((mx - TAN(gp(i)) > -tiny) .AND. & - (mx - TAN(gp(i+1)) < tiny) .AND. & - (my - TAN(gp(j)) > -tiny) .AND. & - (my - TAN(gp(j+1)) < tiny) & - ) THEN - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDIF - ENDIF - - ! Check all potential minimizer points along element boundaries - IF (ABS(recons(5,i,j,k)) > tiny) THEN - - ! Left/right edge, intercept with du/dx = 0 - DO m = i, i+1 - my = - recons(1,i,j,k) - 2.0 * recons(3,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / recons(5,i,j,k) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - - ! Top/bottom edge, intercept with du/dy = 0 - DO n = j, j+1 - mx = - recons(2,i,j,k) - 2.0 * recons(4,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / recons(5,i,j,k) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Top/bottom edge, intercept with du/dx = 0 - IF (ABS(recons(3,i,j,k)) > tiny) THEN - DO n = j, j+1 - mx = - recons(1,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(n)) - abp_centroid(2,i,j)) - - mx = mx / (2.0 * recons(3,i,j,k)) + abp_centroid(1,i,j) - - IF ((mx < TAN(gp(i))) .OR. (mx > TAN(gp(i+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, ATAN(mx), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (mx - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! Left/right edge, intercept with du/dy = 0 - IF (ABS(recons(4,i,j,k)) > tiny) THEN - DO m = i, i+1 - my = - recons(2,i,j,k) - recons(5,i,j,k) * & - (TAN(gp(m)) - abp_centroid(1,i,j)) - - my = my / (2.0 * recons(4,i,j,k)) + abp_centroid(2,i,j) - - IF ((my < TAN(gp(j))) .OR. (my > TAN(gp(j+1)))) THEN - CYCLE - ENDIF - - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), ATAN(my), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (my - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDIF - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), & - order, value) - - linval = & - fcubehalo(i,j,k) & - + recons(1,i,j,k) * (TAN(gp(m)) - abp_centroid(1,i,j)) & - + recons(2,i,j,k) * (TAN(gp(n)) - abp_centroid(2,i,j)) - - IF (linval < local_min) THEN - linval = local_min - ENDIF - IF (linval > local_max) THEN - linval = local_max - ENDIF - - CALL AdjustLimiter( & - value, linval, local_min, local_max, min_phi) - ENDDO - ENDDO - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - WRITE (*,*) '2: ', min_phi - - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - recons(3,i,j,k) = min_phi * recons(3,i,j,k) - recons(4,i,j,k) = min_phi * recons(4,i,j,k) - recons(5,i,j,k) = min_phi * recons(5,i,j,k) - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_NEL -! -! Description: -! Construct a non-equidistant linear reconstruction of the gradient -! within each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_NEL(fcubehalo, recons, order) - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: alpha1, alpha2, beta1, beta2 - REAL (KIND=dbl_kind) :: dx_left, dx_right, top_value, bot_value - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - - recons(1,i,j,p) = & - (+ fcubehalo(i-1,j,p) * dx_right**2 & - - fcubehalo(i+1,j,p) * dx_left**2 & - - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(2,i,j,p) = & - (+ fcubehalo(i,j-1,p) * dx_right**2 & - - fcubehalo(i,j+1,p) * dx_left**2 & - - fcubehalo(i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - IF (order > 2) THEN - dx_left = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - dx_right = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - - recons(3,i,j,p) = & - (+ fcubehalo(i-1,j,p) * dx_right & - - fcubehalo(i+1,j,p) * dx_left & - - fcubehalo(i,j,p) * (dx_right - dx_left)) / & - (dx_right * dx_left * (dx_left - dx_right)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(4,i,j,p) = & - (+ fcubehalo(i,j-1,p) * dx_right & - - fcubehalo(i,j+1,p) * dx_left & - - fcubehalo(i,j,p) * (dx_right - dx_left)) / & - (dx_right * dx_left * (dx_left - dx_right)) - ENDIF - ENDDO - ENDDO - - IF (order > 2) THEN - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - dx_left = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) - dx_right = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) - - top_value = & - (+ fcubehalo(i-1,j+1,p) * dx_right**2 & - - fcubehalo(i+1,j+1,p) * dx_left**2 & - - fcubehalo(i,j+1,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) - dx_right = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) - - bot_value = & - (+ fcubehalo(i-1,j-1,p) * dx_right**2 & - - fcubehalo(i+1,j-1,p) * dx_left**2 & - - fcubehalo(i,j-1,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - dx_left = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - dx_right = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(5,i,j,p) = & - (+ bot_value * dx_right**2 & - - top_value * dx_left**2 & - - recons(1,i,j,p) * (dx_right**2 - dx_left**2)) / & - (dx_right * dx_left * (dx_right - dx_left)) - - ENDDO - ENDDO - ENDIF - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_NEP -! -! Description: -! Construct a non-equidistant parabolic reconstruction of the gradient -! within each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_NEP(fcubehalo, recons, order) - - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: x1, x2, x4, x5, y1, y2, y3, y4, y5 - - REAL (KIND=dbl_kind), DIMENSION(5) :: t, pa, denom - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! X-direction reconstruction - x1 = abp_centroid(1,i-2,j) - abp_centroid(1,i,j) - x2 = abp_centroid(1,i-1,j) - abp_centroid(1,i,j) - x4 = abp_centroid(1,i+1,j) - abp_centroid(1,i,j) - x5 = abp_centroid(1,i+2,j) - abp_centroid(1,i,j) - - !IF (i == 1) THEN - ! x1 = piq - !ELSEIF (i == ncube_reconstruct-1) THEN - ! x5 = -piq - !ENDIF - - y1 = fcubehalo(i-2,j,p) - y2 = fcubehalo(i-1,j,p) - y3 = fcubehalo(i,j,p) - y4 = fcubehalo(i+1,j,p) - y5 = fcubehalo(i+2,j,p) - - denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 - denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 - denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 - denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 - - t(1) = x5 * x4 * x2 - t(2) = x5 * x4 * x1 - t(4) = x5 * x2 * x1 - t(5) = x4 * x2 * x1 - t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) - - pa(1) = x2 * x4 + x2 * x5 + x4 * x5 - pa(2) = x1 * x4 + x1 * x5 + x4 * x5 - pa(4) = x1 * x2 + x1 * x5 + x2 * x5 - pa(5) = x1 * x2 + x1 * x4 + x2 * x4 - pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) - - recons(1,i,j,p) = & - + y1 * t(1) / denom(1) & - + y2 * t(2) / denom(2) & - - y3 * t(3) & - + y4 * t(4) / denom(4) & - + y5 * t(5) / denom(5) - - IF (order > 2) THEN - recons(3,i,j,p) = & - - y1 * pa(1) / denom(1) & - - y2 * pa(2) / denom(2) & - + y3 * pa(3) & - - y4 * pa(4) / denom(4) & - - y5 * pa(5) / denom(5) - ENDIF - - ! Y-direction reconstruction - x1 = abp_centroid(2,i,j-2) - abp_centroid(2,i,j) - x2 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - x4 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - x5 = abp_centroid(2,i,j+2) - abp_centroid(2,i,j) - - !IF (j == 1) THEN - ! x1 = piq - !ELSEIF (j == ncube_reconstruct-1) THEN - ! x5 = -piq - !ENDIF - - y1 = fcubehalo(i,j-2,p) - y2 = fcubehalo(i,j-1,p) - y3 = fcubehalo(i,j,p) - y4 = fcubehalo(i,j+1,p) - y5 = fcubehalo(i,j+2,p) - - denom(1) = (x2 - x1) * (x4 - x1) * (x5 - x1) * x1 - denom(2) = (x1 - x2) * (x4 - x2) * (x5 - x2) * x2 - denom(4) = (x1 - x4) * (x2 - x4) * (x5 - x4) * x4 - denom(5) = (x1 - x5) * (x2 - x5) * (x4 - x5) * x5 - - t(1) = x5 * x4 * x2 - t(2) = x5 * x4 * x1 - t(4) = x5 * x2 * x1 - t(5) = x4 * x2 * x1 - t(3) = (t(1) + t(2) + t(4) + t(5)) / (x1 * x2 * x4 * x5) - - pa(1) = x2 * x4 + x2 * x5 + x4 * x5 - pa(2) = x1 * x4 + x1 * x5 + x4 * x5 - pa(4) = x1 * x2 + x1 * x5 + x2 * x5 - pa(5) = x1 * x2 + x1 * x4 + x2 * x4 - pa(3) = (pa(1) + pa(2) + pa(4) + pa(5)) / (2.0 * x1 * x2 * x4 * x5) - - recons(2,i,j,p) = & - + y1 * t(1) / denom(1) & - + y2 * t(2) / denom(2) & - - y3 * t(3) & - + y4 * t(4) / denom(4) & - + y5 * t(5) / denom(5) - - IF (order > 2) THEN - recons(4,i,j,p) = & - - y1 * pa(1) / denom(1) & - - y2 * pa(2) / denom(2) & - + y3 * pa(3) & - - y4 * pa(4) / denom(4) & - - y5 * pa(5) / denom(5) - recons(5,i,j,p) = 0.0 - ENDIF - - ENDDO - ENDDO - IF (order > 2) THEN - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - x1 = abp_centroid(1,i-1,j+1) - abp_centroid(1,i,j+1) - x2 = abp_centroid(1,i+1,j+1) - abp_centroid(1,i,j+1) - - y2 = (+ fcubehalo(i-1,j+1,p) * x2**2 & - - fcubehalo(i+1,j+1,p) * x1**2 & - - fcubehalo(i,j+1,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - x1 = abp_centroid(1,i-1,j-1) - abp_centroid(1,i,j-1) - x2 = abp_centroid(1,i+1,j-1) - abp_centroid(1,i,j-1) - - y1 = (+ fcubehalo(i-1,j-1,p) * x2**2 & - - fcubehalo(i+1,j-1,p) * x1**2 & - - fcubehalo(i,j-1,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - x1 = abp_centroid(2,i,j-1) - abp_centroid(2,i,j) - x2 = abp_centroid(2,i,j+1) - abp_centroid(2,i,j) - - recons(5,i,j,p) = & - (+ y1 * x2**2 & - - y2 * x1**2 & - - recons(1,i,j,p) * (x2**2 - x1**2)) / & - (x2 * x1 * (x2 - x1)) - - ENDDO - ENDDO - ENDIF - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_PLM -! -! Description: -! Construct a piecewise linear reconstruction of the gradient within -! each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_PLM(fcubehalo, recons, order) - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: width - - ! ABP width between elements - width = pih / DBLE(ncube_reconstruct-1) - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! df/dx - recons(1,i,j,p) = (fcubehalo(i+1,j,p) - fcubehalo(i-1,j,p)) / & - (2.0 * width) - - ! df/dy - recons(2,i,j,p) = (fcubehalo(i,j+1,p) - fcubehalo(i,j-1,p)) / & - (2.0 * width) - - ! Stretching - recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) - recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) - - ! Third order scheme - IF (order > 2) THEN - ! d^2f/dx^2 - recons(3,i,j,p) = & - (fcubehalo(i+1,j,p) - 2.0 * fcubehalo(i,j,p) & - + fcubehalo(i-1,j,p)) / (width * width) - - ! d^2f/dy^2 - recons(4,i,j,p) = & - (fcubehalo(i,j+1,p) - 2.0 * fcubehalo(i,j,p) & - + fcubehalo(i,j-1,p)) / (width * width) - - ! d^2f/dxdy - recons(5,i,j,p) = & - (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & - - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & - ) / (4.0 * width * width) - - ! Stretching - recons(3,i,j,p) = & - (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & - + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 - - recons(4,i,j,p) = & - (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & - + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 - - recons(5,i,j,p) = recons(5,i,j,p) / & - ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) - - ! Scaling - recons(3,i,j,p) = 0.5 * recons(3,i,j,p) - recons(4,i,j,p) = 0.5 * recons(4,i,j,p) - - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient_PPM -! -! Description: -! Construct a piecewise parabolic reconstruction of the gradient within -! each element on an ABP grid. -! -! Parameters: -! fcubehalo - Scalar field on the ABP grid to use in reconstruction -! recons (OUT) - Array of reconstructed coefficients for total elements -! order - Order of the scheme (2 or 3) -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient_PPM(fcubehalo, recons, order) - - -! USE CubedSphereTrans -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), INTENT(IN) :: fcubehalo - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(OUT) :: recons - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind) :: width - - ! ABP width between elements - width = pih / DBLE(ncube_reconstruct-1) - - DO p = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - ! df/dalfa - recons(1,i,j,p) = & - (+ fcubehalo(i+2,j,p) - 8.0 * fcubehalo(i+1,j,p) & - + 8.0 * fcubehalo(i-1,j,p) - fcubehalo(i-2,j,p)) / & - (- 12.0 * width) - - ! df/dbeta - recons(2,i,j,p) = & - (+ fcubehalo(i,j+2,p) - 8.0 * fcubehalo(i,j+1,p) & - + 8.0 * fcubehalo(i,j-1,p) - fcubehalo(i,j-2,p)) / & - (- 12.0 * width) - - ! Stretching - recons(1,i,j,p) = recons(1,i,j,p) / (one + abp_centroid(1,i,j)**2) - recons(2,i,j,p) = recons(2,i,j,p) / (one + abp_centroid(2,i,j)**2) - - ! Third order scheme - IF (order > 2) THEN - ! d^2f/dx^2 - recons(3,i,j,p) = (- fcubehalo(i+2,j,p) & - + 16_dbl_kind * fcubehalo(i+1,j,p) & - - 30_dbl_kind * fcubehalo(i,j,p) & - + 16_dbl_kind * fcubehalo(i-1,j,p) & - - fcubehalo(i-2,j,p) & - ) / (12_dbl_kind * width**2) - - ! d^2f/dy^2 - recons(4,i,j,p) = (- fcubehalo(i,j+2,p) & - + 16_dbl_kind * fcubehalo(i,j+1,p) & - - 30_dbl_kind * fcubehalo(i,j,p) & - + 16_dbl_kind * fcubehalo(i,j-1,p) & - - fcubehalo(i,j-2,p) & - ) / (12_dbl_kind * width**2) - - ! d^2f/dxdy - recons(5,i,j,p) = & - (+ fcubehalo(i+1,j+1,p) - fcubehalo(i-1,j+1,p) & - - fcubehalo(i+1,j-1,p) + fcubehalo(i-1,j-1,p) & - ) / (4.0 * width * width) - - ! Stretching - recons(3,i,j,p) = & - (- 2.0 * abp_centroid(1,i,j) * (one + abp_centroid(1,i,j)**2) * recons(1,i,j,p) & - + recons(3,i,j,p)) / (one + abp_centroid(1,i,j)**2)**2 - - recons(4,i,j,p) = & - (- 2.0 * abp_centroid(2,i,j) * (one + abp_centroid(2,i,j)**2) * recons(2,i,j,p) & - + recons(4,i,j,p)) / (one + abp_centroid(2,i,j)**2)**2 - - recons(5,i,j,p) = recons(5,i,j,p) / & - ((one + abp_centroid(1,i,j)**2) * (one + abp_centroid(2,i,j)**2)) - - ! Scaling - recons(3,i,j,p) = 0.5 * recons(3,i,j,p) - recons(4,i,j,p) = 0.5 * recons(4,i,j,p) - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE ReconstructABPGradient -! -! Description: -! Compute the reconstructed gradient in gnomonic coordinates for each -! ABP element. -! -! Parameters: -! fcube - Scalar field on the cubed sphere to use in reconstruction -! halomethod - Method for computing halo elements -! (0) Piecewise constant -! (1) Piecewise linear -! (3) Piecewise cubic -! recons_method - Method for computing the sub-grid scale gradient -! (0) Non-equidistant linear reconstruction -! (1) Non-equidistant parabolic reconstruction -! (2) Piecewise linear reconstruction with stretching -! (3) Piecewise parabolic reconstruction with stretching -! order - Order of the method being applied -! kmono - Apply monotone limiting (1) or not (0) -! recons (INOUT) - Array of reconstructed coefficients -!------------------------------------------------------------------------------ - SUBROUTINE ReconstructABPGradient( & - fcube, halomethod, recons_method, order, kmono, recons, kpd, kscheme) - -! USE InterpolateCSLL_Utils - - IMPLICIT NONE - - REAL (KIND=dbl_kind), & - DIMENSION(1:ncube_reconstruct-1, 1:ncube_reconstruct-1, 6), INTENT(IN) :: fcube - - INTEGER (KIND=int_kind), INTENT(IN) :: halomethod, recons_method - INTEGER (KIND=int_kind), INTENT(IN) :: order, kmono, kpd, kscheme - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, p - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6) :: fcubehalo - - ! Report status - WRITE (*,*) '...Performing sub-grid scale reconstruction on ABP grid' - - ! Compute element haloes - WRITE(*,*) "fill cubed-sphere halo for reconstruction" - DO p = 1, 6 - IF (halomethod == 0) THEN - CALL CubedSphereFillHalo(fcube, fcubehalo, p, ncube_reconstruct, 2) - - ELSEIF (halomethod == 1) THEN - CALL CubedSphereFillHalo_Linear(fcube, fcubehalo, p, ncube_reconstruct) - - ELSEIF (halomethod == 3) THEN - !halomethod is always 3 in the standard CSLAM setup - CALL CubedSphereFillHalo_Cubic(fcube, fcubehalo, p, ncube_reconstruct) - ELSE - WRITE (*,*) 'Fatal Error: In ReconstructABPGradient' - WRITE (*,*) 'Invalid halo method: ', halomethod - WRITE (*,*) 'Halo method must be 0, 1 or 3.' - STOP - ENDIF - ENDDO - - ! Nonequidistant linear reconstruction - IF (recons_method == 1) THEN - CALL ReconstructABPGradient_NEL(fcubehalo, recons, order) - - ! Nonequidistant parabolic reconstruction (JCP paper) - ELSEIF (recons_method == 2) THEN - WRITE(*,*) "Nonequidistant parabolic reconstruction" - CALL ReconstructABPGradient_NEP(fcubehalo, recons, order) - - ! Piecewise linear reconstruction with rotation - ELSEIF (recons_method == 3) THEN - CALL ReconstructABPGradient_PLM(fcubehalo, recons, order) - - ! Piecewise parabolic reconstruction with rotation - ELSEIF (recons_method == 4) THEN - CALL ReconstructABPGradient_PPM(fcubehalo, recons, order) - - ELSE - WRITE(*,*) 'Fatal Error: In ReconstructABPGradient' - WRITE(*,*) 'Specified recons_method out of range. Given: ', recons_method - WRITE(*,*) 'Valid values: 1, 2, 3, 4' - STOP - ENDIF - - ! Apply monotone filtering - SELECT CASE (kmono) - CASE (0) !Do nothing - WRITE(*,*) "no filter applied to the reconstruction" - CASE (1) - - !Simplest filter: just scales the recon so it's extreme value - !is no bigger than the original values of this point and its neighbors - CALL MonotonizeABPGradient(fcubehalo, order, recons, .FALSE.) - - CASE (2) - - !Applies a more sophisticated Van Leer limiter (or, to be consistent, a filter) - CALL VanLeerLimit(fcubehalo, order, recons) - - CASE (3) - - !Applies a selective filter - CALL MonotonizeABPGradient(fcubehalo, order, recons, .TRUE.) - - CASE (4) - - !A filter that filters the linear part first - CALL MonotonizeABPGradient_New(fcubehalo, order, recons) - - CASE DEFAULT - WRITE(*,*) "Limiter kmono = ", kmono, " does not exist." - STOP 1201 - - END SELECT - - !Apply positive-definite filtering, if desired. This should - !ONLY be applied to the S-L method, since the flux-form - !method needs something different done. (In particular, using - !positive-definite reconstructions does not ensure that a flux- - !form scheme is positive definite, since we could get negatives - !when subtracting the resulting fluxes.) - !HOWEVER...we will allow this to be enabled, for testing purposes - IF ( (kpd > 0 .AND. kscheme == 2) .OR. (kpd == 2 .AND. kscheme == 4) ) THEN - WRITE(*,*) "applying positive deifnite constraint" - CALL PosDefABPGradient(fcubehalo, order, recons) - END IF - - - END SUBROUTINE - - - -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -! SUBROUTINE AdjustLimiter -! -! Description: -! Adjust the slope limiter based on new point values. -! -! Parameters: -! value - Point value -! element_value - Value at the center of the element -! local_max - Local maximum value of the function (from neighbours) -! local_min - Local minimum value of the function (to neighbours) -! min_phi (INOUT) - Slope limiter -!------------------------------------------------------------------------------ - SUBROUTINE AdjustLimiter(value, element_value, local_min, local_max, min_phi) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), INTENT(IN) :: value, element_value - REAL (KIND=dbl_kind), INTENT(IN) :: local_min, local_max - REAL (KIND=dbl_kind), INTENT(INOUT) :: min_phi - - ! Local variables - REAL (KIND=dbl_kind) :: phi = 0.0 - - IF ((local_min > element_value ) .OR. (local_max < element_value )) THEN - WRITE (*,*) 'Fatal Error: In AdjustLimiter' - WRITE (*,*) 'Local min: ', local_min, ' max: ', local_max - WRITE (*,*) 'Elemn: ', element_value - STOP - ENDIF - - ! Check against the minimum bound on the reconstruction - IF (value - element_value > tiny * value) THEN - phi = (local_max - element_value) / & - (value - element_value) - - min_phi = MIN(min_phi, phi) - - ! Check against the maximum bound on the reconstruction - ELSEIF (value - element_value < -tiny * value) THEN - phi = (local_min - element_value) / & - (value - element_value) - - min_phi = MIN(min_phi, phi) - - ENDIF - - IF (min_phi < 0.0) THEN - WRITE (*,*) 'Fatal Error: In AdjustLimiter' - WRITE (*,*) 'Min_Phi: ', min_phi - WRITE (*,*) 'Phi: ', phi - WRITE (*,*) 'Value: ', value - WRITE (*,*) 'Elemn: ', element_value - WRITE (*,*) 'Val-E: ', value - element_value - STOP - ENDIF - - END SUBROUTINE - -!------------------------------------------------------------------------------ -! SUBROUTINE VanLeerLimit -! -! Description: -! Apply a 2D Van Leer-type limiter to a reconstruction. This acts ONLY -! on the linear part of the reconstruction , if any. If passed a PCoM -! reconstruction, this just returns without altering the recon. -! -! Parameters: -! fcubehalo - Scalar field on the cubed sphere to use in reconstruction -! order - Order of the reconstruction -! recons (INOUT) - Array of reconstructed coefficients -! -! Remarks: -! The Van Leer Limiter described here is given on pages 328--329 -! of Dukowicz and Baumgardner (2000). There are no guarantees -! on what it will do to PPM. -!------------------------------------------------------------------------------ - SUBROUTINE VanLeerLimit(fcubehalo, order, recons) - - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(-1:ncube_reconstruct+1, -1:ncube_reconstruct+1, 6), & - INTENT(IN) :: fcubehalo - - INTEGER (KIND=int_kind), INTENT(IN) :: order - - REAL (KIND=dbl_kind), DIMENSION(:,:,:,:), INTENT(INOUT) :: recons - - ! Local variables - INTEGER (KIND=int_kind) :: i, j, k, m, n - - REAL (KIND=dbl_kind) :: local_min, local_max, value, phi, min_phi, & - recon_min, recon_max - - ! The first-order piecewise constant scheme is monotone by construction - IF (order == 1) THEN - RETURN - ENDIF - - ! Apply monotone limiting - DO k = 1, 6 - DO j = 1, ncube_reconstruct-1 - DO i = 1, ncube_reconstruct-1 - CALL ABPHaloMinMax(fcubehalo, i, j, k, local_min, local_max,.FALSE.) - - ! Initialize the limiter - min_phi = one - - ! For the second-order calculation, the minima and maxima will occur - ! at the corner points of the element. For the Van Leer limiter, we - !wish to find BOTH of the reconstruction extrema. - recon_min = bignum - recon_max = -bignum - - DO m = i, i+1 - DO n = j, j+1 - - ! Evaluate the function at each corner point - CALL EvaluateABPReconstruction( & - fcubehalo, recons, i, j, k, gp(m), gp(n), order, value) - recon_min = MIN(recon_min, value) - recon_max = MAX(recon_max, value) - - ENDDO - ENDDO - - !This is equation 27 in Dukowicz and Baumgardner 2000 - min_phi = MIN(one, MAX(0.0, (local_min - fcubehalo(i,j,k))/(recon_min - fcubehalo(i,j,k))), & - MAX(0.0, (local_max - fcubehalo(i,j,k))/(recon_max - fcubehalo(i,j,k))) ) - - IF ((min_phi < -tiny) .OR. (min_phi > one + tiny)) THEN - WRITE (*,*) 'Fatal Error: In MonotonizeABPGradient' - WRITE (*,*) 'Slope limiter out of range: ', min_phi - STOP - ENDIF - - ! Apply monotone limiter to all reconstruction coefficients - recons(1,i,j,k) = min_phi * recons(1,i,j,k) - recons(2,i,j,k) = min_phi * recons(2,i,j,k) - - END DO - END DO - END DO - - - - - END SUBROUTINE VanLeerLimit - - !------------------------------------------------------------------------------ - ! SUBROUTINE EquiangularElementArea - ! - ! Description: - ! Compute the area of a single equiangular cubed sphere grid cell. - ! - ! Parameters: - ! alpha - Alpha coordinate of lower-left corner of grid cell - ! da - Delta alpha - ! beta - Beta coordinate of lower-left corner of grid cell - ! db - Delta beta - !------------------------------------------------------------------------------ - REAL(KIND=dbl_kind) FUNCTION EquiangularElementArea(alpha, da, beta, db) - - IMPLICIT NONE - -! REAL (kind=dbl_kind) :: EquiangularElementArea - REAL (kind=dbl_kind) :: alpha, da, beta, db - REAL (kind=dbl_kind) :: a1, a2, a3, a4 - - ! Calculate interior grid angles - a1 = EquiangularGridAngle(alpha , beta ) - a2 = pi - EquiangularGridAngle(alpha+da, beta ) - a3 = pi - EquiangularGridAngle(alpha , beta+db) - a4 = EquiangularGridAngle(alpha+da, beta+db) - - ! Area = r*r*(-2*pi+sum(interior angles)) - EquiangularElementArea = -pi2 + a1 + a2 + a3 + a4 - - END FUNCTION EquiangularElementArea - - !------------------------------------------------------------------------------ - ! FUNCTION EquiangularGridAngle - ! - ! Description: - ! Compute the angle between equiangular cubed sphere projection grid lines. - ! - ! Parameters: - ! alpha - Alpha coordinate of evaluation point - ! beta - Beta coordinate of evaluation point - !------------------------------------------------------------------------------ - REAL(KIND=dbl_kind) FUNCTION EquiangularGridAngle(alpha, beta) - IMPLICIT NONE - REAL (kind=dbl_kind) :: alpha, beta - EquiangularGridAngle = ACOS(-SIN(alpha) * SIN(beta)) - END FUNCTION EquiangularGridAngle - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! halo region around the specified panel. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -! nhalo - Number of halo/ghost elements around each panel -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo(parg, zarg, np, ncube, nhalo) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube,nhalo - - ! Local variables - INTEGER (KIND=int_kind) :: jh,jhy - - !zarg = 0.0 !DBG - zarg(1:ncube-1,1:ncube-1,np) = parg(1:ncube-1,1:ncube-1,np) - - zarg(1-nhalo:0,1-nhalo:0,np) = 0.0 - zarg(1-nhalo:0,ncube:ncube+nhalo-1,np) = 0.0 - zarg(ncube:ncube+nhalo-1,1-nhalo:0,np) = 0.0 - zarg(ncube:ncube+nhalo-1,ncube:ncube+nhalo-1,np) = 0.0 - - ! Equatorial panels - IF (np==1) THEN - DO jh=1,nhalo - zarg(ncube+jh-1,1:ncube-1 ,1) = parg(jh ,1:ncube-1 ,2) !exchange right - zarg(1-jh ,1:ncube-1 ,1) = parg(ncube-jh ,1:ncube-1 ,4) !exchange left - zarg(1:ncube-1 ,1-jh ,1) = parg(1:ncube-1 ,ncube-jh ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,1) = parg(1:ncube-1 ,jh ,6) !exchange over - ENDDO - - ELSE IF (np==2) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,2) = parg(ncube-jh,1:ncube-1 ,1) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,2) = parg(jh ,1:ncube-1 ,3) !exchange right - zarg(1:ncube-1 ,1-jh ,2) = parg(ncube-jh,ncube-1:1:-1,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,2) = parg(ncube-jh,1:ncube-1 ,6) !exchange over - ENDDO - - ELSE IF (np==3) THEN - DO jh=1,nhalo - zarg(ncube+jh-1,1:ncube-1 ,3) = parg(jh ,1:ncube-1,4) !exchange right - zarg(1-jh ,1:ncube-1 ,3) = parg(ncube-jh ,1:ncube-1,2) !exchange left - zarg(1:ncube-1 ,1-jh ,3) = parg(ncube-1:1:-1,jh ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,3) = parg(ncube-1:1:-1,ncube-jh ,6) !exchange over - ENDDO - - ELSE IF (np==4) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,4) = parg(ncube-jh,1:ncube-1 ,3) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,4) = parg(jh ,1:ncube-1 ,1) !exchange right - zarg(1:ncube-1 ,1-jh ,4) = parg(jh ,1:ncube-1 ,5) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,4) = parg(jh ,ncube-1:1:-1,6) !exchange over - ENDDO - - ! Bottom panel - ELSE IF (np==5) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,5) = parg(1:ncube-1 ,jh ,4) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,5) = parg(ncube-1:1:-1,jh ,2) !exchange right - zarg(1:ncube-1 ,1-jh ,5) = parg(ncube-1:1:-1,jh ,3) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,5) = parg(1:ncube-1 ,jh ,1) !exchange over - ENDDO - - ! Top panel - ELSE IF (np==6) THEN - DO jh=1,nhalo - zarg(1-jh ,1:ncube-1 ,6) = parg(ncube-1:1:-1,ncube-jh,4) !exchange left - zarg(ncube+jh-1,1:ncube-1 ,6) = parg(1:ncube-1 ,ncube-jh,2) !exchange right - zarg(1:ncube-1 ,1-jh ,6) = parg(1:ncube-1 ,ncube-jh,1) !exchange below - zarg(1:ncube-1 ,ncube+jh-1,6) = parg(ncube-1:1:-1,ncube-jh,3) !exchange over - ENDDO - - ELSE - WRITE (*,*) 'Fatal error: In CubedSphereFillHalo' - WRITE (*,*) 'Invalid panel id ', np - STOP - ENDIF - - END SUBROUTINE CubedSphereFillHalo - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo_Linear -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! 2-element halo region around the specified panel. Use linear order -! interpolation to translate between panels. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo_Linear(parg, zarg, np, ncube) - -! USE CubedSphereTrans ! Cubed sphere transforms - - IMPLICIT NONE - - INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube - - ! Local variables - INTEGER (KIND=int_kind) :: ii, iref, jj, ipanel, imin, imax - REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta - - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg - - ! Use 0.0 order interpolation to begin - CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) - - zarg(:,:,np) = yarg(:,:,np) - - ! Calculate the overlapping alpha coordinates - width = pih / DBLE(ncube-1) - - DO jj = 1, nhalo - DO ii = 0, ncube - prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq - beta = - width * (DBLE(jj-1) + 0.5) - piq - - CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & - newalpha(ii,jj), newbeta) - ENDDO - ENDDO - - ! Now apply linear interpolation to obtain edge components - DO jj = 1, nhalo - ! Reset the reference index - iref = 2 - - ! Interpolation can be applied to more elements after first band - IF (jj == 1) THEN - imin = 1 - imax = ncube-1 - ELSE - imin = 0 - imax = ncube - ENDIF - - ! Apply linear interpolation - DO ii = imin, imax - DO WHILE ((iref .NE. ncube-1) .AND. & - (newalpha(ii,jj) > prealpha(iref,jj))) - iref = iref + 1 - ENDDO - - IF ((newalpha(ii,jj) > prealpha(iref-1,jj)) .AND. & - (newalpha(ii,jj) .LE. prealpha(iref ,jj))) & - THEN - a = (newalpha(ii,jj) - prealpha(iref-1,jj)) / & - (prealpha(iref,jj) - prealpha(iref-1,jj)) - - IF ((a < 0.0) .OR. (a > one)) THEN - WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' - WRITE (*,*) 'a out of bounds' - STOP - ENDIF - - ! Bottom edge of panel - zarg(ii, 1-jj, np) = & - (one - a) * yarg(iref-1, 1-jj, np) + & - a * yarg(iref, 1-jj, np) - - ! Left edge of panel - zarg(1-jj, ii, np) = & - (one - a) * yarg(1-jj, iref-1, np) + & - a * yarg(1-jj, iref, np) - - ! Top edge of panel - zarg(ii, ncube+jj-1, np) = & - (one - a) * yarg(iref-1, ncube+jj-1, np) + & - a * yarg(iref, ncube+jj-1, np) - - ! Right edge of panel - zarg(ncube+jj-1, ii, np) = & - (one - a) * yarg(ncube+jj-1, iref-1, np) + & - a * yarg(ncube+jj-1, iref, np) - - ELSE - WRITE (*,*) 'FAIL in CubedSphereFillHalo_Linear' - WRITE (*,*) 'ii: ', ii, ' jj: ', jj - WRITE (*,*) 'newalpha: ', newalpha(ii,jj) - WRITE (*,*) 'prealpha: ', prealpha(iref-1,jj), '-', prealpha(iref,jj) - STOP - ENDIF - ENDDO - ENDDO - - ! Fill in corner bits - zarg(0, 0, np) = & - 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & - zarg(-1,0,np) + zarg(0,-1,np)) - zarg(0, ncube, np) = & - 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & - zarg(-1,ncube,np) + zarg(1,ncube,np)) - zarg(ncube, 0, np) = & - 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & - zarg(ncube,-1,np) + zarg(ncube,1,np)) - zarg(ncube, ncube, np) = & - 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & - zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) - - END SUBROUTINE CubedSphereFillHalo_Linear - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereFillHalo_Cubic -! -! Description: -! Recompute the cubed sphere data storage array, with the addition of a -! 2-element halo region around the specified panel. Use higher order -! interpolation to translate between panels. -! -! Parameters: -! parg - Current panel values -! zarg (OUT) - Calculated panel values with halo/ghost region -! np - Panel number -! ncube - Dimension of the cubed sphere (# of grid lines) -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereFillHalo_Cubic(parg, zarg, np, ncube) - -! USE CubedSphereTrans ! Cubed sphere transforms -! USE MathUtils ! Has function for 1D cubic interpolation - - IMPLICIT NONE - - INTEGER (KIND=int_kind), PARAMETER :: nhalo = 2 - - REAL (KIND=dbl_kind), DIMENSION(ncube-1, ncube-1, 6), INTENT(IN) :: parg - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6), & - INTENT(OUT) :: zarg - - INTEGER (KIND=int_kind), INTENT(IN) :: np, ncube - - ! Local variables - INTEGER (KIND=int_kind) :: ii, iref, ibaseref, jj, ipanel, imin, imax - REAL (KIND=dbl_kind) :: width, lon, lat, beta, a, newbeta - - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: prealpha - REAL (KIND=dbl_kind), DIMENSION(0:ncube, nhalo) :: newalpha - REAL (KIND=dbl_kind), DIMENSION(1:4) :: C, D, X - - REAL (KIND=dbl_kind), & - DIMENSION(1-nhalo:ncube+nhalo-1, 1-nhalo:ncube+nhalo-1, 6) :: yarg - - ! Use 0.0 order interpolation to begin - CALL CubedSphereFillHalo(parg, yarg, np, ncube, nhalo) - - zarg(:,:,np) = yarg(:,:,np) - - ! Calculate the overlapping alpha coordinates - width = pih / DBLE(ncube-1) - - DO jj = 1, nhalo - DO ii = 0, ncube - ! - ! alpha,beta for the cell center (extending the panel) - ! - prealpha(ii, jj) = width * (DBLE(ii-1) + 0.5) - piq - beta = - width * (DBLE(jj-1) + 0.5) - piq - - CALL CubedSphereABPFromABP(prealpha(ii,jj), beta, 1, 5, & - newalpha(ii,jj), newbeta) - ENDDO - ENDDO - - ! Now apply cubic interpolation to obtain edge components - DO jj = 1, nhalo - ! Reset the reference index, which gives the element in newalpha that - ! is closest to ii, looking towards larger values of alpha. - iref = 2 - - ! Interpolation can be applied to more elements after first band -! IF (jj == 1) THEN -! imin = 1 -! imax = ncube-1 -! ELSE - imin = 0 - imax = ncube -! ENDIF - - ! Apply cubic interpolation - DO ii = imin, imax - DO WHILE ((iref .NE. ncube-1) .AND. & - (newalpha(ii,jj) > prealpha(iref,jj))) - iref = iref + 1 - ENDDO - - ! Smallest index for cubic interpolation - apply special consideration - IF (iref == 2) THEN - ibaseref = iref-1 - - ! Largest index for cubic interpolation - apply special consideration - ELSEIF (iref == ncube-1) THEN - ibaseref = iref-3 - - ! Normal range - ELSE - ibaseref = iref-2 - ENDIF - - ! Bottom edge of panel - zarg(ii, 1-jj, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ibaseref:ibaseref+3, 1-jj, np)) - - ! Left edge of panel - zarg(1-jj, ii, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(1-jj, ibaseref:ibaseref+3, np)) - - ! Top edge of panel - zarg(ii, ncube+jj-1, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ibaseref:ibaseref+3, ncube+jj-1, np)) - - ! Right edge of panel - zarg(ncube+jj-1, ii, np) = & - CUBIC_EQUISPACE_INTERP( & - width, newalpha(ii,jj) - prealpha(ibaseref,jj), & - yarg(ncube+jj-1, ibaseref:ibaseref+3, np)) - - ENDDO - ENDDO - - ! Fill in corner bits - zarg(0, 0, np) = & - 0.25 * (zarg(1,0,np) + zarg(0,1,np) + & - zarg(-1,0,np) + zarg(0,-1,np)) - zarg(0, ncube, np) = & - 0.25 * (zarg(0,ncube-1,np) + zarg(0,ncube+1,np) + & - zarg(-1,ncube,np) + zarg(1,ncube,np)) - zarg(ncube, 0, np) = & - 0.25 * (zarg(ncube-1,0,np) + zarg(ncube+1,0,np) + & - zarg(ncube,-1,np) + zarg(ncube,1,np)) - zarg(ncube, ncube, np) = & - 0.25 * (zarg(ncube-1,ncube,np) + zarg(ncube+1,ncube,np) + & - zarg(ncube,ncube-1,np) + zarg(ncube,ncube+1,np)) - - END SUBROUTINE CubedSphereFillHalo_Cubic - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromABP -! -! Description: -! Determine the (alpha,beta,idest) coordinate of a source point on -! panel isource. -! -! Parameters: -! alpha_in - Alpha coordinate in -! beta_in - Beta coordinate in -! isource - Source panel -! idest - Destination panel -! alpha_out (OUT) - Alpha coordinate out -! beta_out (OUT) - Beta coordiante out -!------------------------------------------------------------------------------ - SUBROUTINE CubedSphereABPFromABP(alpha_in, beta_in, isource, idest, & - alpha_out, beta_out) - - IMPLICIT NONE - - REAL (KIND=dbl_kind), INTENT(IN) :: alpha_in, beta_in - INTEGER (KIND=int_kind), INTENT(IN) :: isource, idest - REAL (KIND=dbl_kind), INTENT(OUT) :: alpha_out, beta_out - - ! Local variables - REAL (KIND=dbl_kind) :: a1, b1 - REAL (KIND=dbl_kind) :: xx, yy, zz - REAL (KIND=dbl_kind) :: sx, sy, sz - - ! Convert to relative Cartesian coordinates - a1 = TAN(alpha_in) - b1 = TAN(beta_in) - - sz = (one + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - - ! Convert to full Cartesian coordinates - IF (isource == 6) THEN - yy = sx; xx = -sy; zz = sz - - ELSEIF (isource == 5) THEN - yy = sx; xx = sy; zz = -sz - - ELSEIF (isource == 1) THEN - yy = sx; zz = sy; xx = sz - - ELSEIF (isource == 3) THEN - yy = -sx; zz = sy; xx = -sz - - ELSEIF (isource == 2) THEN - xx = -sx; zz = sy; yy = sz - - ELSEIF (isource == 4) THEN - xx = sx; zz = sy; yy = -sz - - ELSE - WRITE(*,*) 'Fatal Error: Source panel invalid in CubedSphereABPFromABP' - WRITE(*,*) 'panel = ', isource - STOP - ENDIF - - ! Convert to relative Cartesian coordinates on destination panel - IF (idest == 6) THEN - sx = yy; sy = -xx; sz = zz - - ELSEIF (idest == 5) THEN - sx = yy; sy = xx; sz = -zz - - ELSEIF (idest == 1) THEN - sx = yy; sy = zz; sz = xx - - ELSEIF (idest == 3) THEN - sx = -yy; sy = zz; sz = -xx - - ELSEIF (idest == 2) THEN - sx = -xx; sy = zz; sz = yy - - ELSEIF (idest == 4) THEN - sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: Dest panel invalid in CubedSphereABPFromABP' - WRITE(*,*) 'panel = ', idest - STOP - ENDIF - IF (sz < 0) THEN - WRITE(*,*) 'Fatal Error: In CubedSphereABPFromABP' - WRITE(*,*) 'Invalid relative Z coordinate' - STOP - ENDIF - - ! Use panel information to calculate (alpha, beta) coords - alpha_out = ATAN(sx / sz) - beta_out = ATAN(sy / sz) - - END SUBROUTINE - - -!------------------------------------------------------------------------------ -! FUNCTION CUBIC_EQUISPACE_INTERP -! -! Description: -! Apply cubic interpolation on the specified array of values, where all -! points are equally spaced. -! -! Parameters: -! dx - Spacing of points -! x - X coordinate where interpolation is to be applied -! y - Array of 4 values = f(x + k * dx) where k = 0,1,2,3 -!------------------------------------------------------------------------------ - FUNCTION CUBIC_EQUISPACE_INTERP(dx, x, y) - - IMPLICIT NONE - - REAL (KIND=dbl_kind) :: CUBIC_EQUISPACE_INTERP - REAL (KIND=dbl_kind) :: dx, x - REAL (KIND=dbl_kind), DIMENSION(1:4) :: y - - CUBIC_EQUISPACE_INTERP = & - (-y(1) / (6.0 * dx**3)) * (x - dx) * (x - 2.0 * dx) * (x - 3.0 * dx) + & - ( y(2) / (2.0 * dx**3)) * (x) * (x - 2.0 * dx) * (x - 3.0 * dx) + & - (-y(3) / (2.0 * dx**3)) * (x) * (x - dx) * (x - 3.0 * dx) + & - ( y(4) / (6.0 * dx**3)) * (x) * (x - dx) * (x - 2.0 * dx) - - END FUNCTION CUBIC_EQUISPACE_INTERP - -! FUNCTION I_10_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind) :: I_10_AB -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! I_10_ab = -ASINH(COS(alpha) * TAN(beta)) -! END FUNCTION I_10_AB -!! -! -! REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! I_01_ab = -ASINH(COS(beta) * TAN(alpha)) -! END FUNCTION I_01_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) -! END FUNCTION I_20_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) -! END FUNCTION I_02_AB -! -! REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) -! IMPLICIT NONE -! REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta -! -! I_11_ab = -SQRT(1.0+TAN(alpha)**2+TAN(beta)**2) -! END FUNCTION I_11_AB -! - - -END MODULE reconstruct - diff --git a/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 b/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 deleted file mode 100755 index ed87b29c5a6d..000000000000 --- a/components/eam/tools/topo_tool/orographic_drag_toolkit/remap.F90 +++ /dev/null @@ -1,1562 +0,0 @@ -MODULE remap - INTEGER, PARAMETER :: & - int_kind = KIND(1), & - real_kind = SELECTED_REAL_KIND(p=14,r=100),& - dbl_kind = selected_real_kind(13) - - INTEGER :: nc,nhe - -! LOGICAL, PARAMETER:: ldbgr_r = .FALSE. - LOGICAL :: ldbgr - LOGICAL :: ldbg_global - - REAL(kind=real_kind), PARAMETER :: & - one = 1.0 ,& - aa = 1.0 ,& - tiny= 1.0E-9 ,& - bignum = 1.0E20 - REAL (KIND=dbl_kind), parameter :: fuzzy_width = 10.0*tiny !CAM-SE add - - contains - - - subroutine compute_weights_cell(xcell_in,ycell_in,jx,jy,nreconstruction,xgno,ygno,& - jx_min, jx_max, jy_min, jy_max,tmp,& - ngauss,gauss_weights,abscissae,weights,weights_eul_index,jcollect,jmax_segments,& - nc_in,nhe_in,nvertex,ldbg) - - implicit none - integer (kind=int_kind) , intent(in):: nreconstruction, jx,jy,ngauss,jmax_segments - real (kind=real_kind) , dimension(0:nvertex+1) :: xcell_in,ycell_in -! real (kind=real_kind) , dimension(0:5), intent(in):: xcell_in,ycell_in - integer (kind=int_kind), intent(in) :: nc_in,nhe_in,nvertex - logical, intent(in) :: ldbg - ! - ! ipanel is just for debugging - ! - integer (kind=int_kind), intent(in) :: jx_min, jy_min, jx_max, jy_max - real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: xgno - real (kind=real_kind), dimension(-nhe_in:nc_in+2+nhe_in), intent(in) :: ygno - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - ! - ! boundaries of domain - ! - real (kind=real_kind):: tmp - ! - ! Number of Eulerian sub-cell integrals for the cell in question - ! - integer (kind=int_kind), intent(out) :: jcollect - ! - ! local workspace - ! - ! - ! max number of line segments is: - ! - ! (number of longitudes)*(max average number of crossings per line segment = 3)*ncube*2 - ! - real (kind=real_kind) , & - dimension(jmax_segments,nreconstruction), intent(out) :: weights - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(out) :: weights_eul_index - - real (kind=real_kind), dimension(0:3) :: x,y - integer (kind=int_kind),dimension(0:5) :: jx_eul, jy_eul - integer (kind=int_kind) :: jsegment,i - ! - ! variables for registering crossings with Eulerian latitudes and longitudes - ! - integer (kind=int_kind) :: jcross_lat, iter - ! - ! max. crossings per side is 2*nhe - ! - real (kind=real_kind), & - dimension(jmax_segments,2) :: r_cross_lat - integer (kind=int_kind), & - dimension(jmax_segments,2) :: cross_lat_eul_index - real (kind=real_kind) , dimension(1:nvertex) :: xcell,ycell - - real (kind=real_kind) :: eps - - ldbg_global = ldbg - ldbgr = ldbg - - nc = nc_in - nhe = nhe_in - - xcell = xcell_in(1:nvertex) - ycell = ycell_in(1:nvertex) - - - ! - ! this is to avoid ill-conditioning problems - ! - eps = 1.0E-9 - - jsegment = 0 - weights = 0.0D0 - jcross_lat = 0 - ! - !********************** - ! - ! Integrate cell sides - ! - !********************** - - - IF (jx<-nhe.OR.jx>nc+1+nhe.OR.jy<-nhe.OR.jy>nc+1+nhe) THEN - WRITE(*,*) "jx,jy,-nhe,nc+1+nhe",jx,jy,-nhe,nc+1+nhe - STOP - END IF - - - call side_integral(xcell,ycell,nvertex,jsegment,jmax_segments,& - weights,weights_eul_index,nreconstruction,jx,jy,xgno,ygno,jx_min, jx_max, jy_min, jy_max,& - ngauss,gauss_weights,abscissae,& - jcross_lat,r_cross_lat,cross_lat_eul_index) - - ! - !********************** - ! - ! Do inner integrals - ! - !********************** - ! - call compute_inner_line_integrals_lat_nonconvex(r_cross_lat,cross_lat_eul_index,& - jcross_lat,jsegment,jmax_segments,xgno,jx_min, jx_max, jy_min, jy_max,& - weights,weights_eul_index,& - nreconstruction,ngauss,gauss_weights,abscissae) - ! - ! collect line-segment that reside in the same Eulerian cell - ! - if (jsegment>0) then - call collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) - ! - ! DBG - ! - tmp=0.0 - do i=1,jcollect - tmp=tmp+weights(i,1) - enddo - - IF (abs(tmp)>0.01) THEN - WRITE(*,*) "sum of weights too large",tmp - !stop - END IF - IF (tmp<-1.0E-9) THEN - WRITE(*,*) "sum of weights is negative - negative area?",tmp,jx,jy - ! ldbgr=.TRUE. - !stop - !!turn this off for phys grid as that of E3SM - END IF - else - jcollect = 0 - end if - end subroutine compute_weights_cell - - - ! - !**************************************************************************** - ! - ! organize data and store it - ! - !**************************************************************************** - ! - subroutine collect(weights,weights_eul_index,nreconstruction,jcollect,jsegment,jmax_segments) - implicit none - integer (kind=int_kind) , intent(in) :: nreconstruction - real (kind=real_kind) , dimension(jmax_segments,nreconstruction), intent(inout) :: weights - integer (kind=int_kind), dimension(jmax_segments,2 ), intent(inout) :: weights_eul_index - integer (kind=int_kind), INTENT(OUT ) :: jcollect - integer (kind=int_kind), INTENT(IN ) :: jsegment,jmax_segments - ! - ! local workspace - ! - integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k,h - logical :: ltmp - - real (kind=real_kind) , dimension(jmax_segments,nreconstruction) :: weights_out - integer (kind=int_kind), dimension(jmax_segments,2 ) :: weights_eul_index_out - - weights_out = 0.0D0 - weights_eul_index_out = -100 - - imin = MINVAL(weights_eul_index(1:jsegment,1)) - imax = MAXVAL(weights_eul_index(1:jsegment,1)) - jmin = MINVAL(weights_eul_index(1:jsegment,2)) - jmax = MAXVAL(weights_eul_index(1:jsegment,2)) - - ltmp = .FALSE. - - jcollect = 1 - - do j=jmin,jmax - do i=imin,imax - do k=1,jsegment - if (weights_eul_index(k,1)==i.AND.weights_eul_index(k,2)==j) then - weights_out(jcollect,1:nreconstruction) = & - weights_out(jcollect,1:nreconstruction) + weights(k,1:nreconstruction) - ltmp = .TRUE. - h = k - endif - enddo - if (ltmp) then - weights_eul_index_out(jcollect,:) = weights_eul_index(h,:) - jcollect = jcollect+1 - endif - ltmp = .FALSE. - enddo - enddo - jcollect = jcollect-1 - weights = weights_out - weights_eul_index = weights_eul_index_out - end subroutine collect - ! - !***************************************************************************************** - ! - ! - ! - !***************************************************************************************** - ! - subroutine compute_inner_line_integrals_lat(r_cross_lat,cross_lat_eul_index,& - jcross_lat,jsegment,jmax_segments,xgno,jx_min,jx_max,jy_min, jy_max,weights,weights_eul_index,& - nreconstruction,ngauss,gauss_weights,abscissae)!phl add jx_min etc. - implicit none - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - ! - ! variables for registering crossings with Eulerian latitudes and longitudes - ! - integer (kind=int_kind), intent(in):: jcross_lat, jmax_segments,nreconstruction,ngauss - integer (kind=int_kind), intent(inout):: jsegment - ! - ! max. crossings per side is 2*nhe - ! - real (kind=real_kind), & - dimension(jmax_segments,2), intent(in):: r_cross_lat - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(in):: cross_lat_eul_index - integer (kind=int_kind), intent(in) ::jx_min, jx_max, jy_min, jy_max - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: xgno - real (kind=real_kind) , & - dimension(jmax_segments,nreconstruction), intent(inout) :: weights - integer (kind=int_kind), & - dimension(jmax_segments,2), intent(inout) :: weights_eul_index - real (kind=real_kind) , dimension(nreconstruction) :: weights_tmp - - integer (kind=int_kind) :: imin, imax, jmin, jmax, i,j,k, isgn, h, eul_jx, eul_jy - integer (kind=int_kind) :: idx_start_y,idx_end_y - logical :: ltmp,lcontinue - real (kind=real_kind), dimension(2) :: rstart,rend,rend_tmp - real (kind=real_kind), dimension(2) :: xseg, yseg -5 FORMAT(10e14.6) - - - if (jcross_lat>0) then - do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) - ! - ! find "first" crossing with Eulerian cell i - ! - do k=1,jcross_lat - if (cross_lat_eul_index(k,2)==i) exit - enddo - do j=k+1,jcross_lat - ! - ! find "second" crossing with Eulerian cell i - ! - if (cross_lat_eul_index(j,2)==i) then - if (r_cross_lat(k,1)0) then - do i=MINVAL(cross_lat_eul_index(1:jcross_lat,2)),MAXVAL(cross_lat_eul_index(1:jcross_lat,2)) - ! WRITE(*,*) "looking at latitude ",i !xxxx - count = 1 - ! - ! find all crossings with Eulerian latitude i - ! - do k=1,jcross_lat - if (cross_lat_eul_index(k,2)==i) then - ! WRITE(*,*) "other crossings with latitude",i ," is ",k!xxxx - r_cross_lat_seg (count,:) = r_cross_lat (k,:) - cross_lat_eul_index_seg(count,:) = cross_lat_eul_index(k,:) - - IF (ldbg_global) then - WRITE(*,*) r_cross_lat_seg(count,1),r_cross_lat_seg(count,2) - WRITE(*,*) " " - END IF - count = count+1 - end if - enddo - count = count-1 - IF (ABS((count/2)-DBLE(count)/2.0)1000) THEN - WRITE(*,*) "search not converging",iter - STOP - END IF - lsame_cell_x = (x(2).GE.xgno(jx_eul).AND.x(2).LE.xgno(jx_eul+1)) - lsame_cell_y = (y(2).GE.ygno(jy_eul).AND.y(2).LE.ygno(jy_eul+1)) -! IF (ldbgr) WRITE(*,*) "lsame_cell_x,lsame_cell_y=",lsame_cell_x,lsame_cell_y - IF (lsame_cell_x.AND.lsame_cell_y) THEN - ! - !**************************** - ! - ! same cell integral - ! - !**************************** - ! -! IF (ldbgr) WRITE(*,*) "same cell integral",jx_eul,jy_eul - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = x(2); yseg(2) = y(2) - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - lcontinue = .FALSE. - ! - ! prepare for next side if (x(2),y(2)) is on a grid line - ! - IF (x(2).EQ.xgno(jx_eul+1).AND.x(3)>xgno(jx_eul+1)) THEN - ! - ! cross longitude jx_eul+1 - ! -! IF (ldbgr) WRITE(*,*) "cross longitude",jx_eul+1 - jx_eul=jx_eul+1 - ELSE IF (x(2).EQ.xgno(jx_eul ).AND.x(3)ygno(jy_eul+1)) THEN - ! - ! register crossing with latitude: line-segments point Northward - ! - jcross_lat = jcross_lat + 1 - jy_eul = jy_eul + 1 -! IF (ldbgr) WRITE(*,*) "cross latitude",jy_eul - cross_lat_eul_index(jcross_lat,1) = jx_eul - cross_lat_eul_index(jcross_lat,2) = jy_eul - r_cross_lat(jcross_lat,1) = x(2) - r_cross_lat(jcross_lat,2) = y(2) - ELSE IF (y(2).EQ.ygno(jy_eul ).AND.y(3)y(1) else "0" - ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" - ! - !******************************************************************************* - ! - ! there is at least one crossing with latitudes but no crossing with longitudes - ! - !******************************************************************************* - ! - yeul = ygno(jy_eul+ysgn1) - IF (x(1).EQ.x(2)) THEN - ! - ! line segment is parallel to longitude (infinite slope) - ! -! IF (ldbgr) WRITE(*,*) "line segment parallel to longitude" - xcross = x(1) - ELSE - slope = (y(2)-y(1))/(x(2)-x(1)) - xcross = x_cross_eul_lat(x(1),y(1),yeul,slope) - ! - ! constrain crossing to be "physically" possible - ! - xcross = MIN(MAX(xcross,xgno(jx_eul)),xgno(jx_eul+1)) - - -! IF (ldbgr) WRITE(*,*) "cross latitude" - ! - ! debugging - ! - IF (xcross.GT.xgno(jx_eul+1).OR.xcross.LT.xgno(jx_eul)) THEN - WRITE(*,*) "xcross is out of range",jx,jy - WRITE(*,*) "xcross-xgno(jx_eul+1), xcross-xgno(jx_eul))",& - xcross-xgno(jx_eul+1), xcross-ygno(jx_eul) - STOP - END IF - END IF - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 - ! - ! register crossing with latitude - ! - jcross_lat = jcross_lat+1 - cross_lat_eul_index(jcross_lat,1) = jx_eul - if (ysgn2>0) then - cross_lat_eul_index(jcross_lat,2) = jy_eul - else - cross_lat_eul_index(jcross_lat,2) = jy_eul+1 - end if - r_cross_lat(jcross_lat,1) = xcross - r_cross_lat(jcross_lat,2) = yeul - ELSE IF (lsame_cell_y) THEN -! IF (ldbgr) WRITE(*,*) "same cell y" - ! - !******************************************************************************* - ! - ! there is at least one crossing with longitudes but no crossing with latitudes - ! - !******************************************************************************* - ! - xsgn1 = (1+INT(SIGN(1.0D0,x(2)-x(1))))/2 !"1" if x(2)>x(1) else "0" - xsgn2 = INT(SIGN(1.0D0,x(2)-x(1))) !"1" if x(2)>x(1) else "-1" - xeul = xgno(jx_eul+xsgn1) -! IF (ldbgr) WRITE(*,*) " crossing longitude",jx_eul+xsgn1 - IF (ABS(x(2)-x(1))x(1) else "0" - xsgn2 = (INT(SIGN(1.0D0,x(2)-x(1)))) !"1" if x(2)>x(1) else "0" - xeul = xgno(jx_eul+xsgn1) - ysgn1 = (1+INT(SIGN(1.0D0,y(2)-y(1))))/2 !"1" if y(2)>y(1) else "0" - ysgn2 = INT(SIGN(1.0D0,y(2)-y(1))) !"1" if y(2)>y(1) else "-1" - yeul = ygno(jy_eul+ysgn1) - - slope = (y(2)-y(1))/(x(2)-x(1)) - IF (ABS(x(2)-x(1))0.AND.xcross.LE.xeul).OR.(xsgn2<0.AND.xcross.GE.xeul)) THEN - ! - ! cross latitude - ! -! IF (ldbgr) WRITE(*,*) "crossing latitude",jy_eul+ysgn1 - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xcross; yseg(2) = yeul - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xcross; y(1) = yeul; jy_eul = jy_eul+ysgn2 - ! - ! register crossing with latitude - ! - jcross_lat = jcross_lat+1 - cross_lat_eul_index(jcross_lat,1) = jx_eul - if (ysgn2>0) then - cross_lat_eul_index(jcross_lat,2) = jy_eul - else - cross_lat_eul_index(jcross_lat,2) = jy_eul+1 - end if - r_cross_lat(jcross_lat,1) = xcross - r_cross_lat(jcross_lat,2) = yeul - ELSE - ! - ! cross longitude - ! -! IF (ldbgr) WRITE(*,*) "crossing longitude",jx_eul+xsgn1 - xseg(1) = x(1); yseg(1) = y(1); xseg(2) = xeul; yseg(2) = ycross - jx_eul_tmp = jx_eul; jy_eul_tmp = jy_eul; - ! - ! prepare for next iteration - ! - x(0) = x(1); y(0) = y(1); x(1) = xeul; y(1) = ycross; jx_eul = jx_eul+xsgn2 - END IF - - END IF - END IF - ! - ! register line-segment (don't register line-segment if outside of panel) - ! - if (jx_eul_tmp>=jx_min.AND.jy_eul_tmp>=jy_min.AND.& - jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1) then - ! jx_eul_tmp<=jx_max-1.AND.jy_eul_tmp<=jy_max-1.AND.side_count<3) then - jsegment=jsegment+1 - weights_eul_index(jsegment,1) = jx_eul_tmp - weights_eul_index(jsegment,2) = jy_eul_tmp - call get_weights_gauss(weights(jsegment,1:nreconstruction),& - xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) - -! if (ldbg_global) then -! OPEN(unit=40, file='side_integral.dat',status='old',access='append') -! WRITE(40,*) xseg(1),yseg(1) -! WRITE(40,*) xseg(2),yseg(2) -! WRITE(40,*) " " -! CLOSE(40) -! end if - - - jdbg=jdbg+1 - - if (xseg(1).EQ.xseg(2))then - slope = bignum - else if (abs(yseg(1) -yseg(2))0) THEN - compute_slope = (y(2)-y(1))/(x(2)-x(1)) - else - compute_slope = bignum - end if - end function compute_slope - - real (kind=real_kind) function y_cross_eul_lon(x,y,xeul,slope) - implicit none - real (kind=real_kind), intent(in) :: x,y - real (kind=real_kind) , intent(in) :: xeul,slope - ! line: y=a*x+b - real (kind=real_kind) :: a,b - b = y-slope*x - y_cross_eul_lon = slope*xeul+b - end function y_cross_eul_lon - - real (kind=real_kind) function x_cross_eul_lat(x,y,yeul,slope) - implicit none - real (kind=real_kind), intent(in) :: x,y - real (kind=real_kind) , intent(in) :: yeul,slope - - if (fuzzy(ABS(slope),fuzzy_width)>0) THEN - x_cross_eul_lat = x+(yeul-y)/slope - ELSE - ! WRITE(*,*) "WARNING: slope is epsilon - ABORT" - x_cross_eul_lat = bignum - END IF - end function x_cross_eul_lat - - subroutine get_weights_exact(weights,xseg,yseg,nreconstruction) -! use cslam_analytic_mod, only: I_00, I_10, I_01, I_20, I_02, I_11 - implicit none - integer (kind=int_kind), intent(in) :: nreconstruction - real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights - real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg - ! - ! compute weights - ! - real (kind=real_kind) :: tmp,slope,b,integral,dx2,xc - integer (kind=int_kind) :: i -! weights(:) = -half*(xseg(1)*yseg(2)-xseg(2)*yseg(1)) !dummy for testing - - weights(1) = ((I_00(xseg(2),yseg(2))-I_00(xseg(1),yseg(1)))) - if (ABS(weights(1))>1.0) THEN - WRITE(*,*) "1 exact weights(jsegment)",weights(1),xseg,yseg - stop - end if - if (nreconstruction>1) then - weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) - weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) - endif - if (nreconstruction>3) then - weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) - weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) - weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) - endif - - end subroutine get_weights_exact - - - - subroutine get_weights_gauss(weights,xseg,yseg,nreconstruction,ngauss,gauss_weights,abscissae) - implicit none - integer (kind=int_kind), intent(in) :: nreconstruction,ngauss - real (kind=real_kind), dimension(nreconstruction), intent(out) :: weights - real (kind=real_kind), dimension(2 ), intent(in) :: xseg,yseg - real (kind=real_kind) :: slope - ! - ! compute weights - ! - ! - ! for Gaussian quadrature - ! - real (kind=real_kind), dimension(ngauss), intent(in) :: gauss_weights, abscissae - - ! if line-segment parallel to x or y use exact formulaes else use qudrature - ! - real (kind=real_kind) :: tmp,b,integral,dx2,xc,x,y - integer (kind=int_kind) :: i - - - - -! if (fuzzy(abs(xseg(1) -xseg(2)),fuzzy_width)==0)then - if (xseg(1).EQ.xseg(2))then - weights = 0.0D0 - else if (abs(yseg(1) -yseg(2))1) then - weights(2) = ((I_10(xseg(2),yseg(2))-I_10(xseg(1),yseg(1)))) - weights(3) = ((I_01(xseg(2),yseg(2))-I_01(xseg(1),yseg(1)))) - endif - if (nreconstruction>3) then - weights(4) = ((I_20(xseg(2),yseg(2))-I_20(xseg(1),yseg(1)))) - weights(5) = ((I_02(xseg(2),yseg(2))-I_02(xseg(1),yseg(1)))) - weights(6) = ((I_11(xseg(2),yseg(2))-I_11(xseg(1),yseg(1)))) - endif - else - - - slope = (yseg(2)-yseg(1))/(xseg(2)-xseg(1)) - b = yseg(1)-slope*xseg(1) - dx2 = 0.5D0*(xseg(2)-xseg(1)) - if (ldbgr) WRITE(*,*) "dx2 and slope in gauss weight",dx2,slope - xc = 0.5D0*(xseg(1)+xseg(2)) - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_00(x,y) - enddo - weights(1) = integral*dx2 - if (nreconstruction>1) then - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_10(x,y) - enddo - weights(2) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_01(x,y) - enddo - weights(3) = integral*dx2 - endif - if (nreconstruction>3) then - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_20(x,y) - enddo - weights(4) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_02(x,y) - enddo - weights(5) = integral*dx2 - integral = 0.0D0 - do i=1,ngauss - x = xc+abscissae(i)*dx2 - y = slope*x+b - integral = integral+gauss_weights(i)*F_11(x,y) - enddo - weights(6) = integral*dx2 - endif - end if - end subroutine get_weights_gauss - - real (kind=real_kind) function F_00(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_00 =y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_00 - - real (kind=real_kind) function F_10(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_10 =x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_10 - - real (kind=real_kind) function F_01(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_01 =-1.0D0/(SQRT(1.0D0+x*x+y*y)) - end function F_01 - - real (kind=real_kind) function F_20(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_20 =x*x*y/((1.0D0+x*x)*SQRT(1.0D0+x*x+y*y)) - end function F_20 - - real (kind=real_kind) function F_02(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,alpha, tmp - - x = x_in - y = y_in - - alpha = ATAN(x) - tmp=y*COS(alpha) - F_02 =-y/SQRT(1.0D0+x*x+y*y)+log(tmp+sqrt(tmp*tmp+1)) - - ! - ! cos(alpha) = 1/sqrt(1+x*x) - ! - end function F_02 - - real (kind=real_kind) function F_11(x_in,y_in) - implicit none - real (kind=real_kind), intent(in) :: x_in,y_in - real (kind=real_kind) :: x,y,tmp - - x = x_in - y = y_in - - F_11 =-x/(SQRT(1.0D0+x*x+y*y)) - end function F_11 - - subroutine which_eul_cell(x,j_eul,gno) - implicit none - integer (kind=int_kind) , intent(inout) :: j_eul - real (kind=real_kind), dimension(3) , intent(in) :: x - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl -! real (kind=real_kind), intent(in) :: eps - - real (kind=real_kind) :: d1,d2,d3,d1p1 - logical :: lcontinue - integer :: iter - - - ! - ! this is not needed in transport code search - ! -! IF (x(1)gno(nc+2+nhe)) j_eul=nc+1+nhe -! RETURN - -! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added - - lcontinue = .TRUE. - iter = 0 - IF (ldbgr) WRITE(*,*) "from which_eul_cell",x(1),x(2),x(3) - DO WHILE (lcontinue) - iter = iter+1 - IF (x(1).GE.gno(j_eul).AND.x(1).LT.gno(j_eul+1)) THEN - lcontinue = .FALSE. - ! - ! special case when x(1) is on top of grid line - ! - IF (x(1).EQ.gno(j_eul)) THEN -! IF (ABS(x(1)-gno(j_eul))1000.OR.j_eul<-nhe.OR.j_eul>nc+2+nhe) THEN - WRITE(*,*) "search in which_eul_cell not converging!", iter,j_eul - WRITE(*,*) "input", x - WRITE(*,*) "gno", gno(nc),gno(nc+1),gno(nc+2),gno(nc+3) - STOP - END IF - END DO - END subroutine which_eul_cell - - - subroutine truncate_vertex(x,j_eul,gno) - implicit none - integer (kind=int_kind) , intent(inout) :: j_eul - real (kind=real_kind) , intent(inout) :: x - real (kind=real_kind), dimension(-nhe:nc+2+nhe), intent(in) :: gno !phl -! real (kind=real_kind), intent(in) :: eps - - logical :: lcontinue - integer :: iter - real (kind=real_kind) :: xsgn,dist,dist_new,tmp - - ! - ! this is not needed in transport code search - ! -! IF (xgno(nc+2+nhe)) j_eul=nc+1+nhe -! -! RETURN - - - lcontinue = .TRUE. - iter = 0 - dist = bignum -! j_eul = MIN(MAX(j_eul,-nhe),nc+1+nhe) !added - xsgn = INT(SIGN(1.0_dbl_kind,x-gno(j_eul))) - DO WHILE (lcontinue) - iter = iter+1 - tmp = x-gno(j_eul) - dist_new = ABS(tmp) - IF (dist_new>dist) THEN - lcontinue = .FALSE. -! ELSE IF (ABS(tmp)<1.0E-11) THEN - ELSE IF (ABS(tmp)<1.0E-9) THEN -! ELSE IF (ABS(tmp)<1.0E-4) THEN - x = gno(j_eul) - lcontinue = .FALSE. - ELSE - j_eul = j_eul+xsgn - dist = dist_new - END IF - IF (iter>10000) THEN - WRITE(*,*) "truncate vertex not converging" - STOP - END IF - END DO - END subroutine truncate_vertex - - - - -!******************************************************************************** -! -! Gauss-Legendre quadrature -! -! Tabulated values -! -!******************************************************************************** -subroutine gauss_points(n,weights,points) - implicit none - real (kind=real_kind), dimension(n), intent(out) :: weights, points - integer (kind=int_kind) , intent(in ) :: n - - select case (n) -! CASE(1) -! abscissae(1) = 0.0D0 -! weights(1) = 2.0D0 - case(2) - points(1) = -sqrt(1.0D0/3.0D0) - points(2) = sqrt(1.0D0/3.0D0) - weights(1) = 1.0D0 - weights(2) = 1.0D0 - case(3) - points(1) = -0.774596669241483377035853079956D0 - points(2) = 0.0D0 - points(3) = 0.774596669241483377035853079956D0 - weights(1) = 0.555555555555555555555555555556D0 - weights(2) = 0.888888888888888888888888888889D0 - weights(3) = 0.555555555555555555555555555556D0 - case(4) - points(1) = -0.861136311594052575223946488893D0 - points(2) = -0.339981043584856264802665659103D0 - points(3) = 0.339981043584856264802665659103D0 - points(4) = 0.861136311594052575223946488893D0 - weights(1) = 0.347854845137453857373063949222D0 - weights(2) = 0.652145154862546142626936050778D0 - weights(3) = 0.652145154862546142626936050778D0 - weights(4) = 0.347854845137453857373063949222D0 - case(5) - points(1) = -(1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) - points(2) = -(1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) - points(3) = 0.0D0 - points(4) = (1.0D0/3.0D0)*sqrt(5.0D0-2.0D0*sqrt(10.0D0/7.0D0)) - points(5) = (1.0D0/3.0D0)*sqrt(5.0D0+2.0D0*sqrt(10.0D0/7.0D0)) - weights(1) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 - weights(2) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 - weights(3) = 128.0D0/225.0D0 - weights(4) = (322.0D0+13.0D0*sqrt(70.0D0))/900.0D0 - weights(5) = (322.0D0-13.0D0*sqrt(70.0D0))/900.0D0 - case default - write(*,*) 'n out of range in glwp of module gll. n=',n - write(*,*) '0 0.0D0) THEN - signum = 1.0D0 - ELSEIF (x < 0.0D0) THEN - signum = -1.0D0 - ELSE - signum = 0.0D0 - ENDIF - end function - -!------------------------------------------------------------------------------ -! FUNCTION SIGNUM_FUZZY -! -! Description: -! Gives the sign of the given real number, returning zero if x is within -! a small amount from zero. -!------------------------------------------------------------------------------ - function signum_fuzzy(x) - implicit none - - real (kind=real_kind) :: signum_fuzzy - real (kind=real_kind) :: x - - IF (x > fuzzy_width) THEN - signum_fuzzy = 1.0D0 - ELSEIF (x < fuzzy_width) THEN - signum_fuzzy = -1.0D0 - ELSE - signum_fuzzy = 0.0D0 - ENDIF - end function - - function fuzzy(x,epsilon) - implicit none - - integer (kind=int_kind) :: fuzzy - real (kind=real_kind), intent(in) :: epsilon - real (kind=real_kind) :: x - - IF (ABS(x)epsilon) THEN - fuzzy = 1 - ELSE !IF (x < fuzzy_width) THEN - fuzzy = -1 - ENDIF - end function - -! -! see, e.g., http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/ -! -subroutine check_lines_cross(x1,x2,x3,x4,y1,y2,y3,y4,lcross) - implicit none - real (kind=real_kind), INTENT(IN) :: x1,x2,x3,x4,y1,y2,y3,y4 - LOGICAL, INTENT(OUT) :: lcross - ! - ! local workspace - ! - real (kind=real_kind) :: cp,tx,ty - - cp = (y4-y3)*(x2-x1)-(x4-x3)*(y2-y1) - IF (ABS(cp)-tiny.AND.tx<1.0D0+tiny.AND.& - ty>-tiny.AND.ty<1.0D0+tiny) THEN - lcross = .TRUE. - ELSE - lcross = .FALSE. -! WRITE(*,*) "not parallel but not crossing,",tx,ty - ENDIF - ENDIF -end subroutine check_lines_cross - - - REAL (KIND=dbl_kind) FUNCTION I_00(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y - - x = x_in/aa - y = y_in/aa -! x = x_in -! y = y_in - I_00 = ATAN(x*y/SQRT(one+x*x+y*y)) - END FUNCTION I_00 - - REAL (KIND=dbl_kind) FUNCTION I_10(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y,tmp - - x = x_in/aa - y = y_in/aa - tmp = ATAN(x) - I_10 = -ASINH(y*COS(tmp)) - ! - ! = -arcsinh(y/sqrt(1+x^2)) - ! - END FUNCTION I_10 - - REAL (KIND=dbl_kind) FUNCTION I_10_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - I_10_ab = -ASINH(COS(alpha) * TAN(beta)) - END FUNCTION I_10_AB - - REAL (KIND=dbl_kind) FUNCTION I_01(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y!,beta - - x = x_in/aa - y = y_in/aa -! beta = ATAN(y) -! I_01 = -ASINH(x*COS(beta)) - I_01 = -ASINH(x/SQRT(1+y*y)) - END FUNCTION I_01 - - REAL (KIND=dbl_kind) FUNCTION I_01_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - I_01_ab = -ASINH(COS(beta) * TAN(alpha)) - END FUNCTION I_01_AB - - REAL (KIND=dbl_kind) FUNCTION I_20(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta - - x = x_in/aa - y = y_in/aa -! alpha = aa*ATAN(x) -! beta = aa*ATAN(y) - - tmp = one+y*y - -! I_20 = y*ASINH(COS(beta)*x)+ACOS(SIN(alpha)*SIN(beta)) - I_20 = y*ASINH(x/SQRT(tmp))+ACOS(x*y/(SQRT((one+x*x)*tmp))) - END FUNCTION I_20 - - REAL (KIND=dbl_kind) FUNCTION I_20_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_20_ab = TAN(beta)*ASINH(COS(beta)*TAN(alpha))+ACOS(SIN(alpha)*SIN(beta)) - END FUNCTION I_20_AB - - REAL (KIND=dbl_kind) FUNCTION I_02(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y, tmp!,alpha,beta - - x = x_in/aa - y = y_in/aa -! alpha = aa*ATAN(x) -! beta = aa*ATAN(y) - - tmp=one+x*x - - I_02 = x*ASINH(y/SQRT(tmp))+ACOS(x*y/SQRT(tmp*(1+y*y))) - END FUNCTION I_02 - - REAL (KIND=dbl_kind) FUNCTION I_02_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_02_ab = TAN(alpha)*ASINH(TAN(beta)*COS(alpha))+ACOS(SIN(alpha)*SIN(beta)) - END FUNCTION I_02_AB - - - REAL (KIND=dbl_kind) FUNCTION I_11(x_in,y_in) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: x_in,y_in - REAL (KIND=dbl_kind) :: x,y - - x = x_in/aa - y = y_in/aa - - I_11 = -SQRT(1+x*x+y*y) - END FUNCTION I_11 - - REAL (KIND=dbl_kind) FUNCTION I_11_ab(alpha,beta) - IMPLICIT NONE - REAL (KIND=dbl_kind), INTENT(IN) :: alpha,beta - - I_11_ab = -SQRT(one+TAN(alpha)**2+TAN(beta)**2) - END FUNCTION I_11_AB -!------------------------------------------------------------------------------ -! FUNCTION ASINH -! -! Description: -! Hyperbolic arcsin function -!------------------------------------------------------------------------------ - FUNCTION ASINH(x) - IMPLICIT NONE - - REAL (KIND=dbl_kind) :: ASINH - REAL (KIND=dbl_kind) :: x - - ASINH = LOG(x + SQRT(x * x + one)) - END FUNCTION - - - !******************************************************************************** - ! - ! Gauss-Legendre quadrature - ! - ! Tabulated values - ! - !******************************************************************************** - SUBROUTINE glwp(n,weights,abscissae) - IMPLICIT NONE - REAL (KIND=dbl_kind), DIMENSION(n), INTENT(OUT) :: weights, abscissae - INTEGER (KIND=int_kind) , INTENT(IN ) :: n - - SELECT CASE (n) - CASE(1) - abscissae(1) = 0.0 - weights(1) = 2.0 - CASE(2) - abscissae(1) = -SQRT(1.0/3.0) - abscissae(2) = SQRT(1.0/3.0) - weights(1) = 1.0 - weights(2) = 1.0 - CASE(3) - abscissae(1) = -0.774596669241483377035853079956_dbl_kind - abscissae(2) = 0.0 - abscissae(3) = 0.774596669241483377035853079956_dbl_kind - weights(1) = 0.555555555555555555555555555556_dbl_kind - weights(2) = 0.888888888888888888888888888889_dbl_kind - weights(3) = 0.555555555555555555555555555556_dbl_kind - CASE(4) - abscissae(1) = -0.861136311594052575223946488893_dbl_kind - abscissae(2) = -0.339981043584856264802665659103_dbl_kind - abscissae(3) = 0.339981043584856264802665659103_dbl_kind - abscissae(4) = 0.861136311594052575223946488893_dbl_kind - weights(1) = 0.347854845137453857373063949222_dbl_kind - weights(2) = 0.652145154862546142626936050778_dbl_kind - weights(3) = 0.652145154862546142626936050778_dbl_kind - weights(4) = 0.347854845137453857373063949222_dbl_kind - CASE(5) - abscissae(1) = -(1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) - abscissae(2) = -(1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) - abscissae(3) = 0.0 - abscissae(4) = (1.0/3.0)*SQRT(5.0-2.0*SQRT(10.0/7.0)) - abscissae(5) = (1.0/3.0)*SQRT(5.0+2.0*SQRT(10.0/7.0)) - weights(1) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(2) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(3) = 128.0_dbl_kind/225.0_dbl_kind - weights(4) = (322.0_dbl_kind+13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - weights(5) = (322.0_dbl_kind-13.0_dbl_kind*SQRT(70.0_dbl_kind))/900.0_dbl_kind - CASE DEFAULT - WRITE(*,*) 'n out of range in glwp of module gll. n=',n - WRITE(*,*) '0 shr_kind_r8 -contains -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereABPFromRLL -! -! Description: -! Determine the (alpha,beta,panel) coordinate of a point on the sphere from -! a given regular lat lon coordinate. -! -! Parameters: -! lon - Coordinate longitude -! lat - Coordinate latitude -! alpha (OUT) - Alpha coordinate -! beta (OUT) - Beta coordinate -! ipanel (OUT) - Face panel -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereABPFromRLL(lon, lat, alpha, beta, ipanel, ldetermine_panel) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (R8), INTENT(IN) :: lon, lat - REAL (R8), INTENT(OUT) :: alpha, beta - INTEGER :: ipanel - LOGICAL, INTENT(IN) :: ldetermine_panel - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - REAL (r8), PARAMETER :: rotate_cube = 0.0 - - ! Local variables - REAL (R8) :: xx, yy, zz, pm - REAL (R8) :: sx, sy, sz - INTEGER :: ix, iy, iz - - ! Translate to (x,y,z) space - xx = COS(lon-rotate_cube) * COS(lat) - yy = SIN(lon-rotate_cube) * COS(lat) - zz = SIN(lat) - - pm = MAX(ABS(xx), ABS(yy), ABS(zz)) - - ! Check maximality of the x coordinate - IF (pm == ABS(xx)) THEN - IF (xx > 0) THEN; ix = 1; ELSE; ix = -1; ENDIF - ELSE - ix = 0 - ENDIF - - ! Check maximality of the y coordinate - IF (pm == ABS(yy)) THEN - IF (yy > 0) THEN; iy = 1; ELSE; iy = -1; ENDIF - ELSE - iy = 0 - ENDIF - - ! Check maximality of the z coordinate - IF (pm == ABS(zz)) THEN - IF (zz > 0) THEN; iz = 1; ELSE; iz = -1; ENDIF - ELSE - iz = 0 - ENDIF - - ! Panel assignments - IF (ldetermine_panel) THEN - IF (iz == 1) THEN - ipanel = 6; sx = yy; sy = -xx; sz = zz - - ELSEIF (iz == -1) THEN - ipanel = 5; sx = yy; sy = xx; sz = -zz - - ELSEIF ((ix == 1) .AND. (iy /= 1)) THEN - ipanel = 1; sx = yy; sy = zz; sz = xx - - ELSEIF ((ix == -1) .AND. (iy /= -1)) THEN - ipanel = 3; sx = -yy; sy = zz; sz = -xx - - ELSEIF ((iy == 1) .AND. (ix /= -1)) THEN - ipanel = 2; sx = -xx; sy = zz; sz = yy - - ELSEIF ((iy == -1) .AND. (ix /= 1)) THEN - ipanel = 4; sx = xx; sy = zz; sz = -yy - - ELSE - WRITE(*,*) 'Fatal Error: CubedSphereABPFromRLL failed' - WRITE(*,*) '(xx, yy, zz) = (', xx, ',', yy, ',', zz, ')' - WRITE(*,*) 'pm =', pm, ' (ix, iy, iz) = (', ix, ',', iy, ',', iz, ')' - STOP - ENDIF - ELSE - IF (ipanel == 6) THEN - sx = yy; sy = -xx; sz = zz - ELSEIF (ipanel == 5) THEN - sx = yy; sy = xx; sz = -zz - ELSEIF (ipanel == 1) THEN - sx = yy; sy = zz; sz = xx - ELSEIF (ipanel == 3) THEN - sx = -yy; sy = zz; sz = -xx - ELSEIF (ipanel == 2) THEN - sx = -xx; sy = zz; sz = yy - ELSEIF (ipanel == 4) THEN - sx = xx; sy = zz; sz = -yy - ELSE - WRITE(*,*) "ipanel out of range",ipanel - STOP - END IF - END IF - - ! Use panel information to calculate (alpha, beta) coords - alpha = ATAN(sx / sz) - beta = ATAN(sy / sz) - -END SUBROUTINE CubedSphereABPFromRLL - -!------------------------------------------------------------------------------ -! SUBROUTINE EquiangularAllAreas -! -! Description: -! Compute the area of all cubed sphere grid cells, storing the results in -! a two dimensional array. -! -! Parameters: -! icube - Resolution of the cubed sphere -! dA (OUT) - Output array containing the area of all cubed sphere grid cells -!------------------------------------------------------------------------------ -SUBROUTINE EquiangularAllAreas(icube, dA) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - INTEGER, INTENT(IN) :: icube - REAL (r8), DIMENSION(icube,icube), INTENT(OUT) :: dA - - ! Local variables - INTEGER :: k, k1, k2 - REAL (r8) :: a1, a2, a3, a4 - REAL (r8), DIMENSION(icube+1,icube+1) :: ang - REAL (r8), DIMENSION(icube+1) :: gp - - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - - !#ifdef DBG - REAL (r8) :: dbg1 !DBG - !#endif - - ! Recall that we are using equi-angular spherical gridding - ! Compute the angle between equiangular cubed sphere projection grid lines. - DO k = 1, icube+1 - gp(k) = -piq + (pi/DBLE(2*(icube))) * DBLE(k-1) - ENDDO - - DO k2=1,icube+1 - DO k1=1,icube+1 - ang(k1,k2) =ACOS(-SIN(gp(k1)) * SIN(gp(k2))) - ENDDO - ENDDO - - DO k2=1,icube - DO k1=1,icube - a1 = ang(k1 , k2 ) - a2 = pi - ang(k1+1, k2 ) - a3 = pi - ang(k1 , k2+1) - a4 = ang(k1+1, k2+1) - ! area = r*r*(-2*pi+sum(interior angles)) - DA(k1,k2) = -2.0*pi+a1+a2+a3+a4 - ENDDO - ENDDO - - !#ifdef DBG - ! Only for debugging - test consistency - dbg1 = 0.0 !DBG - DO k2=1,icube - DO k1=1,icube - dbg1 = dbg1 + DA(k1,k2) !DBG - ENDDO - ENDDO - write(*,*) 'DAcube consistency: ',dbg1-4.0*pi/6.0 !DBG - !#endif -END SUBROUTINE EquiangularAllAreas - - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereRLLFromABP -! -! Description: -! Determine the lat lon coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! lon (OUT) - Calculated longitude -! lat (OUT) - Calculated latitude -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereRLLFromABP(alpha, beta, ipanel, lon, lat) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: lon, lat - ! Local variables - REAL (r8) :: xx, yy, zz, rotate_cube - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: piq = 0.25*pi - - rotate_cube = 0.0 - ! Convert to cartesian coordinates - CALL CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - ! Convert back to lat lon - lat = ASIN(zz) - if (xx==0.0.and.yy==0.0) THEN - lon = 0.0 - else - lon = ATAN2(yy, xx) +rotate_cube - IF (lon<0.0) lon=lon+2.0*pi - IF (lon>2.0*pi) lon=lon-2.0*pi - end if -END SUBROUTINE CubedSphereRLLFromABP - -!------------------------------------------------------------------------------ -! SUBROUTINE CubedSphereXYZFromABP -! -! Description: -! Determine the Cartesian coordinate of a point on a sphere given its -! (alpha,beta,panel) coordinate. -! -! Parameters: -! alpha - Alpha coordinate -! beta - Beta coordinate -! panel - Cubed sphere panel id -! xx (OUT) - Calculated x coordinate -! yy (OUT) - Calculated y coordinate -! zz (OUT) - Calculated z coordinate -!------------------------------------------------------------------------------ -SUBROUTINE CubedSphereXYZFromABP(alpha, beta, ipanel, xx, yy, zz) - use shr_kind_mod, only: r8 => shr_kind_r8 - IMPLICIT NONE - - REAL (r8), INTENT(IN) :: alpha, beta - INTEGER , INTENT(IN) :: ipanel - REAL (r8), INTENT(OUT) :: xx, yy, zz - ! Local variables - REAL (r8) :: a1, b1, pm - REAL (r8) :: sx, sy, sz - - ! Convert to Cartesian coordinates - a1 = TAN(alpha) - b1 = TAN(beta) - - sz = (1.0 + a1 * a1 + b1 * b1)**(-0.5) - sx = sz * a1 - sy = sz * b1 - ! Panel assignments - IF (ipanel == 6) THEN - yy = sx; xx = -sy; zz = sz - ELSEIF (ipanel == 5) THEN - yy = sx; xx = sy; zz = -sz - ELSEIF (ipanel == 1) THEN - yy = sx; zz = sy; xx = sz - ELSEIF (ipanel == 3) THEN - yy = -sx; zz = sy; xx = -sz - ELSEIF (ipanel == 2) THEN - xx = -sx; zz = sy; yy = sz - ELSEIF (ipanel == 4) THEN - xx = sx; zz = sy; yy = -sz - ELSE - WRITE(*,*) 'Fatal Error: Panel out of range in CubedSphereXYZFromABP' - WRITE(*,*) '(alpha, beta, panel) = (', alpha, ',', beta, ',', ipanel, ')' - STOP - ENDIF -END SUBROUTINE CubedSphereXYZFromABP - - -SUBROUTINE remove_duplicates_integer(n_in,f_in,n_out,f_out) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - integer,dimension(n_in), intent(in) :: f_in - integer, intent(out) :: n_out - integer,dimension(n_in), intent(out) :: f_out - ! - ! local work space - ! - integer :: k,i,j - ! - ! remove duplicates in ipanel_tmp - ! - k = 1 - f_out(1) = f_in(1) - outer: do i=2,n_in - do j=1,k - ! if (f_out(j) == f_in(i)) then - if (ABS(f_out(j)-f_in(i))<1.0E-10) then - ! Found a match so start looking again - cycle outer - end if - end do - ! No match found so add it to the output - k = k + 1 - f_out(k) = f_in(i) - end do outer - n_out = k -END SUBROUTINE remove_duplicates_integer - -SUBROUTINE remove_duplicates_latlon(n_in,lon_in,lat_in,n_out,lon_out,lat_out,tiny,ldbg) - use shr_kind_mod, only: r8 => shr_kind_r8 - integer, intent(in) :: n_in - real(r8),dimension(n_in), intent(inout) :: lon_in,lat_in - real, intent(in) :: tiny - integer, intent(out) :: n_out - real(r8),dimension(n_in), intent(out) :: lon_out,lat_out - logical :: ldbg - ! - ! local work space - ! - integer :: k,i,j - REAL (r8), PARAMETER :: pi = 3.14159265358979323846264338327 - REAL (r8), PARAMETER :: pih = 0.50*pi - ! - ! for pole points: make sure the longitudes are identical so that algorithm below works properly - ! - do i=2,n_in - if (abs(lat_in(i)-pih) Date: Fri, 8 Nov 2024 22:14:22 -0800 Subject: [PATCH 06/19] Modified code to add dev suite and better format 1.Separate the orographic drag (OD) schemes from gw_common.F90 to form a new od_common.F90 to have OD related schemes. 2.Modify the namelist names to all use OD as starting for OD-related options and schemes. 3.Added a new OD development suite for testing of the OD schemes in the model. 4.Made easier to read format coding throught the codes. [BFB] --- cime_config/tests.py | 14 ++- components/eam/bld/build-namelist | 4 +- .../namelist_files/namelist_defaults_eam.xml | 12 +-- .../eam/orodrag_ne30pg2/user_nl_eam | 8 ++ .../{orodrag => orodrag_ne4pg2}/user_nl_eam | 1 + components/eam/src/physics/cam/clubb_intr.F90 | 89 +++++++++---------- components/eam/src/physics/cam/gw_drag.F90 | 42 ++++----- components/eam/src/physics/cam/od_common.F90 | 47 +++++----- .../eam/src/physics/cam/phys_control.F90 | 6 +- 9 files changed, 113 insertions(+), 110 deletions(-) create mode 100644 components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne30pg2/user_nl_eam rename components/eam/cime_config/testdefs/testmods_dirs/eam/{orodrag => orodrag_ne4pg2}/user_nl_eam (50%) diff --git a/cime_config/tests.py b/cime_config/tests.py index e2ab71f0c53f..0c1930292c6e 100644 --- a/cime_config/tests.py +++ b/cime_config/tests.py @@ -191,14 +191,12 @@ "e3sm_orodrag_developer" : { "tests" : ( - "ERP.ne4pg2_oQU480.F2010.eam-orodrag", - "REP_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", - "PET.ne4pg2_oQU480.F2010.eam-orodrag", - "PEM_Ln18.ne4pg2_oQU480.F2010.eam-orodrag", - "SMS_Ln5.ne30pg2_EC30to60E2r2.F2010.eam-orodrag", - "SMS_D_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", - "SMS_Ln5.ne4pg2_oQU480.F2010.eam-orodrag", - "ERS.ne4pg2_oQU480.F2010.eam-orodrag" + "ERP.ne4pg2_oQU480.F2010.eam-orodrag_ne4pg2", + "REP_Ln5.ne4pg2_oQU480.F2010.eam-orodrag_ne4pg2", + "PET.ne4pg2_oQU480.F2010.eam-orodrag_ne4pg2", + "PEM_Ln18.ne4pg2_oQU480.F2010.eam-orodrag_ne4pg2", + "SMS_Ln5.ne30pg2_EC30to60E2r2.F2010.eam-orodrag_ne30pg2", + "SMS_D_Ln5.ne4pg2_oQU480.F2010.eam-orodrag_ne4pg2" ) }, diff --git a/components/eam/bld/build-namelist b/components/eam/bld/build-namelist index 293a03cdf3a4..f967ba88c5cf 100755 --- a/components/eam/bld/build-namelist +++ b/components/eam/bld/build-namelist @@ -4104,8 +4104,8 @@ if ($waccm_phys or $cfg->get('nlev') >= 60) { } add_default($nl, 'pgwv', 'val'=>'32'); add_default($nl, 'gw_dc','val'=>'2.5D0'); -add_default($nl, 'od_ls_ncleff ','val'=>'3.D0'); -add_default($nl, 'od_bl_ncd ','val'=>'3.D0'); +add_default($nl, 'od_ls_ncleff' ,'val'=>'3.D0'); +add_default($nl, 'od_bl_ncd' ,'val'=>'3.D0'); add_default($nl, 'od_ss_sncleff','val'=>'1.D0'); if ($nl->get_value('use_gw_oro') =~ /$TRUE/io) { diff --git a/components/eam/bld/namelist_files/namelist_defaults_eam.xml b/components/eam/bld/namelist_files/namelist_defaults_eam.xml index 4ad34edf4ea1..2fb78fcf8a6a 100755 --- a/components/eam/bld/namelist_files/namelist_defaults_eam.xml +++ b/components/eam/bld/namelist_files/namelist_defaults_eam.xml @@ -126,13 +126,13 @@ atm/cam/topo/USGS-gtopo30_64x128_c050520.nc -atm/cam/topo/USGS-gtopo30_ne4np4_16x_forOroDrag.c20241019.nc -atm/cam/topo/USGS-gtopo30_ne4np4pg2_16x_converted_forOroDrag.c20241019.nc +atm/cam/topo/USGS-gtopo30_ne4np4_16x.c20160612.nc +atm/cam/topo/USGS-gtopo30_ne4np4pg2_16x_converted.c20200527.nc atm/cam/topo/USGS-gtopo30_ne11np4_16xconsistentSGH.c20160612.nc atm/cam/topo/USGS-gtopo30_ne16np4_16xconsistentSGH.c20160612.nc atm/cam/topo/USGS-gtopo30_ne16np4pg2_16xdel2_20200527.nc atm/cam/topo/USGS-gtopo30_ne30np4_16xdel2-PFC-consistentSGH.nc -atm/cam/topo/USGS-gtopo30_ne30np4pg2_x6t-SGH_forOroDrag.c20241001.nc +atm/cam/topo/USGS-gtopo30_ne30np4pg2_x6t-SGH.c20210614.nc atm/cam/topo/USGS-gtopo30_ne30np4pg3_16xdel2.c20200504.nc atm/cam/topo/USGS-gtopo30_ne30np4pg4_16xdel2.c20200504.nc atm/cam/topo/USGS-gtopo30_ne45np4pg2_16xdel2.c20200615.nc @@ -1883,9 +1883,9 @@ with se_tstep, dt_remap_factor, dt_tracer_factor set to -1 1.0 0.375 .true. - 3 - 3 - 1 + 3.D0 + 3.D0 + 1.D0 2.5D0 268.15D0 13.8D0 diff --git a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne30pg2/user_nl_eam b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne30pg2/user_nl_eam new file mode 100644 index 000000000000..8ab37d279783 --- /dev/null +++ b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne30pg2/user_nl_eam @@ -0,0 +1,8 @@ +use_gw_oro=.false. +use_od_ls=.true. +use_od_bl=.true. +use_od_ss=.true. +use_od_fd=.true. + + +bnd_topo='$DIN_LOC_ROOT/atm/cam/topo/USGS-gtopo30_ne30np4pg2_x6t-SGH_forOroDrag.c20241001.nc' diff --git a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam similarity index 50% rename from components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam rename to components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam index e14e93f8374c..185a235d4f58 100644 --- a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag/user_nl_eam +++ b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam @@ -4,3 +4,4 @@ use_od_bl=.true. use_od_ss=.true. use_od_fd=.true. +bnd_topo='$DIN_LOC_ROOT/atm/cam/topo/USGS-gtopo30_ne4np4_16x_forOroDrag.c20241019.nc' diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index e44c3ab7fea0..6b7fb38906ad 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -930,7 +930,7 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call addfld ('TPERTBLT', horiz_only, 'A', 'K', 'perturbation temperature at PBL top') ! if (use_od_fd) then - !!added for TOFD output + !added for turbulent orographic form drag (TOFD) output call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') call addfld ('DUSFC_FD',horiz_only,'A','N/m2','fd zonal oro surface stress') @@ -1176,7 +1176,7 @@ subroutine clubb_tend_cam( & use model_flags, only: ipdf_call_placement use advance_clubb_core_module, only: ipdf_post_advance_fields #endif - use gw_common, only: grid_size,gw_oro_interface + use od_common, only: grid_size, oro_drag_interface use hycoef, only: etamid use physconst, only: rh2o,pi,rearth,r_universal implicit none @@ -1993,28 +1993,28 @@ subroutine clubb_tend_cam( & endif ! if (use_od_fd) then - gwd_ls=.false. - gwd_bl=.false. - gwd_ss=.false. - gwd_fd=use_od_fd - dummy_nm=0.0_r8 + gwd_ls =.false. + gwd_bl =.false. + gwd_ss =.false. + gwd_fd =use_od_fd + dummy_nm =0.0_r8 dummy_utgw=0.0_r8 dummy_vtgw=0.0_r8 dummy_ttgw=0.0_r8 - !sgh30 as the input for TOFD instead of sgh - call gw_oro_interface(state,cam_in,sgh30,pbuf,hdtime,dummy_nm,& - gwd_ls,gwd_bl,gwd_ss,gwd_fd,& - od_ls_ncleff,od_bl_ncd,od_ss_sncleff,& - dummy_utgw,dummy_vtgw,dummy_ttgw,& - dtaux3_ls=dummx3_ls,dtauy3_ls=dummy3_ls,& - dtaux3_bl=dummx3_bl,dtauy3_bl=dummy3_bl,& - dtaux3_ss=dummx3_ss,dtauy3_ss=dummy3_ss,& - dtaux3_fd=dtaux3_fd,dtauy3_fd=dtauy3_fd,& - dusfc_ls=dummx_ls,dvsfc_ls=dummy_ls,& - dusfc_bl=dummx_bl,dvsfc_bl=dummy_bl,& - dusfc_ss=dummx_ss,dvsfc_ss=dummy_ss,& - dusfc_fd=dusfc_fd,dvsfc_fd=dvsfc_fd) - ! + !sgh30 as the input for turbulent orographic form drag (TOFD) instead of sgh + call oro_drag_interface(state,cam_in,sgh30,pbuf,hdtime,dummy_nm,& + gwd_ls,gwd_bl,gwd_ss,gwd_fd,& + od_ls_ncleff,od_bl_ncd,od_ss_sncleff,& + dummy_utgw,dummy_vtgw,dummy_ttgw,& + dtaux3_ls=dummx3_ls,dtauy3_ls=dummy3_ls,& + dtaux3_bl=dummx3_bl,dtauy3_bl=dummy3_bl,& + dtaux3_ss=dummx3_ss,dtauy3_ss=dummy3_ss,& + dtaux3_fd=dtaux3_fd,dtauy3_fd=dtauy3_fd,& + dusfc_ls=dummx_ls,dvsfc_ls=dummy_ls,& + dusfc_bl=dummx_bl,dvsfc_bl=dummy_bl,& + dusfc_ss=dummx_ss,dvsfc_ss=dummy_ss,& + dusfc_fd=dusfc_fd,dvsfc_fd=dvsfc_fd) + call outfld ('DTAUX3_FD', dtaux3_fd, pcols, lchnk) call outfld ('DTAUY3_FD', dtauy3_fd, pcols, lchnk) call outfld ('DUSFC_FD', dusfc_fd, pcols, lchnk) @@ -3269,38 +3269,37 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) enddo if (use_od_ss) then - !add calculation of bulk richardson number here - ! - !compute the whole level th and thv for diagnose of bulk richardson number - thv_lv=0.0_r8 - th_lv=0.0_r8 + !add calculation of bulk richardson number here + !compute the whole level th and thv for diagnose of bulk richardson number + thv_lv=0.0_r8 + th_lv =0.0_r8 - !use the same virtual potential temperature formula as above (thv) except for all vertical levels - !used for bulk richardson number below in pblintd_ri - do i=1,ncol - do k=1,pver - th_lv(i,k) = state%t(i,k)*state%exner(i,k) - if (use_sgv) then - thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq) & - - state%q(i,k,ixcldliq)) - else - thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq)) - end if + !use the same virtual potential temperature formula as above (thv) except for all vertical levels + !used for bulk richardson number below in pblintd_ri + do i=1,ncol + do k=1,pver + th_lv(i,k) = state%t(i,k)*state%exner(i,k) + if (use_sgv) then + thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq) & + - state%q(i,k,ixcldliq)) + else + thv_lv(i,k) = th_lv(i,k)*(1.0_r8+zvir*state%q(i,k,ixq)) + end if + enddo enddo - enddo - !recalculate the kbfs stored in kbfs_pcol for bulk richardson number in pblintd_ri - kbfs_pcol=0.0_r8 - do i=1,ncol + !recalculate the kbfs stored in kbfs_pcol for bulk richardson number in pblintd_ri + kbfs_pcol=0.0_r8 + do i=1,ncol call calc_ustar( state%t(i,pver), state%pmid(i,pver), cam_in%wsx(i), cam_in%wsy(i), rrho, ustar(i) ) call calc_obklen( th(i), thv(i), cam_in%cflx(i,1), cam_in%shf(i), rrho, ustar(i), & kinheat, kinwat, kbfs, obklen(i) ) kbfs_pcol(i)=kbfs - enddo + enddo - !calculate the bulk richardson number - call pblintd_ri(ncol, gravit, thv_lv, state%zm, state%u, state%v, & - ustar, obklen, kbfs_pcol, state%ribulk) + !calculate the bulk richardson number + call pblintd_ri(ncol, gravit, thv_lv, state%zm, state%u, state%v, & + ustar, obklen, kbfs_pcol, state%ribulk) endif return diff --git a/components/eam/src/physics/cam/gw_drag.F90 b/components/eam/src/physics/cam/gw_drag.F90 index d0f26a3245c3..352858905ba9 100644 --- a/components/eam/src/physics/cam/gw_drag.F90 +++ b/components/eam/src/physics/cam/gw_drag.F90 @@ -303,30 +303,30 @@ subroutine gw_init() character*11 :: subname='gw_init' ! subroutine name integer :: grid_id pblh_idx = pbuf_get_index('pblh') - ! grid_id = cam_grid_id('physgrid') - ! + if (use_od_ls.or.use_od_bl) then - if (.not. cam_grid_check(grid_id)) then - call endrun(trim(subname)//': Internal error, no "physgrid" grid') - end if - call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - ! - call initialize_comsrf_OD() - call setup_initial_OD() - ncid_topo_OD=>topo_OD_file_get_id() - call infld('OC', ncid_topo_OD, dim1name, dim2name, 1, pcols, begchunk, & - endchunk, oc , found, gridname='physgrid') - !keep the same interval of OA,OL - call infld('OA', ncid_topo_OD,dim1name, 'nvar_dirOA', dim2name, 1, pcols, 1, nvar_dirOA, begchunk, & - endchunk, oadir(:,:,:), found, gridname='physgrid') - call infld('OL', ncid_topo_OD,dim1name, 'nvar_dirOL', dim2name, 1, pcols, 1, nvar_dirOL, begchunk, & - endchunk, ol , found, gridname='physgrid') - if(.not. found) call endrun('ERROR: OD topo file readerr') - ! - call close_initial_file_OD() + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + call initialize_comsrf_OD() + call setup_initial_OD() + + ncid_topo_OD=>topo_OD_file_get_id() + call infld('OC', ncid_topo_OD, dim1name, dim2name, 1, pcols, begchunk, & + endchunk, oc , found, gridname='physgrid') + !keep the same interval of OA,OL + call infld('OA', ncid_topo_OD,dim1name, 'nvar_dirOA', dim2name, 1, pcols, 1, nvar_dirOA, begchunk, & + endchunk, oadir(:,:,:), found, gridname='physgrid') + call infld('OL', ncid_topo_OD,dim1name, 'nvar_dirOL', dim2name, 1, pcols, 1, nvar_dirOL, begchunk, & + endchunk, ol , found, gridname='physgrid') + if(.not. found) call endrun('ERROR: OD topo file readerr') + call close_initial_file_OD() + endif - ! + ! Set model flags. do_spectral_waves = (pgwv > 0 .and. (use_gw_front .or. use_gw_convect)) orographic_only = (use_gw_oro .and. .not. do_spectral_waves) diff --git a/components/eam/src/physics/cam/od_common.F90 b/components/eam/src/physics/cam/od_common.F90 index d548e32b3790..3eb81889e95a 100644 --- a/components/eam/src/physics/cam/od_common.F90 +++ b/components/eam/src/physics/cam/od_common.F90 @@ -1,5 +1,4 @@ module od_common - ! ! This module contains code common to different orographic drag ! parameterizations. @@ -10,7 +9,7 @@ module od_common ! turbulent orographic form drag (Beljaars et al.,2004). ! use gw_utils, only: r8 -use ppgrid, only: nvar_dirOA,nvar_dirOL +use ppgrid, only: pver,nvar_dirOA,nvar_dirOL use cam_logfile, only: iulog implicit none @@ -25,14 +24,14 @@ module od_common !========================================================================== -subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm,& - gwd_ls, gwd_bl, gwd_ss, gwd_fd, & - od_ls_ncleff, od_bl_ncd,od_ss_sncleff,& - utgw, vtgw, ttgw, & - dtaux3_ls,dtauy3_ls,dtaux3_bl,dtauy3_bl, & - dtaux3_ss,dtauy3_ss,dtaux3_fd,dtauy3_fd, & - dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl, & - dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) +subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, & + gwd_ls, gwd_bl, gwd_ss, gwd_fd, & + od_ls_ncleff, od_bl_ncd,od_ss_sncleff, & + utgw, vtgw, ttgw, & + dtaux3_ls,dtauy3_ls,dtaux3_bl,dtauy3_bl, & + dtaux3_ss,dtauy3_ss,dtaux3_fd,dtauy3_fd, & + dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl, & + dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index use camsrfexch, only: cam_in_t @@ -76,12 +75,12 @@ subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, real(r8), intent(out), optional :: dvsfc_ss(pcols) real(r8), intent(out), optional :: dusfc_fd(pcols) real(r8), intent(out), optional :: dvsfc_fd(pcols) - ! + real(r8) :: ztop(pcols,pver) ! top interface height asl (m) real(r8) :: zbot(pcols,pver) ! bottom interface height asl (m) real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) real(r8) :: dz(pcols,pver) ! model layer height - ! + !real(r8) :: g !pblh input integer :: pblh_idx = 0 @@ -215,30 +214,30 @@ subroutine dxygrid(dx,dy,theta_in,dxy) theta1=MOD(theta_in,360._r8) !set negative axis into 0~360 if (theta1.ge.-360._r8.and.theta1.lt.0._r8) then - theta1=theta1+360._r8 + theta1=theta1+360._r8 endif !in case the angle is not into the judgement theta=theta1 !transform of angle into first quadrant if (theta1.ge. 0._r8.and.theta1.lt. 90._r8) then - theta=theta1 + theta=theta1 else if (theta1.gt. 90._r8.and.theta1.lt.180._r8) then - theta=(180._r8-theta1) + theta=(180._r8-theta1) else if (theta1.gt.180._r8.and.theta1.lt.270._r8) then - theta=(theta1-180._r8) + theta=(theta1-180._r8) else if (theta1.gt.270._r8.and.theta1.lt.360._r8) then - theta=(360._r8-theta1) + theta=(360._r8-theta1) else if (theta1.eq.90._r8.or.theta1.eq.270._r8) then - theta=90._r8 + theta=90._r8 else if (theta1.eq.0._r8.or.theta1.eq.180._r8) then - theta=0._r8 + theta=0._r8 endif !get dxy if (theta.ge. 0._r8.and.theta.lt.atan2(dy,dx)/rad) then - dxy=dx/cos(theta*rad) + dxy=dx/cos(theta*rad) else if (theta.ge.atan2(dy,dx)/rad.and.theta.le.90._r8)then - dxy=dy/sin(theta*rad) + dxy=dy/sin(theta*rad) endif end subroutine dxygrid @@ -681,9 +680,8 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & real(r8),parameter :: odmin = 0.1_r8 real(r8),parameter :: odmax = 10._r8 real(r8),parameter :: erad = 6371.315e+3_r8 - ! - ! local variables - ! + + !local variables integer :: i,j,k,lcap,lcapp1,nwd,idir integer :: klcap,kp1,ikount,kk,nwd1!added nwd1 real(r8) :: rcs,rclcs,csg,fdir,cleff,cs,rcsks @@ -1220,7 +1218,6 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper vtendform(i,k)=-0.0759_r8*wsp*v1(i,k)* & EXP(-(za(i,k)/1500._r8)**1.5_r8)*a2*za(i,k)**(-1.2_r8)*ss_taper - ! enddo endif enddo diff --git a/components/eam/src/physics/cam/phys_control.F90 b/components/eam/src/physics/cam/phys_control.F90 index b82ad13ef288..1ac5d841dc45 100644 --- a/components/eam/src/physics/cam/phys_control.F90 +++ b/components/eam/src/physics/cam/phys_control.F90 @@ -184,7 +184,7 @@ module phys_control logical, public, protected :: use_od_fd = .false. real(r8),public, protected :: od_ls_ncleff = 3._r8 !tunable parameter for oGWD real(r8),public, protected :: od_bl_ncd = 3._r8 !tunable parameter for FBD -real(r8),public, protected :: od_ss_od_ss_sncleff = 1._r8 !tunable parameter for sGWD +real(r8),public, protected :: od_ss_sncleff = 1._r8 !tunable parameter for sGWD ! ! Switches that turn on/off individual parameterizations. ! @@ -383,9 +383,9 @@ subroutine phys_ctl_readnl(nlfile) call mpibcast(use_od_bl, 1 , mpilog, 0, mpicom) call mpibcast(use_od_ss, 1 , mpilog, 0, mpicom) call mpibcast(use_od_fd, 1 , mpilog, 0, mpicom) - call mpibcast(od_ls_ncleff 1 , mpilog, 0, mpicom) + call mpibcast(od_ls_ncleff, 1 , mpilog, 0, mpicom) call mpibcast(od_bl_ncd, 1 , mpilog, 0, mpicom) - call mpibcast(od_ss_sncleff 1 , mpilog, 0, mpicom) + call mpibcast(od_ss_sncleff, 1 , mpilog, 0, mpicom) call mpibcast(fix_g1_err_ndrop, 1 , mpilog, 0, mpicom) call mpibcast(ssalt_tuning, 1 , mpilog, 0, mpicom) call mpibcast(resus_fix, 1 , mpilog, 0, mpicom) From 5a108653afa1cced8ed3796362e3233b74b3c94e Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Wed, 13 Nov 2024 09:10:45 -0700 Subject: [PATCH 07/19] Update clubb_intr.F90 --- components/eam/src/physics/cam/clubb_intr.F90 | 42 +++++++++---------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index 6b7fb38906ad..c69d76def44d 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -930,24 +930,22 @@ subroutine clubb_ini_cam(pbuf2d, dp1_in) call addfld ('TPERTBLT', horiz_only, 'A', 'K', 'perturbation temperature at PBL top') ! if (use_od_fd) then - !added for turbulent orographic form drag (TOFD) output - call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') - call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') - call addfld ('DUSFC_FD',horiz_only,'A','N/m2','fd zonal oro surface stress') - call addfld ('DVSFC_FD',horiz_only,'A','N/m2','fd merio oro surface stress') - call add_default('DTAUX3_FD', 1, ' ') - call add_default('DTAUY3_FD', 1, ' ') - call add_default('DUSFC_FD', 1, ' ') - call add_default('DVSFC_FD', 1, ' ') - if (masterproc) then + !added for turbulent orographic form drag (TOFD) output + call addfld ('DTAUX3_FD',(/'lev'/),'A','m/s2','U tendency - fd orographic drag') + call addfld ('DTAUY3_FD',(/'lev'/),'A','m/s2','V tendency - fd orographic drag') + call addfld ('DUSFC_FD',horiz_only,'A','N/m2','fd zonal oro surface stress') + call addfld ('DVSFC_FD',horiz_only,'A','N/m2','fd merio oro surface stress') + call add_default('DTAUX3_FD', 1, ' ') + call add_default('DTAUY3_FD', 1, ' ') + call add_default('DUSFC_FD', 1, ' ') + call add_default('DVSFC_FD', 1, ' ') + if (masterproc) then write(iulog,*)'Using turbulent orographic form drag scheme (TOFD)' - end if - ! - if (use_od_fd.and.do_tms) then - call endrun("clubb_intr: Both TMS and TOFD are turned on, please turn one off& - &by setting use_od_fd or do_tms as .false.") - end if - ! + end if + if (use_od_fd.and.do_tms) then + call endrun("clubb_intr: Both TMS and TOFD are turned on, please turn one off& + &by setting use_od_fd or do_tms as .false.") + end if end if ! Initialize statistics, below are dummy variables dum1 = 300._r8 @@ -1541,7 +1539,8 @@ subroutine clubb_tend_cam( & real(r8) :: sfc_v_diff_tau(pcols) ! Response to tau perturbation, m/s real(r8), parameter :: pert_tau = 0.1_r8 ! tau perturbation, Pa - !add par for tofd + + !variables for turbulent orographic form drag (TOFD) interface real(r8) :: dtaux3_fd(pcols,pver) real(r8) :: dtauy3_fd(pcols,pver) real(r8) :: dusfc_fd(pcols) @@ -1551,7 +1550,6 @@ subroutine clubb_tend_cam( & real(r8) :: dummy_utgw(pcols,pver) real(r8) :: dummy_vtgw(pcols,pver) real(r8) :: dummy_ttgw(pcols,pver) - ! real(r8) :: dummx_ls(pcols,pver) real(r8) :: dummx_bl(pcols,pver) real(r8) :: dummx_ss(pcols,pver) @@ -1564,7 +1562,7 @@ subroutine clubb_tend_cam( & real(r8) :: dummy3_ls(pcols,pver) real(r8) :: dummy3_bl(pcols,pver) real(r8) :: dummy3_ss(pcols,pver) - ! + real(r8) :: inv_exner_clubb_surf @@ -1991,7 +1989,7 @@ subroutine clubb_tend_cam( & tautmsx, tautmsy, cam_in%landfrac ) call t_stopf('compute_tms') endif - ! + if (use_od_fd) then gwd_ls =.false. gwd_bl =.false. @@ -2020,7 +2018,7 @@ subroutine clubb_tend_cam( & call outfld ('DUSFC_FD', dusfc_fd, pcols, lchnk) call outfld ('DVSFC_FD', dvsfc_fd, pcols, lchnk) endif - ! + if (micro_do_icesupersat) then call physics_ptend_init(ptend_loc,state%psetcols, 'clubb_ice3', ls=.true., lu=.true., lv=.true., lq=lq) endif From 67a0dc2f59223123ebcd3a2a2c94c4089846fd15 Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Fri, 15 Nov 2024 10:47:37 -0600 Subject: [PATCH 08/19] fix topo file for ne4 oro drag testmod --- .../testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam index 185a235d4f58..f32cc8a6f936 100644 --- a/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam +++ b/components/eam/cime_config/testdefs/testmods_dirs/eam/orodrag_ne4pg2/user_nl_eam @@ -4,4 +4,4 @@ use_od_bl=.true. use_od_ss=.true. use_od_fd=.true. -bnd_topo='$DIN_LOC_ROOT/atm/cam/topo/USGS-gtopo30_ne4np4_16x_forOroDrag.c20241019.nc' +bnd_topo='$DIN_LOC_ROOT/atm/cam/topo/USGS-gtopo30_ne4np4pg2_16x_converted_forOroDrag.c20241019.nc' From dcd650c031fb2a5d0859d10663d590dae4ca1a5f Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Fri, 15 Nov 2024 10:51:23 -0600 Subject: [PATCH 09/19] cosmetic fix --- components/eam/src/physics/cam/hb_diff.F90 | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/components/eam/src/physics/cam/hb_diff.F90 b/components/eam/src/physics/cam/hb_diff.F90 index 7721cdef4a0b..3d18ce50280d 100644 --- a/components/eam/src/physics/cam/hb_diff.F90 +++ b/components/eam/src/physics/cam/hb_diff.F90 @@ -770,9 +770,7 @@ end subroutine austausch_pbl subroutine pblintd_ri(ncol ,gravit , & thv ,z ,u ,v , & ustar ,obklen ,kbfs ,rino_bulk) - !! use pbl_utils, only: virtem, calc_ustar, calc_obklen - !! integer, intent(in) :: ncol ! number of atmospheric columns real(r8), intent(in) :: gravit real(r8), intent(in) :: thv(pcols,pver) ! virtual temperature @@ -782,14 +780,14 @@ subroutine pblintd_ri(ncol ,gravit , & real(r8), intent(in) :: ustar(pcols) ! surface friction velocity [m/s] real(r8), intent(in) :: obklen(pcols) ! Obukhov length real(r8), intent(in) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] - !! + ! ! Output arguments ! real(r8) :: wstar(pcols) ! convective sclae velocity [m/s] real(r8) :: pblh(pcols) ! boundary-layer height [m] real(r8) :: bge(pcols) ! buoyancy gradient enhancment real(r8), intent(out) :: rino_bulk(pcols) ! bulk Richardson no. surface level - !! + ! !---------------------------Local parameters---------------------------- ! real(r8), parameter :: tiny = 1.e-36_r8 ! lower bound for wind magnitude @@ -811,12 +809,11 @@ subroutine pblintd_ri(ncol ,gravit , & do i=1,ncol check(i) = .true. rino(i,pver) = 0.0_r8 - rino_bulk(i) = 0.0_r8 + rino_bulk(i) = 0.0_r8 pblh(i) = z(i,pver) tref(i) = thv(i,pver)!if not excess then tref is equal to lowest level thv_lv end do ! - ! ! PBL height calculation: Scan upward until the Richardson number between ! the first level and the current level exceeds the "critical" value. ! @@ -845,9 +842,7 @@ subroutine pblintd_ri(ncol ,gravit , & phiminv(i) = (1._r8 - binm*pblh(i)/obklen(i))**onet rino(i,pver) = 0.0_r8 tlv(i) = thv(i,pver) + kbfs(i)*fak/( ustar(i)*phiminv(i) ) - ! tref(i) = tlv(i) - ! end if end do ! @@ -879,13 +874,13 @@ subroutine pblintd_ri(ncol ,gravit , & !following Holstag and Boville (1993) equation (2.8) ! do i=1,ncol - vvk = u(i,pver)**2 + v(i,pver)**2 + fac*ustar(i)**2 - vvk = max(vvk,tiny) - rino_bulk(i)=gravit*(thv(i,pver) - tref(i))*z(i,pver)/(thv(i,pver)*vvk) + vvk = u(i,pver)**2 + v(i,pver)**2 + fac*ustar(i)**2 + vvk = max(vvk,tiny) + rino_bulk(i)=gravit*(thv(i,pver) - tref(i))*z(i,pver)/(thv(i,pver)*vvk) enddo ! return - end subroutine pblintd_ri - !=============================================================================== + end subroutine pblintd_ri + !=============================================================================== end module hb_diff From 26b037f52546daf745fa1261fb53e80e6ad9006b Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Fri, 15 Nov 2024 10:56:37 -0600 Subject: [PATCH 10/19] refactor data handling for oro drag put data in pbuf rather than state and isolate orodrag register/init methods in od_common --- .../eam/src/control/startup_initialconds.F90 | 43 - components/eam/src/physics/cam/clubb_intr.F90 | 29 +- components/eam/src/physics/cam/comsrf.F90 | 32 +- components/eam/src/physics/cam/gw_drag.F90 | 85 +- components/eam/src/physics/cam/od_common.F90 | 1213 +++++++++-------- .../eam/src/physics/cam/physics_types.F90 | 28 +- components/eam/src/physics/cam/physpkg.F90 | 19 +- components/eam/src/physics/cam/ppgrid.F90 | 8 - 8 files changed, 732 insertions(+), 725 deletions(-) diff --git a/components/eam/src/control/startup_initialconds.F90 b/components/eam/src/control/startup_initialconds.F90 index a68195c731db..68f9a2f12a3b 100644 --- a/components/eam/src/control/startup_initialconds.F90 +++ b/components/eam/src/control/startup_initialconds.F90 @@ -5,28 +5,16 @@ module startup_initialconds ! !----------------------------------------------------------------------- -use pio, only: file_desc_t - implicit none private save public :: initial_conds ! Read in initial conditions (dycore dependent) -!added for orographic drag -public topo_OD_file_get_id -public setup_initial_OD -public close_initial_file_OD -type(file_desc_t), pointer :: ncid_topo_OD !======================================================================= contains !======================================================================= -function topo_OD_file_get_id() - type(file_desc_t), pointer :: topo_OD_file_get_id - topo_OD_file_get_id => ncid_topo_OD -end function topo_OD_file_get_id - subroutine initial_conds(dyn_in) ! This routine does some initializing of buffers that should move to a @@ -72,35 +60,4 @@ subroutine initial_conds(dyn_in) end subroutine initial_conds -!======================================================================= - -subroutine setup_initial_OD() - use filenames, only: bnd_topo - use ioFileMod, only: getfil - use cam_pio_utils, only: cam_pio_openfile - use pio, only: pio_nowrite -! -! Input arguments -! -!----------------------------------------------------------------------- - include 'netcdf.inc' -!----------------------------------------------------------------------- - character(len=256) :: bnd_topo_loc ! filepath of topo file on local disk - allocate(ncid_topo_OD) - call getfil(bnd_topo, bnd_topo_loc) - call cam_pio_openfile(ncid_topo_OD, bnd_topo_loc, PIO_NOWRITE) -end subroutine setup_initial_OD - -subroutine close_initial_file_OD - use pio, only: pio_closefile - call pio_closefile(ncid_topo_OD) - deallocate(ncid_topo_OD) - nullify(ncid_topo_OD) -end subroutine close_initial_file_OD -!======================================================================= - - - - - end module startup_initialconds diff --git a/components/eam/src/physics/cam/clubb_intr.F90 b/components/eam/src/physics/cam/clubb_intr.F90 index c69d76def44d..0d45232f8a98 100644 --- a/components/eam/src/physics/cam/clubb_intr.F90 +++ b/components/eam/src/physics/cam/clubb_intr.F90 @@ -2139,14 +2139,14 @@ subroutine clubb_tend_cam( & dum_core_rknd = real((ksrftms(i)*state1%v(i,pver)), kind = core_rknd) vpwp_sfc = vpwp_sfc-(dum_core_rknd/rho_ds_zm(1)) endif - !----------------------------------------------------! - !Apply TOFD - !----------------------------------------------------! - !tendency is flipped already - if (use_od_fd) then + ! ------------------------------------------------- ! + ! Apply TOFD + ! ------------------------------------------------- ! + ! tendency is flipped already + if (use_od_fd) then um_forcing(2:pverp)=dtaux3_fd(i,pver:1:-1) vm_forcing(2:pverp)=dtauy3_fd(i,pver:1:-1) - endif + endif ! Need to flip arrays around for CLUBB core do k=1,pverp um_in(k) = real(um(i,pverp-k+1), kind = core_rknd) @@ -3170,7 +3170,7 @@ end subroutine clubb_tend_cam ! ! ! =============================================================================== ! - subroutine clubb_surface (state, cam_in, ustar, obklen) + subroutine clubb_surface (state, cam_in, pbuf, ustar, obklen) !------------------------------------------------------------------------------- ! Description: Provide the obukhov length and the surface friction velocity @@ -3192,7 +3192,7 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) use constituents, only: cnst_get_ind use camsrfexch, only: cam_in_t use hb_diff, only: pblintd_ri - + use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc implicit none @@ -3200,8 +3200,9 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) ! Input Auguments ! ! --------------- ! - type(physics_state), intent(inout) :: state ! Physics state variables - type(cam_in_t), intent(in) :: cam_in + type(physics_state), intent(inout) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in + type(physics_buffer_desc), pointer, intent(in) :: pbuf(:) ! ---------------- ! ! Output Auguments ! @@ -3231,6 +3232,9 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) integer :: ixq,ixcldliq !PMA fix for thv real(r8) :: rrho ! Inverse air density + integer :: oro_drag_ribulk_idx ! pbuf index of bulk richardson number for oro drag + real(r8), pointer :: oro_drag_ribulk(:) ! pbuf pointer for bulk richardson number + #endif obklen(pcols) = 0.0_r8 @@ -3295,9 +3299,12 @@ subroutine clubb_surface (state, cam_in, ustar, obklen) kbfs_pcol(i)=kbfs enddo + oro_drag_ribulk_idx = pbuf_get_index('oro_drag_ribulk') + call pbuf_get_field(pbuf, oro_drag_ribulk_idx, oro_drag_ribulk) + !calculate the bulk richardson number call pblintd_ri(ncol, gravit, thv_lv, state%zm, state%u, state%v, & - ustar, obklen, kbfs_pcol, state%ribulk) + ustar, obklen, kbfs_pcol, oro_drag_ribulk) endif return diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index 64e3750dd4e7..7ac806c10326 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -17,7 +17,7 @@ module comsrf ! USES: ! use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use ppgrid, only: pcols, begchunk, endchunk,nvar_dirOA,nvar_dirOL + use ppgrid, only: pcols, begchunk, endchunk use infnan, only: nan, assignment(=) use cam_abortutils, only: endrun @@ -31,8 +31,6 @@ module comsrf ! ! PUBLIC MEMBER FUNCTIONS: ! public initialize_comsrf ! Set the surface temperature and sea-ice fraction - !!added for separate input of ogwd parareters in gw_drag - public initialize_comsrf_OD ! ! Public data ! @@ -56,10 +54,6 @@ module comsrf real(r8), allocatable:: trefmxav(:,:) ! diagnostic: tref max over the day real(r8), allocatable:: trefmnav(:,:) ! diagnostic: tref min over the day - public oc, ol, oadir - real(r8), allocatable:: oc(:,:) ! Convexity - real(r8), allocatable:: oadir(:,:,:) ! Asymmetry - real(r8), allocatable:: ol(:,:,:) ! Effective length ! ! Private module data @@ -138,28 +132,4 @@ subroutine initialize_comsrf end if end subroutine initialize_comsrf - subroutine initialize_comsrf_OD - use cam_control_mod, only: ideal_phys, adiabatic -!----------------------------------------------------------------------- -! -! Purpose: -! Initialize surface data -! -! Method: -! -! Author: Mariana Vertenstein -! -!----------------------------------------------------------------------- - integer k,c ! level, constituent indices - - if(.not. (adiabatic .or. ideal_phys)) then - allocate (oc (pcols,begchunk:endchunk)) - allocate (oadir (pcols,nvar_dirOA,begchunk:endchunk)) - allocate (ol (pcols,nvar_dirOL,begchunk:endchunk)) - oc (:,:) = nan - oadir (:,:,:) = nan - ol (:,:,:) = nan - end if - end subroutine initialize_comsrf_OD - end module comsrf diff --git a/components/eam/src/physics/cam/gw_drag.F90 b/components/eam/src/physics/cam/gw_drag.F90 index 352858905ba9..96ac9f70021e 100644 --- a/components/eam/src/physics/cam/gw_drag.F90 +++ b/components/eam/src/physics/cam/gw_drag.F90 @@ -24,7 +24,7 @@ module gw_drag !-------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp, nvar_dirOA, nvar_dirOL, begchunk, endchunk + use ppgrid, only: pcols, pver use hycoef, only: hyai, hybi, hyam, hybm, etamid use constituents, only: pcnst use physics_types, only: physics_state, physics_ptend, physics_ptend_init @@ -49,6 +49,7 @@ module gw_drag ! PUBLIC: interfaces ! public :: gw_drag_readnl ! Read namelist + public :: gw_register ! Register pbuf variables public :: gw_init ! Initialization public :: gw_tend ! interface to actual parameterization @@ -199,7 +200,16 @@ end subroutine gw_drag_readnl !========================================================================== -subroutine gw_init() +subroutine gw_register() + use od_common, only: oro_drag_register + + call oro_drag_register() + +end subroutine gw_register + +!========================================================================== + +subroutine gw_init(pbuf2d) !----------------------------------------------------------------------- ! Time independent initialization for multiple gravity wave ! parameterization. @@ -208,7 +218,7 @@ subroutine gw_init() use cam_history, only: addfld, horiz_only, add_default use interpolate_data, only: lininterp use phys_control, only: phys_getopts - use physics_buffer, only: pbuf_get_index + use physics_buffer, only: pbuf_get_index, physics_buffer_desc use ref_pres, only: pref_edge use physconst, only: gravit, rair @@ -218,12 +228,9 @@ subroutine gw_init() use gw_front, only: gw_front_init use gw_convect, only: gw_convect_init - use comsrf, only: oc, oadir, ol, initialize_comsrf_OD - use pio, only: file_desc_t - use startup_initialconds,only: topo_OD_file_get_id, setup_initial_OD, close_initial_file_OD - use ncdio_atm, only: infld - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id,cam_grid_get_dim_names - + use od_common, only: oro_drag_init + !------------------------------Arguments-------------------------------- + type(physics_buffer_desc), pointer :: pbuf2d(:,:) !---------------------------Local storage------------------------------- integer :: l, k @@ -296,36 +303,8 @@ subroutine gw_init() character(len=128) :: errstring !----------------------------------------------------------------------- - !added for input of od parameters - type(file_desc_t), pointer :: ncid_topo_OD - logical :: found=.false. - character(len=8) :: dim1name, dim2name - character*11 :: subname='gw_init' ! subroutine name - integer :: grid_id - pblh_idx = pbuf_get_index('pblh') - grid_id = cam_grid_id('physgrid') - - if (use_od_ls.or.use_od_bl) then - if (.not. cam_grid_check(grid_id)) then - call endrun(trim(subname)//': Internal error, no "physgrid" grid') - end if - call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - call initialize_comsrf_OD() - call setup_initial_OD() - - ncid_topo_OD=>topo_OD_file_get_id() - call infld('OC', ncid_topo_OD, dim1name, dim2name, 1, pcols, begchunk, & - endchunk, oc , found, gridname='physgrid') - !keep the same interval of OA,OL - call infld('OA', ncid_topo_OD,dim1name, 'nvar_dirOA', dim2name, 1, pcols, 1, nvar_dirOA, begchunk, & - endchunk, oadir(:,:,:), found, gridname='physgrid') - call infld('OL', ncid_topo_OD,dim1name, 'nvar_dirOL', dim2name, 1, pcols, 1, nvar_dirOL, begchunk, & - endchunk, ol , found, gridname='physgrid') - if(.not. found) call endrun('ERROR: OD topo file readerr') - call close_initial_file_OD() - - endif + call oro_drag_init(pbuf2d) ! Set model flags. do_spectral_waves = (pgwv > 0 .and. (use_gw_front .or. use_gw_convect)) @@ -699,9 +678,6 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) ! real(r8), pointer :: pblh(:) real(r8) :: dx(pcols),dy(pcols) - ! - logical :: gwd_ls,gwd_bl,gwd_ss,gwd_fd - ! !---------------------------Local storage------------------------------- @@ -998,22 +974,12 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) ttgw, qtgw, taucd, egwdffi, gwut(:,:,0:0), dttdf, dttke) endif ! - if (use_od_ls.or.& - use_od_bl.or.& - use_od_ss) then - !open ogwd,bl,ss, - !close fd - gwd_ls=use_od_ls - gwd_bl=use_od_bl - gwd_ss=use_od_ss - gwd_fd=.false. - ! + if ( use_od_ls .or. use_od_bl .or. use_od_ss) then utgw=0.0_r8 vtgw=0.0_r8 ttgw=0.0_r8 - ! call oro_drag_interface(state,cam_in,sgh,pbuf,dt,nm,& - gwd_ls,gwd_bl,gwd_ss,gwd_fd,& + use_od_ls,use_od_bl,use_od_ss,.false.,& od_ls_ncleff,od_bl_ncd,od_ss_sncleff,& utgw,vtgw,ttgw,& dtaux3_ls=dtaux3_ls,dtauy3_ls=dtauy3_ls,& @@ -1024,14 +990,13 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl,& dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss,& dusfc_fd=dummx_fd,dvsfc_fd=dummy_fd) - endif - ! - ! Add the orographic tendencies to the spectrum tendencies - ! Compute the temperature tendency from energy conservation - ! (includes spectrum). - ! both old and new gwd scheme will add the tendency to circulation - ! + ! + ! Add the orographic tendencies to the spectrum tendencies + ! Compute the temperature tendency from energy conservation + ! (includes spectrum). + ! both old and new gwd scheme will add the tendency to circulation + ! if (use_gw_oro.or.& use_od_ls .or.& use_od_bl .or.& diff --git a/components/eam/src/physics/cam/od_common.F90 b/components/eam/src/physics/cam/od_common.F90 index 3eb81889e95a..5d84e718b287 100644 --- a/components/eam/src/physics/cam/od_common.F90 +++ b/components/eam/src/physics/cam/od_common.F90 @@ -1,5 +1,5 @@ module od_common -! +!========================================================================== ! This module contains code common to different orographic drag ! parameterizations. ! It includes 4 parts: @@ -7,23 +7,159 @@ module od_common ! flow-blocking drag (Xie et al.,2020), ! small-scale orographic gravity wave drag (Tsiringakis et al. 2017), ! turbulent orographic form drag (Beljaars et al.,2004). -! -use gw_utils, only: r8 -use ppgrid, only: pver,nvar_dirOA,nvar_dirOL +!========================================================================== +use shr_kind_mod, only: i8 => shr_kind_i8, r8 => shr_kind_r8 +use shr_sys_mod, only: shr_sys_flush +use ppgrid, only: pcols, pver, begchunk, endchunk use cam_logfile, only: iulog +use cam_abortutils,only: endrun +use pio, only: file_desc_t +use phys_control, only: use_od_ls, use_od_bl, use_od_ss, od_ls_ncleff, od_bl_ncd, od_ss_sncleff +use physics_buffer,only: dtype_r8, physics_buffer_desc, pbuf_get_chunk +use physics_buffer,only: pbuf_get_index, pbuf_get_field, pbuf_add_field, pbuf_set_field implicit none private save ! Public interface. +public :: oro_drag_register +public :: oro_drag_init public :: oro_drag_interface public :: od_gsd,pblh_get_level_idx,grid_size +type(file_desc_t), pointer :: topo_file_ncid + +! dimensions for topo shape data +integer, parameter :: ndir_asymmetry = 2+1 ! add 1 to avoid bug reading file - not sure why this happens +integer, parameter :: ndir_efflength = 180 ! 1-degree resolution with opposite directions mirrored + +! pbuf indices for data read in from topo data file +integer :: oro_drag_convexity_idx = -1 ! Convexity +integer :: oro_drag_asymmetry_idx = -1 ! Asymmetry +integer :: oro_drag_efflength_idx = -1 ! Effective length +integer :: oro_drag_ribulk_idx = -1 ! bulk richardson number (calculated in CLUBB) + contains !========================================================================== +subroutine oro_drag_open_topo_file() + use filenames, only: bnd_topo + use ioFileMod, only: getfil + use cam_pio_utils,only: cam_pio_openfile + use pio, only: pio_nowrite + include 'netcdf.inc' + !----------------------------------------------------------------------- + character(len=256) :: bnd_topo_loc ! filepath of topo file on local disk + allocate(topo_file_ncid) + call getfil(bnd_topo, bnd_topo_loc) + call cam_pio_openfile(topo_file_ncid, bnd_topo_loc, PIO_NOWRITE) +end subroutine oro_drag_open_topo_file + +!========================================================================== + +subroutine oro_drag_close_topo_file + use pio, only: pio_closefile + call pio_closefile(topo_file_ncid) + deallocate(topo_file_ncid) + nullify(topo_file_ncid) +end subroutine oro_drag_close_topo_file + +!========================================================================== + +subroutine oro_drag_register() + !----------------------------------------------------------------------- + ! Register pbuf variables for orographic drag parameterizations + !----------------------------------------------------------------------- + ! create pbuf variables to hold oro drag data + if (use_od_ls.or.use_od_bl) then + call pbuf_add_field('oro_drag_convexity','physpkg',dtype_r8,(/pcols/), oro_drag_convexity_idx) + call pbuf_add_field('oro_drag_asymmetry','physpkg',dtype_r8,(/pcols,ndir_asymmetry/),oro_drag_asymmetry_idx) + call pbuf_add_field('oro_drag_efflength','physpkg',dtype_r8,(/pcols,ndir_efflength/),oro_drag_efflength_idx) + end if + if (use_od_ss) then + call pbuf_add_field('oro_drag_ribulk', 'physpkg',dtype_r8,(/pcols/), oro_drag_ribulk_idx) + end if + +end subroutine oro_drag_register + +!========================================================================== + +subroutine oro_drag_init(pbuf2d) + !----------------------------------------------------------------------- + ! Initialization for orographic drag parameterizations + !----------------------------------------------------------------------- + use pio, only: file_desc_t + use ncdio_atm, only: infld + use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id,cam_grid_get_dim_names + use infnan, only: nan, assignment(=) + !----------------------------------------------------------------------- + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + !----------------------------------------------------------------------- + logical :: found + character(len=8) :: dim1name, dim2name + character*11 :: subname='oro_drag_init' + integer :: grid_id + integer :: c + + real(r8), allocatable:: oro_drag_convexity_tmp(:,:) + real(r8), allocatable:: oro_drag_asymmetry_tmp(:,:,:) + real(r8), allocatable:: oro_drag_efflength_tmp(:,:,:) + + type(physics_buffer_desc), pointer :: pbuf_chunk(:) ! temporary pbuf pointer for single chunk + !----------------------------------------------------------------------- + if (.not.(use_od_ls.or.use_od_bl)) return + + grid_id = cam_grid_id('physgrid') + if (.not. cam_grid_check(grid_id)) then + call endrun(trim(subname)//': Internal error, no "physgrid" grid') + end if + + ! Alocate variables for reading oro drag data + allocate( oro_drag_convexity_tmp(pcols,begchunk:endchunk) ) + allocate( oro_drag_asymmetry_tmp(pcols,ndir_asymmetry,begchunk:endchunk) ) + allocate( oro_drag_efflength_tmp(pcols,ndir_efflength,begchunk:endchunk) ) + oro_drag_convexity_tmp(:,:) = nan + oro_drag_asymmetry_tmp(:,:,:) = nan + oro_drag_efflength_tmp(:,:,:) = nan + + ! Read special orographic shape fields from topo file + call cam_grid_get_dim_names(grid_id, dim1name, dim2name) + call oro_drag_open_topo_file() + + found=.false. + call infld( 'OC', topo_file_ncid, dim1name, dim2name, 1, pcols, & + begchunk, endchunk, oro_drag_convexity_tmp(:,:), found, gridname='physgrid') + if(.not. found) call endrun('ERROR - oro_drag_init: topo file read error - OC') + + found=.false. + call infld( 'OA', topo_file_ncid, dim1name, 'ndir_asymmetry', dim2name, 1, pcols, 1, ndir_asymmetry, & + begchunk, endchunk, oro_drag_asymmetry_tmp(:,:,:), found, gridname='physgrid') + if(.not. found) call endrun('ERROR - oro_drag_init: topo file read error - OA') + + found=.false. + call infld( 'OL', topo_file_ncid, dim1name, 'ndir_efflength', dim2name, 1, pcols, 1, ndir_efflength, & + begchunk, endchunk, oro_drag_efflength_tmp(:,:,:), found, gridname='physgrid') + if(.not. found) call endrun('ERROR - oro_drag_init: topo file read error - OL') + + call oro_drag_close_topo_file() + + ! copy the oro drag data in pbuf + do c=begchunk,endchunk + pbuf_chunk => pbuf_get_chunk(pbuf2d, c) + call pbuf_set_field(pbuf_chunk, oro_drag_convexity_idx, oro_drag_convexity_tmp(:,c) ) + call pbuf_set_field(pbuf_chunk, oro_drag_asymmetry_idx, oro_drag_asymmetry_tmp(:,:,c) ) + call pbuf_set_field(pbuf_chunk, oro_drag_efflength_idx, oro_drag_efflength_tmp(:,:,c) ) + end do + + deallocate(oro_drag_convexity_tmp) + deallocate(oro_drag_asymmetry_tmp) + deallocate(oro_drag_efflength_tmp) + +end subroutine oro_drag_init +!========================================================================== + subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, & gwd_ls, gwd_bl, gwd_ss, gwd_fd, & od_ls_ncleff, od_bl_ncd,od_ss_sncleff, & @@ -33,13 +169,12 @@ subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, dusfc_ls, dvsfc_ls ,dusfc_bl, dvsfc_bl, & dusfc_ss, dvsfc_ss ,dusfc_fd, dvsfc_fd) use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index use camsrfexch, only: cam_in_t use ppgrid, only: pcols,pver,pverp use physconst, only: gravit,rair,cpair,rh2o,zvir,pi use hycoef, only: etamid - - type(physics_state), intent(in) :: state ! physics state structure ! Standard deviation of orography. + !----------------------------------------------------------------------- + type(physics_state), intent(in) :: state ! physics state structure type(cam_in_t), intent(in) :: cam_in real(r8), intent(in) :: sgh(pcols) type(physics_buffer_desc), pointer :: pbuf(:) ! Physics buffer @@ -81,17 +216,21 @@ subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, real(r8) :: zmid(pcols,pver) ! middle interface height asl (m) real(r8) :: dz(pcols,pver) ! model layer height - !real(r8) :: g - !pblh input integer :: pblh_idx = 0 integer :: kpbl2d_in(pcols) integer :: kpbl2d_reverse_in(pcols) real(r8), pointer :: pblh(:) real(r8) :: dx(pcols),dy(pcols) - !needed index + + real(r8), pointer :: oro_drag_convexity(:) + real(r8), pointer :: oro_drag_asymmetry(:,:) + real(r8), pointer :: oro_drag_efflength(:,:) + real(r8), pointer :: oro_drag_ribulk(:) ! pbuf pointer for bulk richardson number + integer :: ncol integer :: i integer :: k + !----------------------------------------------------------------------- ncol=state%ncol !convert heights above surface to heights above sea level @@ -120,7 +259,7 @@ subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, do k=1,pver do i=1,ncol - ! assign values for level top/bottom + ! assign values for level top/bottom ztop(i,k)=state%zi(i,k) zbot(i,k)=state%zi(i,k+1) enddo @@ -145,34 +284,41 @@ subroutine oro_drag_interface(state, cam_in, sgh, pbuf, dtime, nm, kpbl2d_reverse_in(i)=pverp-kpbl2d_in(i)!pverp-k end do + call pbuf_get_field(pbuf, oro_drag_convexity_idx, oro_drag_convexity ) + call pbuf_get_field(pbuf, oro_drag_asymmetry_idx, oro_drag_asymmetry ) + call pbuf_get_field(pbuf, oro_drag_efflength_idx, oro_drag_efflength ) + call pbuf_get_field(pbuf, oro_drag_ribulk_idx, oro_drag_ribulk) + !get grid size for dx,dy call grid_size(state,dx,dy) + !interface for orographic drag - call od_gsd(& - u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& - qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& - pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& - od_ls_ncleff=od_ls_ncleff,od_bl_ncd=od_bl_ncd,od_ss_sncleff=od_ss_sncleff,& - rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& - dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& - dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& - dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& - dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& - dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& - dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& - dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& - dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& - xland=cam_in%landfrac,br=state%ribulk(:ncol),& - var2d=sgh(:ncol),oc12d=state%oc(:ncol),& - oa2d=state%oadir(:ncol,:),ol2d=state%ol(:ncol,:),& - znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& - cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& - dt=dtime,dx=dx,dy=dy,& - kpbl2d=kpbl2d_reverse_in,gwd_opt=0,& - ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & - ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & - its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & - gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) + call od_gsd(u3d=state%u(:ncol,pver:1:-1),v3d=state%v(:ncol,pver:1:-1),t3d=state%t(:ncol,pver:1:-1),& + qv3d=state%q(:ncol,pver:1:-1,1),p3d=state%pmid(:ncol,pver:1:-1),p3di=state%pint(:ncol,pver+1:1:-1),& + pi3d=state%exner(:ncol,pver:1:-1),z=zbot(:ncol,pver:1:-1),& + od_ls_ncleff=od_ls_ncleff,od_bl_ncd=od_bl_ncd,od_ss_sncleff=od_ss_sncleff,& + rublten=utgw(:ncol,pver:1:-1),rvblten=vtgw(:ncol,pver:1:-1),rthblten=ttgw(:ncol,pver:1:-1),& + dtaux3d_ls=dtaux3_ls(:ncol,pver:1:-1),dtauy3d_ls=dtauy3_ls(:ncol,pver:1:-1),& + dtaux3d_bl=dtaux3_bl(:ncol,pver:1:-1),dtauy3d_bl=dtauy3_bl(:ncol,pver:1:-1),& + dtaux3d_ss=dtaux3_ss(:ncol,pver:1:-1),dtauy3d_ss=dtauy3_ss(:ncol,pver:1:-1),& + dtaux3d_fd=dtaux3_fd(:ncol,pver:1:-1),dtauy3d_fd=dtauy3_fd(:ncol,pver:1:-1),& + dusfcg_ls=dusfc_ls(:ncol),dvsfcg_ls=dvsfc_ls(:ncol),& + dusfcg_bl=dusfc_bl(:ncol),dvsfcg_bl=dvsfc_bl(:ncol),& + dusfcg_ss=dusfc_ss(:ncol),dvsfcg_ss=dvsfc_ss(:ncol),& + dusfcg_fd=dusfc_fd(:ncol),dvsfcg_fd=dvsfc_fd(:ncol),& + xland=cam_in%landfrac,br=oro_drag_ribulk(:ncol),& + var2d=sgh(:ncol),& + oc12d=oro_drag_convexity(:ncol),& + oa2d=oro_drag_asymmetry(:ncol,:),& + ol2d=oro_drag_efflength(:ncol,:),& + znu=etamid(pver:1:-1),dz=dz(:ncol,pver:1:-1),pblh=pblh(:ncol),& + cp=cpair,g=gravit,rd=rair,rv=rh2o,ep1=zvir,pi=pi,bnvbg=nm(:ncol,pver:1:-1),& + dt=dtime,dx=dx,dy=dy,& + kpbl2d=kpbl2d_reverse_in,gwd_opt=0,& + ids=1,ide=ncol,jds=0,jde=0,kds=1,kde=pver, & + ims=1,ime=ncol,jms=0,jme=0,kms=1,kme=pver, & + its=1,ite=ncol,jts=0,jte=0,kts=1,kte=pver, & + gwd_ls=gwd_ls,gwd_bl=gwd_bl,gwd_ss=gwd_ss,gwd_fd=gwd_fd ) end subroutine oro_drag_interface @@ -263,39 +409,39 @@ subroutine grid_size(state, grid_dx, grid_dy) integer :: i do i=1,state%ncol - ! determine the column area in radians - column_area = get_area_p(state%lchnk,i) - ! convert to degrees - degree = sqrt(column_area)*(180._r8/shr_const_pi) - - ! convert latitude to radians - lat_in_rad = state%lat(i)*(shr_const_pi/180._r8) - - ! Now find meters per degree latitude - ! Below equation finds distance between two points on an ellipsoid, derived from expansion - ! taking into account ellipsoid using World Geodetic System (WGS84) reference - mpdeglat = earth_ellipsoid1 - earth_ellipsoid2 * cos(2._r8*lat_in_rad) + earth_ellipsoid3 * cos(4._r8*lat_in_rad) - grid_dx(i) = mpdeglat * degree - grid_dy(i) = grid_dx(i) ! Assume these are the same + ! determine the column area in radians + column_area = get_area_p(state%lchnk,i) + ! convert to degrees + degree = sqrt(column_area)*(180._r8/shr_const_pi) + + ! convert latitude to radians + lat_in_rad = state%lat(i)*(shr_const_pi/180._r8) + + ! Now find meters per degree latitude + ! Below equation finds distance between two points on an ellipsoid, derived from expansion + ! taking into account ellipsoid using World Geodetic System (WGS84) reference + mpdeglat = earth_ellipsoid1 - earth_ellipsoid2 * cos(2._r8*lat_in_rad) + earth_ellipsoid3 * cos(4._r8*lat_in_rad) + grid_dx(i) = mpdeglat * degree + grid_dy(i) = grid_dx(i) ! Assume these are the same enddo end subroutine grid_size !========================================================================== subroutine od_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & - od_ls_ncleff,od_bl_ncd,od_ss_sncleff, & - rublten,rvblten,rthblten, & - dtaux3d_ls,dtauy3d_ls,dtaux3d_bl,dtauy3d_bl, & - dtaux3d_ss,dtauy3d_ss,dtaux3d_fd,dtauy3d_fd, & - dusfcg_ls,dvsfcg_ls,dusfcg_bl,dvsfcg_bl,dusfcg_ss,dvsfcg_ss, & - dusfcg_fd,dvsfcg_fd,xland,br, & - var2d,oc12d,oa2d,ol2d,znu,znw,p_top,dz,pblh, & - cp,g,rd,rv,ep1,pi,bnvbg, & - dt,dx,dy,kpbl2d,gwd_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - gwd_ls,gwd_bl,gwd_ss,gwd_fd) + od_ls_ncleff,od_bl_ncd,od_ss_sncleff, & + rublten,rvblten,rthblten, & + dtaux3d_ls,dtauy3d_ls,dtaux3d_bl,dtauy3d_bl, & + dtaux3d_ss,dtauy3d_ss,dtaux3d_fd,dtauy3d_fd, & + dusfcg_ls,dvsfcg_ls,dusfcg_bl,dvsfcg_bl,dusfcg_ss,dvsfcg_ss, & + dusfcg_fd,dvsfcg_fd,xland,br, & + var2d,oc12d,oa2d,ol2d,znu,znw,p_top,dz,pblh, & + cp,g,rd,rv,ep1,pi,bnvbg, & + dt,dx,dy,kpbl2d,gwd_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + gwd_ls,gwd_bl,gwd_ss,gwd_fd) !------------------------------------------------------------------------------- implicit none !------------------------------------------------------------------------------- @@ -375,8 +521,8 @@ subroutine od_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & !input topographic parameters real(r8), dimension( ims:ime ), intent(in), optional :: var2d real(r8), dimension( ims:ime ), intent(in), optional :: oc12d - real(r8), dimension( ims:ime,nvar_dirOL ),intent(in), optional :: ol2d - real(r8), dimension( ims:ime,nvar_dirOA ),intent(in), optional :: oa2d + real(r8), dimension( ims:ime,ndir_efflength ),intent(in), optional :: ol2d + real(r8), dimension( ims:ime,ndir_asymmetry ),intent(in), optional :: oa2d !input model parameters real(r8), intent(in), optional :: dt real(r8), intent(in), optional :: p_top @@ -426,8 +572,8 @@ subroutine od_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & real(r8), dimension( its:ite, kts:kte ) :: delprsi real(r8), dimension( its:ite, kts:kte ) :: pdh real(r8), dimension( its:ite, kts:kte+1 ) :: pdhi - real(r8), dimension( its:ite, nvar_dirOA ) :: oa4 - real(r8), dimension( its:ite, nvar_dirOL ) :: ol4 + real(r8), dimension( its:ite, ndir_asymmetry ) :: oa4 + real(r8), dimension( its:ite, ndir_efflength ) :: ol4 integer :: i,j,k,kpblmax !determine the lowest level for planet boundary layer do k = kts,kte @@ -454,58 +600,58 @@ subroutine od_gsd(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & ol4(i,:) = ol2d(i,:) enddo endif - !call the od2d for calculatino of each grid - call od2d(dudt=rublten(ims,kms),dvdt=rvblten(ims,kms) & - ,dthdt=rthblten(ims,kms) & - ,ncleff=od_ls_ncleff,ncd=od_bl_ncd,sncleff=od_ss_sncleff & - ,dtaux2d_ls=dtaux2d_ls,dtauy2d_ls=dtauy2d_ls & - ,dtaux2d_bl=dtaux2d_bl,dtauy2d_bl=dtauy2d_bl & - ,dtaux2d_ss=dtaux2d_ss,dtauy2d_ss=dtauy2d_ss & - ,dtaux2d_fd=dtaux2d_fd,dtauy2d_fd=dtauy2d_fd & - ,u1=u3d(ims,kms),v1=v3d(ims,kms) & - ,t1=t3d(ims,kms) & - ,q1=qv3d(ims,kms) & - ,del=delprsi(its,kts) & - ,prsi=pdhi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms) & - ,zl=z(ims,kms),rcl=1.0_r8 & - ,xland1=xland(ims),br1=br(ims),hpbl=pblh(ims) & - ,bnv_in=bnvbg(ims,kms) & - ,dz2=dz(ims,kms) & - ,kpblmax=kpblmax & - ,dusfc_ls=dusfc_ls,dvsfc_ls=dvsfc_ls & - ,dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl & - ,dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss & - ,dusfc_fd=dusfc_fd,dvsfc_fd=dvsfc_fd & - ,var=var2d(ims),oc1=oc12d(ims) & - ,oa4=oa4,ol4=ol4 & - ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi & - ,dxmeter=dx,dymeter=dy,deltim=dt & - ,kpbl=kpbl2d(ims) & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte & - ,gsd_gwd_ls=gwd_ls,gsd_gwd_bl=gwd_bl,gsd_gwd_ss=gwd_ss,gsd_gwd_fd=gwd_fd) - !set the total stress output to each terms for the 4 drag schemes - do i = its,ite - dusfcg_ls(i)=dusfc_ls(i) - dvsfcg_ls(i)=dvsfc_ls(i) - dusfcg_bl(i)=dusfc_bl(i) - dvsfcg_bl(i)=dvsfc_bl(i) - dusfcg_ss(i)=dusfc_ss(i) - dvsfcg_ss(i)=dvsfc_ss(i) - dusfcg_fd(i)=dusfc_fd(i) - dvsfcg_fd(i)=dvsfc_fd(i) - enddo - !set the 3D output tendencies to each terms for the 4 drag schemes - dtaux3d_ls=dtaux2d_ls - dtaux3d_bl=dtaux2d_bl - dtauy3d_ls=dtauy2d_ls - dtauy3d_bl=dtauy2d_bl - dtaux3d_ss=dtaux2d_ss - dtaux3d_fd=dtaux2d_fd - dtauy3d_ss=dtauy2d_ss - dtauy3d_fd=dtauy2d_fd + !call the od2d for calculatino of each grid + call od2d(dudt=rublten(ims,kms),dvdt=rvblten(ims,kms) & + ,dthdt=rthblten(ims,kms) & + ,ncleff=od_ls_ncleff,ncd=od_bl_ncd,sncleff=od_ss_sncleff & + ,dtaux2d_ls=dtaux2d_ls,dtauy2d_ls=dtauy2d_ls & + ,dtaux2d_bl=dtaux2d_bl,dtauy2d_bl=dtauy2d_bl & + ,dtaux2d_ss=dtaux2d_ss,dtauy2d_ss=dtauy2d_ss & + ,dtaux2d_fd=dtaux2d_fd,dtauy2d_fd=dtauy2d_fd & + ,u1=u3d(ims,kms),v1=v3d(ims,kms) & + ,t1=t3d(ims,kms) & + ,q1=qv3d(ims,kms) & + ,del=delprsi(its,kts) & + ,prsi=pdhi(its,kts) & + ,prsl=pdh(its,kts),prslk=pi3d(ims,kms) & + ,zl=z(ims,kms),rcl=1.0_r8 & + ,xland1=xland(ims),br1=br(ims),hpbl=pblh(ims) & + ,bnv_in=bnvbg(ims,kms) & + ,dz2=dz(ims,kms) & + ,kpblmax=kpblmax & + ,dusfc_ls=dusfc_ls,dvsfc_ls=dvsfc_ls & + ,dusfc_bl=dusfc_bl,dvsfc_bl=dvsfc_bl & + ,dusfc_ss=dusfc_ss,dvsfc_ss=dvsfc_ss & + ,dusfc_fd=dusfc_fd,dvsfc_fd=dvsfc_fd & + ,var=var2d(ims),oc1=oc12d(ims) & + ,oa4=oa4,ol4=ol4 & + ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi & + ,dxmeter=dx,dymeter=dy,deltim=dt & + ,kpbl=kpbl2d(ims) & + ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & + ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & + ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte & + ,gsd_gwd_ls=gwd_ls,gsd_gwd_bl=gwd_bl,gsd_gwd_ss=gwd_ss,gsd_gwd_fd=gwd_fd) + !set the total stress output to each terms for the 4 drag schemes + do i = its,ite + dusfcg_ls(i) = dusfc_ls(i) + dvsfcg_ls(i) = dvsfc_ls(i) + dusfcg_bl(i) = dusfc_bl(i) + dvsfcg_bl(i) = dvsfc_bl(i) + dusfcg_ss(i) = dusfc_ss(i) + dvsfcg_ss(i) = dvsfc_ss(i) + dusfcg_fd(i) = dusfc_fd(i) + dvsfcg_fd(i) = dvsfc_fd(i) + enddo + !set the 3D output tendencies to each terms for the 4 drag schemes + dtaux3d_ls = dtaux2d_ls + dtaux3d_bl = dtaux2d_bl + dtauy3d_ls = dtauy2d_ls + dtauy3d_bl = dtauy2d_bl + dtaux3d_ss = dtaux2d_ss + dtaux3d_fd = dtaux2d_fd + dtauy3d_ss = dtauy2d_ss + dtauy3d_fd = dtauy2d_fd end subroutine od_gsd ! @@ -513,21 +659,21 @@ end subroutine od_gsd ! !------------------------------------------------------------------------------- subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & - dtaux2d_ls,dtauy2d_ls, & - dtaux2d_bl,dtauy2d_bl, & - dtaux2d_ss,dtauy2d_ss, & - dtaux2d_fd,dtauy2d_fd, & - u1,v1,t1,q1, & - del, & - prsi,prsl,prslk,zl,rcl, & - xland1,br1,hpbl,bnv_in,dz2, & - kpblmax,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & - dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd,var,oc1,oa4,ol4, & - g,cp,rd,rv,fv,pi,dxmeter,dymeter,deltim,kpbl, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - gsd_gwd_ls,gsd_gwd_bl,gsd_gwd_ss,gsd_gwd_fd) + dtaux2d_ls,dtauy2d_ls, & + dtaux2d_bl,dtauy2d_bl, & + dtaux2d_ss,dtauy2d_ss, & + dtaux2d_fd,dtauy2d_fd, & + u1,v1,t1,q1, & + del, & + prsi,prsl,prslk,zl,rcl, & + xland1,br1,hpbl,bnv_in,dz2, & + kpblmax,dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd,var,oc1,oa4,ol4, & + g,cp,rd,rv,fv,pi,dxmeter,dymeter,deltim,kpbl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + gsd_gwd_ls,gsd_gwd_bl,gsd_gwd_ss,gsd_gwd_fd) ! This code handles the time tendencies of u v due to the effect of mountain ! induced gravity wave drag from sub-grid scale orography. It includes 4 parts: ! orographic gravity wave drag and flow-blocking drag (Xie et al.,2020),small-scale @@ -582,8 +728,8 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & real(r8), dimension(:), intent(in) :: dxmeter real(r8), dimension(:), intent(in) :: dymeter !input topo variables - real(r8), dimension( ims:ime,nvar_dirOA ), intent(in) :: oa4 - real(r8), dimension( ims:ime,nvar_dirOL ), intent(in) :: ol4 + real(r8), dimension( ims:ime,ndir_asymmetry ), intent(in) :: oa4 + real(r8), dimension( ims:ime,ndir_efflength ), intent(in) :: ol4 real(r8), dimension( ims:ime ) , intent(in) :: var real(r8), dimension( ims:ime ) , intent(in) :: oc1 !input atmospheric variables @@ -673,7 +819,7 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & real(r8),parameter :: tndmax = 400._r8 / 86400._r8 ! convert 400 m/s/day to m/s/s integer,parameter :: kpblmin = 2 !number of direction for ogwd - integer,parameter :: mdir=2*nvar_dirOL + integer,parameter :: mdir=2*ndir_efflength ! variables for flow-blocking drag real(r8),parameter :: frmax = 10._r8 real(r8),parameter :: olmin = 1.0e-5_r8 @@ -736,8 +882,8 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & real(r8),dimension( its:ite ) :: dely real(r8),dimension( its:ite ) :: dxy real(r8),dimension( its:ite ) :: dxyp - real(r8),dimension( its:ite,nvar_dirOL ):: dxy4 - real(r8),dimension( its:ite,nvar_dirOL ):: dxy4p + real(r8),dimension( its:ite,ndir_efflength ):: dxy4 + real(r8),dimension( its:ite,ndir_efflength ):: dxy4p !topo parameters real(r8),dimension( its:ite ) :: olp real(r8),dimension( its:ite ) :: od @@ -893,192 +1039,192 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & ! ! For ls and bl only IF (gsd_gwd_ls.or.gsd_gwd_bl) then - ! figure out low-level horizontal wind direction - ! order into a counterclockwise index instead - ! - do i = its,ite - wdir = atan2(vbar(i),ubar(i)) + pi!changed into y/x - wdir1 = wdir-pi - if (wdir1.ge.0._r8.and.wdir1.lt.pi) then - nwd = MOD(nint(fdir*wdir1),mdir) + 1 - else!(-pi,0) - nwd = MOD(nint(fdir*(wdir1+2._r8*pi)),mdir) + 1 - endif - !turn backwords because start is pi - !need turning - rad = 4.0_r8*atan(1.0_r8)/180.0_r8 - theta = (real(nwd,kind=r8)-1._r8)*(360._r8/real(mdir,kind=r8)) - !select OA - oa1(i) = oa4(i,1)*cos(theta*rad)+oa4(i,2)*sin(theta*rad) - !select OL - ol(i) = ol4(i,MOD(nwd-1,int(mdir/2))+1) - !calculate dxygrid, not so slow - call dxygrid(dxmeter(i),dymeter(i),theta,dxy(i)) + ! figure out low-level horizontal wind direction + ! order into a counterclockwise index instead ! - !----- compute orographic width along (ol) and perpendicular (olp) - !----- the direction of wind - !put wdir inside the (0,2*pi) section - !changing pi/2 either way is perpendicular - !wdir1=wdir-pi + do i = its,ite + wdir = atan2(vbar(i),ubar(i)) + pi!changed into y/x + wdir1 = wdir-pi + if (wdir1.ge.0._r8.and.wdir1.lt.pi) then + nwd = MOD(nint(fdir*wdir1),mdir) + 1 + else!(-pi,0) + nwd = MOD(nint(fdir*(wdir1+2._r8*pi)),mdir) + 1 + endif + !turn backwords because start is pi + !need turning + rad = 4.0_r8*atan(1.0_r8)/180.0_r8 + theta = (real(nwd,kind=r8)-1._r8)*(360._r8/real(mdir,kind=r8)) + !select OA + oa1(i) = oa4(i,1)*cos(theta*rad)+oa4(i,2)*sin(theta*rad) + !select OL + ol(i) = ol4(i,MOD(nwd-1,int(mdir/2))+1) + !calculate dxygrid, not so slow + call dxygrid(dxmeter(i),dymeter(i),theta,dxy(i)) + ! + !----- compute orographic width along (ol) and perpendicular (olp) + !----- the direction of wind + !put wdir inside the (0,2*pi) section + !changing pi/2 either way is perpendicular + !wdir1=wdir-pi if (wdir1.ge.0._r8.and.wdir1.lt.pi) then - nwd1 = MOD(nint(fdir*(wdir1+pi/2._r8)),mdir) + 1 - olp(i)=ol4(i,MOD(nwd1-1,int(mdir/2))+1) + nwd1 = MOD(nint(fdir*(wdir1+pi/2._r8)),mdir) + 1 + olp(i)=ol4(i,MOD(nwd1-1,int(mdir/2))+1) else!(-pi,0) - nwd1 = MOD(nint(fdir*(wdir1-pi/2._r8+2._r8*pi)),mdir) + 1 - olp(i)=ol4(i,MOD(nwd1-1,int(mdir/2))+1) + nwd1 = MOD(nint(fdir*(wdir1-pi/2._r8+2._r8*pi)),mdir) + 1 + olp(i)=ol4(i,MOD(nwd1-1,int(mdir/2))+1) endif theta=(real(nwd1,kind=r8)-1._r8)*(360._r8/real(mdir,kind=r8)) call dxygrid(dxmeter(i),dymeter(i),theta,dxyp(i)) - ! - ! - !----- compute orographic direction (horizontal orographic aspect ratio) - ! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) - ! - !----- compute length of grid in the along(dxy) and cross(dxyp) wind directions - ! - enddo + ! + ! + !----- compute orographic direction (horizontal orographic aspect ratio) + ! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) + ! + !----- compute length of grid in the along(dxy) and cross(dxyp) wind directions + ! + enddo ENDIF !============================================ ! END INITIALIZATION; BEGIN GWD CALCULATIONS: !============================================ IF (gsd_gwd_ls.or.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02) ) THEN - ! - !--- saving richardson number in usqj for migwdi - ! - do k = kts,kte-1 + ! + !--- saving richardson number in usqj for migwdi + ! + do k = kts,kte-1 + do i = its,ite + ti = 2.0_r8 / (t1(i,k)+t1(i,k+1)) + rdz = 1._r8/(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = rcl*(tem1*tem1 + tem2*tem2) + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = max(bnv_in(i,k)**2,bnv2min ) + enddo + enddo + ! + !----compute the "low level" or 1/3 wind magnitude (m/s) + ! do i = its,ite - ti = 2.0_r8 / (t1(i,k)+t1(i,k+1)) - rdz = 1._r8/(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = rcl*(tem1*tem1 + tem2*tem2) - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = max(bnv_in(i,k)**2,bnv2min ) + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0_r8) + rulow(i) = 1._r8/ulow(i) enddo - enddo - ! - !----compute the "low level" or 1/3 wind magnitude (m/s) - ! - do i = its,ite - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0_r8) - rulow(i) = 1._r8/ulow(i) - enddo - do k = kts,kte-1 + do k = kts,kte-1 + do i = its,ite + velco(i,k) = (0.5_r8*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0._r8)) then + velco(i,k) = veleps + endif + enddo + enddo + ! + ! no drag when critical level in the base layer + ! do i = its,ite - velco(i,k) = (0.5_r8*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0._r8)) then - velco(i,k) = veleps - endif + ldrag(i) = velco(i,1).le.0._r8 enddo - enddo - ! - ! no drag when critical level in the base layer - ! - do i = its,ite - ldrag(i) = velco(i,1).le.0._r8 - enddo - ! - ! no drag when velco.lt.0 - ! - do k = kpblmin,kpblmax + ! + ! no drag when velco.lt.0 + ! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0._r8 + enddo + enddo + ! + ! no drag when bnv2.lt.0 + ! + do k = kts,kpblmax + do i = its,ite + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0._r8 + enddo + enddo + ! + !-----the low level weighted average ri is stored in usqj(1,1; im) + !-----the low level weighted average n**2 is stored in bnv2(1,1; im) + !---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 + !---- rdelks (del(k)/delks) vert ave factor so we can * instead of / + ! do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0._r8 + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) enddo - enddo - ! - ! no drag when bnv2.lt.0 - ! - do k = kts,kpblmax + + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo + enddo + do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0._r8 + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0_r8 + ldrag(i) = ldrag(i) .or. ulow(i) .eq.1.0_r8 + ldrag(i) = ldrag(i) .or. var(i) .le.0.0_r8 enddo - enddo - ! - !-----the low level weighted average ri is stored in usqj(1,1; im) - !-----the low level weighted average n**2 is stored in bnv2(1,1; im) - !---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 - !---- rdelks (del(k)/delks) vert ave factor so we can * instead of / - ! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo - - do k = kpblmin,kpblmax + ! + ! set all ri low level values to the low level value + ! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo + enddo + do i = its,ite - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * 2._r8 * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) endif enddo - enddo - - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0_r8 - ldrag(i) = ldrag(i) .or. ulow(i) .eq.1.0_r8 - ldrag(i) = ldrag(i) .or. var(i) .le.0.0_r8 - enddo - ! - ! set all ri low level values to the low level value - ! - do k = kpblmin,kpblmax + ! + ! compute the base level stress and store it in taub + ! calculate enhancement factor, number of mountains & aspect + ! ratio const. use simplified relationship between standard + ! deviation & critical hgt + ! do i = its,ite - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + if (.not. ldrag(i)) then + !maintain (oa+2) greater than or equal to 0 + efact = max(oa1(i)+2._r8,0._r8) ** (ce*fr(i)/frc) + efact = min(max(efact,efmin),efmax) + ! cleff (effective grid length) is highly tunable parameter + ! the bigger (smaller) value produce weaker (stronger) wave drag + cleff = sqrt(dxy(i)**2._r8 + dxyp(i)**2._r8) + !tune the times of drag + cleff = (3._r8/ncleff) * max(dxmax_ls,cleff) + coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) + xlinv(i) = coefm(i) / cleff + tem = fr(i) * fr(i) * 1.!oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + ! + if (gsd_gwd_ls) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else ! We've gotten what we need for the blocking scheme + taub(i) = 0.0_r8 + end if + else + taub(i) = 0.0_r8 + xn(i) = 0.0_r8 + yn(i) = 0.0_r8 + endif enddo - enddo - - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * 2._r8 * var(i) * od(i) - fr(i) = min(fr(i),frmax) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif - enddo - ! - ! compute the base level stress and store it in taub - ! calculate enhancement factor, number of mountains & aspect - ! ratio const. use simplified relationship between standard - ! deviation & critical hgt - ! - do i = its,ite - if (.not. ldrag(i)) then - !maintain (oa+2) greater than or equal to 0 - efact = max(oa1(i)+2._r8,0._r8) ** (ce*fr(i)/frc) - efact = min(max(efact,efmin),efmax) - ! cleff (effective grid length) is highly tunable parameter - ! the bigger (smaller) value produce weaker (stronger) wave drag - cleff = sqrt(dxy(i)**2._r8 + dxyp(i)**2._r8) - !tune the times of drag - cleff = (3._r8/ncleff) * max(dxmax_ls,cleff) - coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) - xlinv(i) = coefm(i) / cleff - tem = fr(i) * fr(i) * 1.!oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - ! - if (gsd_gwd_ls) then - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else ! We've gotten what we need for the blocking scheme - taub(i) = 0.0_r8 - end if - else - taub(i) = 0.0_r8 - xn(i) = 0.0_r8 - yn(i) = 0.0_r8 - endif - enddo ENDIF ! (gsd_gwd_ls .eq. .true.).or.(gsd_gwd_bl .eq..true.) !========================================================= @@ -1092,93 +1238,93 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & zq=0._r8 IF (gsd_gwd_ss.and.(ss_taper.GT.1.E-02)) THEN - ! - ! declaring potential temperature - ! - do k = kts,kte - do i = its,ite - thx(i,k) = t1(i,k)/prslk(i,k) + ! + ! declaring potential temperature + ! + do k = kts,kte + do i = its,ite + thx(i,k) = t1(i,k)/prslk(i,k) + enddo enddo - enddo - do k = kts,kte - do i = its,ite - tvcon = (1._r8+fv*q1(i,k)) - thvx(i,k) = thx(i,k)*tvcon + do k = kts,kte + do i = its,ite + tvcon = (1._r8+fv*q1(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo enddo - enddo - ! - ! Defining layer height - ! - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz2(i,k)+zq(i,k) + ! + ! Defining layer height + ! + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz2(i,k)+zq(i,k) + enddo enddo - enddo - do k = kts,kte - do i = its,ite - za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) + do k = kts,kte + do i = its,ite + za(i,k) = 0.5_r8*(zq(i,k)+zq(i,k+1)) + enddo enddo - enddo - do i=its,ite - hpbl2 = hpbl(i)+10._r8 - kpbl2 = kpbl(i) - kvar = 1 - do k=kts+1,MAX(kpbl(i),kts+1) - IF (za(i,k)>300._r8) then - kpbl2 = k - IF (k == kpbl(i)) then - hpbl2 = hpbl(i)+10._r8 - ELSE - hpbl2 = za(i,k)+10._r8 + do i=its,ite + hpbl2 = hpbl(i)+10._r8 + kpbl2 = kpbl(i) + kvar = 1 + do k=kts+1,MAX(kpbl(i),kts+1) + IF (za(i,k)>300._r8) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10._r8 + ELSE + hpbl2 = za(i,k)+10._r8 + ENDIF + exit ENDIF - exit - ENDIF - enddo + enddo - if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then - if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then - cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) - cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) - coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) - xlinv(i) = coefm(i) / cleff - govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) - bnrf=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) - - if(abs(bnrf/u1(i,kpbl2)).gt.xlinv(i))then - tauwavex0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) - tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" - else - tauwavex0=0._r8 - endif + if(xland1(i).gt.0._r8 .and. 2._r8*var(i).le.hpbl(i))then + if(br1(i).gt.0._r8 .and. thvx(i,kpbl2)-thvx(i,kts) > 0._r8)then + cleff = sqrt(dxy(i)**2_r8 + dxyp(i)**2_r8) + cleff = (2.0_r8/sncleff) * max(dxmax_ss,cleff) + coefm(i) = (1._r8 + ol(i)) ** (oa1(i)+1._r8) + xlinv(i) = coefm(i) / cleff + govrth(i)=g/(0.5_r8*(thvx(i,kpbl2)+thvx(i,kts))) + bnrf=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) + + if(abs(bnrf/u1(i,kpbl2)).gt.xlinv(i))then + tauwavex0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2_r8*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper ! "Scale-awareness" + else + tauwavex0=0._r8 + endif - if(abs(bnrf/v1(i,kpbl2)).gt.xlinv(i))then - tauwavey0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) - tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" - else - tauwavey0=0._r8 - endif + if(abs(bnrf/v1(i,kpbl2)).gt.xlinv(i))then + tauwavey0=0.5_r8*bnrf*xlinv(i)*(2._r8*MIN(var(i),varmax))**2._r8*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper ! "Scale-awareness" + else + tauwavey0=0._r8 + endif - do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) - utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 - enddo + do k=kts,kpbl(i) !MIN(kpbl2+1,kte-1) + utendwave(i,k)=-1._r8*tauwavex0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + vtendwave(i,k)=-1._r8*tauwavey0*2._r8*max((1._r8-za(i,k)/hpbl2),0._r8)/hpbl2 + enddo + endif endif - endif - enddo ! end i loop + enddo ! end i loop - do k = kts,kte - do i = its,ite - dudt(i,k) = dudt(i,k) + utendwave(i,k) - dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) - dtaux2d_ss(i,k) = utendwave(i,k) - dtauy2d_ss(i,k) = vtendwave(i,k) - dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) - dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + do k = kts,kte + do i = its,ite + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + enddo enddo - enddo ENDIF ! end if gsd_gwd_ss == .true. !================================================================ @@ -1240,108 +1386,108 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) enddo enddo - ENDIF ! end if gsd_gwd_fd == .true. + ENDIF ! end if gsd_gwd_fd == .true. !======================================================= ! More for the large-scale gwd component !======================================================= IF (gsd_gwd_ls.and.(ls_taper.GT.1.E-02) ) THEN - ! - ! now compute vertical structure of the stress. - ! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo - - if (scorer_on) then - ! - !determination of the interface height for scorer adjustment - ! - do i=its,ite - iint=.false. - do k=kpblmin,kte-1 - if (k.gt.kbl(i).and.usqj(i,k)-usqj(i,k-1).lt.0.and.(.not.iint)) then - iint=.true. - zl_hint(i)=zl(i,k+1) - endif + ! + ! now compute vertical structure of the stress. + ! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) enddo enddo - endif - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite - ! - ! unstablelayer if ri < ric - ! unstable layer if upper air vel comp along surf vel <=0 (crit lay) - ! at (u-c)=0. crit layer exists and bit vector should be set (.le.) - ! - if (k .ge. kbl(i)) then - !we modify the criteria for unstable layer - !that the lv is critical under 0.25 - !while we keep wave breaking ric for - !other larger lv - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& - .or. (velco(i,k) .le. 0.0_r8) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo + if (scorer_on) then + ! + !determination of the interface height for scorer adjustment + ! + do i=its,ite + iint=.false. + do k=kpblmin,kte-1 + if (k.gt.kbl(i).and.usqj(i,k)-usqj(i,k-1).lt.0.and.(.not.iint)) then + iint=.true. + zl_hint(i)=zl(i,k+1) + endif + enddo + enddo + endif - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then - temv = 1.0_r8 / velco(i,k) - tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv - ! - ! rim is the minimum-richardson number by shutts (1985) - ! - tem2 = sqrt(usqj(i,k)) - tem = 1._r8 + tem2 * fro - rim = usqj(i,k) * (1._r8-fro) / (tem * tem) + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite + ! + ! unstablelayer if ri < ric + ! unstable layer if upper air vel comp along surf vel <=0 (crit lay) + ! at (u-c)=0. crit layer exists and bit vector should be set (.le.) + ! + if (k .ge. kbl(i)) then + !we modify the criteria for unstable layer + !that the lv is critical under 0.25 + !while we keep wave breaking ric for + !other larger lv + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric_rig)& + .or. (velco(i,k) .le. 0.0_r8) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo - ! - ! check stability to employ the 'saturation hypothesis' - ! of lindzen (1981) except at tropospheric downstream regions - ! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then - temc = 2.0_r8 + 1.0_r8 / tem2 - hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - ! - ! taup is restricted to monotoncally decrease - ! to avoid unexpected high taup in calculation - ! - taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) - ! - ! add vertical decrease at low level below hint (Kim and Doyle 2005) - ! where Ri first decreases - ! - if (scorer_on.and.k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i).and.k.lt.kte-1) then - l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2) - l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2) - taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0_r8 ) then + temv = 1.0_r8 / velco(i,k) + tem1 = coefm(i)/(dxy(i)/ncleff)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5_r8 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv + ! + ! rim is the minimum-richardson number by shutts (1985) + ! + tem2 = sqrt(usqj(i,k)) + tem = 1._r8 + tem2 * fro + rim = usqj(i,k) * (1._r8-fro) / (tem * tem) + + ! + ! check stability to employ the 'saturation hypothesis' + ! of lindzen (1981) except at tropospheric downstream regions + ! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa1(i) .le. 0._r8).or.(kp1 .ge. kpblmin )) then + temc = 2.0_r8 + 1.0_r8 / tem2 + hd = velco(i,k) * (2.0_r8*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + ! + ! taup is restricted to monotoncally decrease + ! to avoid unexpected high taup in calculation + ! + taup(i,kp1)=min(tem1*hd*hd,taup(i,k)) + ! + ! add vertical decrease at low level below hint (Kim and Doyle 2005) + ! where Ri first decreases + ! + if (scorer_on.and.k.gt.klowtop(i).and.zl(i,k).le.zl_hint(i).and.k.lt.kte-1) then + l1=(9.81_r8*bnv2(i,kp1)/velco(i,kp1)**2) + l2=(9.81_r8*bnv2(i,k)/velco(i,k)**2) + taup(i,kp1)=min(taup(i,k),taup(i,k)*(l1/l2),tem1*hd*hd) + endif endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) endif endif - endif + enddo enddo - enddo - if(lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + if(lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo enddo - enddo - endif + endif ENDIF !END LARGE-SCALE TAU CALCULATION !=============================================================== @@ -1349,11 +1495,11 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & !=============================================================== IF (gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN - do i = its,ite - if(.not.ldrag(i)) then - ! - !------- determine the height of flow-blocking layer - ! + do i = its,ite + if(.not.ldrag(i)) then + ! + !------- determine the height of flow-blocking layer + ! kblk = 0 pe = 0.0_r8 @@ -1364,9 +1510,9 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & !divided by g*ro is to turn del(pa) into height pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) ke = 0.5_r8*((rcs*u1(i,k))**2._r8+(rcs*v1(i,k))**2._r8) - ! - !---------- apply flow-blocking drag when pe >= ke - ! + ! + !---------- apply flow-blocking drag when pe >= ke + ! if(pe.ge.ke) then kblk = k kblk = min(kblk,kbl(i)) @@ -1376,9 +1522,9 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & enddo if(kblk.ne.0) then - ! - !--------- compute flow-blocking stress - ! + ! + !--------- compute flow-blocking stress + ! !dxmax_ls is different than the usual one !because the taper is very different @@ -1403,85 +1549,82 @@ subroutine od2d(dudt,dvdt,dthdt,ncleff,ncd,sncleff, & ! !taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now endif - endif - enddo + endif + enddo ENDIF ! end blocking drag !=========================================================== IF (gsd_gwd_ls.OR.gsd_gwd_bl.and.(ls_taper .GT. 1.E-02)) THEN - ! - ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy - ! - - do k = kts,kte - do i = its,ite - taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) - taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) - enddo - enddo - ! - ! limit de-acceleration (momentum deposition ) at top to 1/2 value - ! the idea is some stuff must go out the 'top' - ! - - do klcap = lcap,kte - do i = its,ite - taud_ls(i,klcap) = taud_ls(i,klcap) * factop - taud_bl(i,klcap) = taud_bl(i,klcap) * factop - enddo - enddo - - ! - ! if the gravity wave drag would force a critical line - ! in the lower ksmm1 layers during the next deltim timestep, - ! then only apply drag until that critical line is reached. - ! - do k = kts,kpblmax-1 + ! + ! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy + ! + do k = kts,kte + do i = its,ite + taud_ls(i,k) = 1._r8 * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1._r8 * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo + enddo + ! + ! limit de-acceleration (momentum deposition ) at top to 1/2 value + ! the idea is some stuff must go out the 'top' + ! + do klcap = lcap,kte do i = its,ite - if (k .le. kbl(i)) then - if((taud_ls(i,k)+taud_bl(i,k)).ne.0._r8) & - dtfac(i) = min(dtfac(i),abs(velco(i,k) & - /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) - endif + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop enddo - enddo + enddo + ! + ! if the gravity wave drag would force a critical line + ! in the lower ksmm1 layers during the next deltim timestep, + ! then only apply drag until that critical line is reached. + ! + do k = kts,kpblmax-1 + do i = its,ite + if (k .le. kbl(i)) then + if((taud_ls(i,k)+taud_bl(i,k)).ne.0._r8) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo + enddo - do k = kts,kte + do k = kts,kte do i = its,ite - taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper - !apply limiter for ogwd - !1.dudt < |c-u|/dt, so u-c cannot change sign(u^n+1 = u^n + du/dt * dt) - !2.dudt shr_kind_r8 - use ppgrid, only: pcols, pver, psubcols,nvar_dirOA,nvar_dirOL + use ppgrid, only: pcols, pver, psubcols use constituents, only: pcnst, qmin, cnst_name, icldliq, icldice use geopotential, only: geopotential_t use physconst, only: zvir, gravit, cpair, rair, cpairv, rairv @@ -137,16 +137,6 @@ module physics_types cid ! unique column id integer :: ulatcnt, &! number of unique lats in chunk uloncnt ! number of unique lons in chunk - real(r8), dimension(:),allocatable :: & - oc !convexity of high-res grid height - real(r8), dimension(:,:),allocatable :: & - oadir !orographic asymmetry in a coarse grid - real(r8), dimension(:,:),allocatable :: & - ol !orographic length in a coarse grid - real(r8), dimension(:),allocatable :: & - pblh !get plantet boundary layer height - real(r8), dimension(:),allocatable :: & - ribulk end type physics_state !------------------------------------------------------------------------------- @@ -1839,21 +1829,7 @@ subroutine physics_state_alloc(state,lchnk,psetcols) allocate(state%cid(psetcols), stat=ierr) if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid') - allocate(state%oc(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%oc') - allocate(state%oadir(psetcols,nvar_dirOA), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%oadir') - allocate(state%ol(psetcols,nvar_dirOL), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ol') - allocate(state%pblh(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pblh') - allocate(state%ribulk(psetcols), stat=ierr) - if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ribulk') - state%oc(:)=inf - state%oadir(:,:)=inf - state%ol(:,:)=inf - state%pblh(:)=inf - state%ribulk(:)=0.0_r8!inf + state%lat(:) = inf state%lon(:) = inf state%ulat(:) = inf diff --git a/components/eam/src/physics/cam/physpkg.F90 b/components/eam/src/physics/cam/physpkg.F90 index c7b8da3c8938..1dd0e69a6d33 100644 --- a/components/eam/src/physics/cam/physpkg.F90 +++ b/components/eam/src/physics/cam/physpkg.F90 @@ -156,6 +156,7 @@ subroutine phys_register use radiation, only: radiation_register use co2_cycle, only: co2_register use co2_diagnostics, only: co2_diags_register + use gw_drag, only: gw_register use flux_avg, only: flux_avg_register use iondrag, only: iondrag_register use ionosphere, only: ionos_register @@ -316,6 +317,8 @@ subroutine phys_register call co2_register() call co2_diags_register() + call gw_register() + ! register data model ozone with pbuf if (cam3_ozone_data_on) then call cam3_ozone_data_register() @@ -906,7 +909,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) ! CAM3 prescribed ozone if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) - call gw_init() + call gw_init(pbuf2d) call rayleigh_friction_init() @@ -1321,7 +1324,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & use cam_diagnostics,only: diag_deallocate, diag_surf - use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds, oc, oadir, ol + use comsrf, only: trefmxav, trefmnav, sgh, sgh30, fsds use physconst, only: stebol, latvap #if ( defined OFFLINE_DYN ) use metdata, only: get_met_srf2 @@ -1329,7 +1332,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & use time_manager, only: get_nstep, is_first_step, is_end_curr_month, & is_first_restart_step, is_last_step use check_energy, only: ieflx_gmean, check_ieflx_fix - use phys_control, only: ieflx_opt,use_od_ls,use_od_bl + use phys_control, only: ieflx_opt use co2_diagnostics,only: get_total_carbon, print_global_carbon_diags, & co2_diags_store_fields, co2_diags_read_fields use co2_cycle, only: co2_transport @@ -1432,13 +1435,7 @@ subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & call t_startf('diag_surf') call diag_surf(cam_in(c), cam_out(c), phys_state(c)%ps,trefmxav(1,c), trefmnav(1,c)) call t_stopf('diag_surf') - ! for tranport of ogwd related parameters - if ( use_od_ls .or. use_od_bl ) then - phys_state(c)%oc (:) =oc (:,c) - phys_state(c)%oadir(:,:) =oadir (:,:,c) - phys_state(c)%ol (:,:) =ol (:,:,c) - endif - ! + call tphysac(ztodt, cam_in(c), & sgh(1,c), sgh30(1,c), cam_out(c), & phys_state(c), phys_tend(c), phys_buffer_chunk, phys_diag(c), & @@ -1840,7 +1837,7 @@ subroutine tphysac (ztodt, cam_in, & ! If CLUBB is called, do not call vertical diffusion, but still ! calculate surface friction velocity (ustar) and Obukhov length - call clubb_surface ( state, cam_in, surfric, obklen) + call clubb_surface ( state, cam_in, pbuf, surfric, obklen) ! Diagnose tracer mixing ratio tendencies from surface fluxes, ! then update the mixing ratios. (If cflx_cpl_opt==2, these are done in diff --git a/components/eam/src/physics/cam/ppgrid.F90 b/components/eam/src/physics/cam/ppgrid.F90 index 8ef5d205703b..a2bbc5e7fad9 100644 --- a/components/eam/src/physics/cam/ppgrid.F90 +++ b/components/eam/src/physics/cam/ppgrid.F90 @@ -21,8 +21,6 @@ module ppgrid public psubcols public pver public pverp - public nvar_dirOA - public nvar_dirOL ! Grid point resolution parameters @@ -32,9 +30,6 @@ module ppgrid integer psubcols ! number of sub-columns (max) integer pver ! number of vertical levels integer pverp ! pver + 1 - !added for ogwd - integer nvar_dirOA - integer nvar_dirOL #ifdef PPCOLS parameter (pcols = PCOLS) @@ -42,9 +37,6 @@ module ppgrid parameter (psubcols = PSUBCOLS) parameter (pver = PLEV) parameter (pverp = pver + 1 ) - !added for ogwd - parameter (nvar_dirOA =2+1 )!avoid bug when nvar_dirOA is 2 - parameter (nvar_dirOL =180)!set for 360 degrees wind direction ! ! start, end indices for chunks owned by a given MPI task ! (set in phys_grid_init). From 9e5799fc086b59b4719b905ed9095ea9498ffdb9 Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Fri, 15 Nov 2024 11:40:34 -0600 Subject: [PATCH 11/19] cosmetic fix --- components/eam/src/control/startup_initialconds.F90 | 2 ++ components/eam/src/physics/cam/comsrf.F90 | 4 +++- components/eam/src/physics/cam/gw_common.F90 | 3 --- components/eam/src/physics/cam/physics_types.F90 | 1 + components/eam/src/physics/cam/ppgrid.F90 | 1 + 5 files changed, 7 insertions(+), 4 deletions(-) diff --git a/components/eam/src/control/startup_initialconds.F90 b/components/eam/src/control/startup_initialconds.F90 index 68f9a2f12a3b..fed4cece6460 100644 --- a/components/eam/src/control/startup_initialconds.F90 +++ b/components/eam/src/control/startup_initialconds.F90 @@ -60,4 +60,6 @@ subroutine initial_conds(dyn_in) end subroutine initial_conds +!======================================================================= + end module startup_initialconds diff --git a/components/eam/src/physics/cam/comsrf.F90 b/components/eam/src/physics/cam/comsrf.F90 index 7ac806c10326..856cc9d23a67 100644 --- a/components/eam/src/physics/cam/comsrf.F90 +++ b/components/eam/src/physics/cam/comsrf.F90 @@ -54,10 +54,12 @@ module comsrf real(r8), allocatable:: trefmxav(:,:) ! diagnostic: tref max over the day real(r8), allocatable:: trefmnav(:,:) ! diagnostic: tref min over the day - ! ! Private module data +!=============================================================================== CONTAINS +!=============================================================================== + !====================================================================== ! PUBLIC ROUTINES: Following routines are publically accessable !====================================================================== diff --git a/components/eam/src/physics/cam/gw_common.F90 b/components/eam/src/physics/cam/gw_common.F90 index 198c634f2840..86881900e598 100644 --- a/components/eam/src/physics/cam/gw_common.F90 +++ b/components/eam/src/physics/cam/gw_common.F90 @@ -5,7 +5,6 @@ module gw_common ! parameterizations. ! use gw_utils, only: r8 -use cam_logfile, only: iulog implicit none private @@ -743,6 +742,4 @@ subroutine gw_drag_prof(ncol, ngwv, src_level, tend_level, do_taper, dt, & end subroutine gw_drag_prof -!========================================================================== - end module gw_common diff --git a/components/eam/src/physics/cam/physics_types.F90 b/components/eam/src/physics/cam/physics_types.F90 index ef0bbc8f2a02..2b7d78c14618 100644 --- a/components/eam/src/physics/cam/physics_types.F90 +++ b/components/eam/src/physics/cam/physics_types.F90 @@ -137,6 +137,7 @@ module physics_types cid ! unique column id integer :: ulatcnt, &! number of unique lats in chunk uloncnt ! number of unique lons in chunk + end type physics_state !------------------------------------------------------------------------------- diff --git a/components/eam/src/physics/cam/ppgrid.F90 b/components/eam/src/physics/cam/ppgrid.F90 index a2bbc5e7fad9..88c5740a3506 100644 --- a/components/eam/src/physics/cam/ppgrid.F90 +++ b/components/eam/src/physics/cam/ppgrid.F90 @@ -22,6 +22,7 @@ module ppgrid public pver public pverp + ! Grid point resolution parameters #ifdef PPCOLS From 817c664739b36d77807712b8eabf381c2328dc93 Mon Sep 17 00:00:00 2001 From: xie7 Date: Tue, 19 Nov 2024 12:34:36 -0800 Subject: [PATCH 12/19] Added docs for the new orographic drag schemes. new file: docs/figures/orodrag.png new file: docs/tech-guide/orodrag.md modified: docs/user-guide/namelist_parameters.md [BFB] --- components/eam/docs/figures/orodrag.png | Bin 0 -> 290236 bytes components/eam/docs/tech-guide/orodrag.md | 35 ++++++++++++++++++ .../docs/user-guide/namelist_parameters.md | 19 ++++++++++ 3 files changed, 54 insertions(+) create mode 100644 components/eam/docs/figures/orodrag.png create mode 100644 components/eam/docs/tech-guide/orodrag.md diff --git a/components/eam/docs/figures/orodrag.png b/components/eam/docs/figures/orodrag.png new file mode 100644 index 0000000000000000000000000000000000000000..de6e5cd8407274ecde0b7f2342ee75675bff53cc GIT binary patch literal 290236 zcmeFZWpo_Nk}hh2WieR{7Be$5TWB#ewWJm^Gcz+;%+O+snVDK-vBh99Uhgye%$%7u z_nr6qtygPRWmeP|k&%&+S(%m59igNkg#?cW|KY<2BpGRO;%`@bMq? z4_&?_#?!Qy0e2D*&m=F0+^he@+sDI`m|I*_F zrtSgCp9IccTFdFf2P}%eP6!!g^2+`TI%~?y@tW8H8I4TsjLjI`f%boKec*TJ z{gVZnIU5nX18r=bc-;j^|AFBBlmCm%L`wV*h_kf-siwRVv6!8s88Ig#Gb1ypAUrWK zF~6g!Ij^#~180{P_m{@ptc$k=3nOIpF{va5fJZznf z+!<`0$o@mfKjnyCp#OLzr?HA0-Oa|`Tqg_pXC24?LW9Q|BFqKg`NFx zrhldWPY$jBmE&Kj|C2+}5n%SmCV#0W$ntjy|4RFxcriPmy`!0v)4$^XmG(dJN|tuc zc7NK_5nv)?>ul!uhxzZ){%M5&JK}Fy{7io}$-gwwf3*KUsDB(l5T2juKb=Vs-mvL~ z{KE&~4>IB+s_qb{IUoJA7Z*dPC#s%p*JHS$6$8BrFj__VX@GqA;tZ<9Tb;*PW?8YCr@otp{>7ezh9(HoO-+Ncezuh7SC{desoHb`{_&%R;I{#Ao zTw7*+hEfwE3WSpuxSZmc@VzY>SeK{1e8+FhQV0mrXm&_u{BO_j0cM_77l?CpNB%ColJN-Xd<{uUN z`Hl-|W@cuX=y zA!M$<&8P7H7vedI{y^8gHJ{@DcTxY+;sLI(?vM?H#BU4#H!t{4)mFU!KplS@9f@84 zZ{G5sxW9Y}O!5n<=_)^Uoh;?H4$QfgRFM+2)cKoNYPV2)%iKa`r=RJ?9#&O>5q!MsaFx7dM_|r*eyp;`e!jLO)_lG2EFN5(KAA zv`8oUrhAKmVO6AiWUAlCl{w%`ccQdcA}90yKTO!;11wM6JVEQf(2 z@OSHYqb32r|9nII+!E{g9RL2s_YL^pdsBd2xUeW~oTYZiASW*)YjMINx_;z?Kdb{r zF)UhX!>wPQcT$ZBWFbosy;Nd`vRqKOoTdu35l<|u6$BuNNCr^j5d5}f8EG5u<98hb z8@?GQ!U=OmWt35)7cq_e9cb-P^V=YDl$uCqKmco@lnHTZ>*k+hPmhN1AEgW+$lt^N z`zx&HK#G_=FE-XhoDQMkdqepY7L$(o?JbhRGZP!xJg+Ntqu>Vbr)2!StY7iXp{rR! zYFja=+jtD5lWfVvY{_0yFd6#;J;w;-5A0Xz()nu#9Lrt!A&-P#L)ZcR1#)SHsaE0~ zQ5C6ITw=E{O;U(W0BcJr7^HK)WT-rhzwPtTMLNTJ?w!Xvv%{YeFpCuV)!Q>ff$oR~ z;%xkP5tM?I+WiiB1 z(fcwz%oIJ>a%5zK&1H|mU67A!V?PS6+1mZtp5ytD9=M#nT{QS&BH3eu!-!O&OyH_T z4Y#h?q2vA*^GB1>^QJw&2J)QLvClpQVR8p%bVg03<-O%h`L7)qrlLHn&dy#k8EZ@G zmPS9fB!SHT^N-1gL|wa`Zm<@JQFjca5Lm+CW*OVblK1WpLb_U$ir9(H5_&20CZ*7tvohoCy|A651iFKF?~g^*||aB;a4zb;X}(drql zP!jdZ@al%7bd?j&8J%c9JyDJc$N8O!9eo=)au3A8Od1)!-^wtidO4=7R5&QSNr&1t zu=8s@;O2Y3^l_KMIracs(E>z{Rak52Fs!nzoz7=}R&rFNMjd5;q?yGfdd!m}s_8AN z=>XXhKrLP%q3p{o-&DIP^Qig!^s~k-*>rSKo`#87msaLN+|2uX6zcJV4!EFz82!~d z(l--eK-`bp0`mn?b$uW8@CbrNSPsQWK8R4^2M2jmIGchc34sv&N2SM$+7N%M#AD?V zII9JrVEjcP4K5uEUIV&`_k;fHcFb^dcG%U8UrK`6{a*X*s5n76YHH53>y5Ai>7gniuQ)N7G{M-h)w#h0N@Tq9LjT@=RvHJd*qq zsdq=v-eB9|R8Wy^?uZZdpFt8WAfHoA#CRDOzA=u&L=LO#aMRPIJ;$N9n$yiAC!`@t zH!Haci&nA*!Nincy7Y0DJ84yY&60C}cad|yzy2=G`n-OAT5!p>YtK^K>@&}(L!ll) z8*?ITI9e3o#W;8Y<#p5~;W{aX4Q@t_cMwZTe#YA-BX!-~Bs!l|q zC8hCE7@w5pHZ*s>W{j7d=p)hVQlqET6^wS3r%;T%HNS{K*&HB5vs-(5LFki@^D#Dl zIp_H@GwEf8}J5m_h@JqLS^ReBh_J>x7m3ythkOZyPagAUY^b{VMkv9fQKQqpF=r?=np4=W~!Sv$IkZhmW!H4v1NG zJi~t*YJAe5AFcGYpq>(O5^dprGHnpC1x*-LBb4%+tv5VRH6?bGY!Y79cbsg%`a#r2 z*dE%0D;g>s4yMS60b=+WxO?3wZT*dRPclQ|n!}Y-^9N5{0fo_{2OQm0Amg}=q!?>| zMdcXa`y)#urt-Kj z!?o=D!sa5{rEO#yEPFRO_BE?1KpA1<9F?OOO&O&^J~8{IgV$yDcRxemCr5t}3qyvl zkh=*KZi-uAy!#|W{O2w*Y4=a)9BBQ^Ccwr;Rn{*W%i64sA3~I1M=N+MXK!~r$K^3h zjDgKI=N+zhgVW&Fh^SwZ;X)|a%@G)4^lhz#O@PcV}Z_PZxs^+lDny(pEVmHLoaBb|7?aO#MbJR}?G%D>k+aJ+_ipKSv z60Er{LHb#w>ftxD?FXjbGN!?m&es&8EZjF$jK?$2!7>lvS1lSxDcW^uIY$&1N+@_% z1#pO#VL1W+@|zAoo|;K1o|MyUNlt6bT}vF4gfhQZCJR~6L7gJFh?J(8tD>E}Jn1%Y znN)Gf-qjZ3NUCn*Fh>x{p<|-Qq4a5haMgJb!`iYz+-YJ*wE~rum=0zSg_W~#E4buo zqN!*M%A4#;ju`&9m5elK!a?zj&Ygm|QVr`X91*-AwBVQ%@4e?HMQSOh3wc?;h<+f| zg0D-6rl#`@R~xzBT#dSd1YRlj)CT^*$yZ$ub>0-Ae@=gTT4MdlgDwUWT+4D4s$kUM z2xWpnLnUR^Om=m}Q5q`^k+oOI_Ih_W*3r5qn* ze>#5Ox`zpMzI)wzM~4hZ{eB!ztAOzhTZBIO>{wNas(3UR-SJHp@KQ1xYAKuefr3(f zaoA>aPNLa;^lN36O#>qI>RccJ9Svjs+pCujZi#){YWNfS*KRqhmlC+^KhxE&kI?JE z!2vyJC=-2Fv$T<%>}-N%5?pP7XjjC^sYq>o#$!qFlSs?kq}bkl{6&F?V4L*$RtYo~Vd28#XD}>j%p^E!y zuwJw^s|;z4bqjgZiwl3L6v_mdLofnh>C}hCpkun5n`cEdQ59-B(ikcyD(39o(DJUR4HxZXwXJlY?dD*a#15kn>ucW4>Zi)n6q<2{ z?3|PK2yUOR9-vVx7L#dY3m!dwGg;LHPqcjl?d3w_Cb)P`JivHkQwc)~RcFYRdFK9Eeo||Yno=li_!S>2`UlraIP*dj;OGX!#kN6?F=6IKHVa-UjX9&Mm zuCP+o+7Bl9CU&&K07_a!QI%qU6m6-yGj@BbLQvz=I=yxDqX7yJ7Z8%LXw?$?EGehx z#{>}DhQftkFa{)J%b52vn6JV}bOx8p2ZEkNHe?dwY`pxaq|!pP_I*^Oq3RWJH{{}EI(|{9d)EA;7R+c z>uj#d{n?h%L`~Dfh6bh2@hqgyUGI!0=rA~FEajb%150+YLlybQx$PxYYdI1Amp-X8 z*;vJSj;WC1lOje1uX^aLBkJzC`~%N$=wQIIRi{;$46IbKKw&%jhb|-Xw~4>k_g$FK z%49t)=*#92;z1PzR$Rkbr`uGU4PiqHb#aGP4P(bJ)^fz!GLcE30ulKjOi>HUL^TJ6 zSeJ`TyD&n2u&?VJ#8M^V7Ee_}82N}L`@Hl4O5C5-fUt{_6l@YD;dB@8V7v1~^Xyuz zePArK=cvk7>DOZVkeR#87H7-@o%@|I>w2}NdUOSRhrk~bI_%p!88*@{Bv9~Y^&L!& zy`3FJ(0W_`x(Uy<7buVu7{y^|AQj4TxqQ-SOt+2uDn0unF?FT66rFDe;c~WkzfW7q zq`(XsIhJk8O*7C3Tigp_mZI!;w;p%D4b}k>+1iw{>6xs)92^>JxqNp`7Q?#Z0}3~YTRwo*v9Tj49+$7l~sr2bA&b(W_V5bQAKL0DY;ohGhs&-yP$Q-&dnc!p{lKDrGeDU%Xz__zo`5fO$rQ zsP9DyAHR_{3CAv_e(jG?b&wEOZf4Nz${swS#479f4#Ag)dcF;AZuXPfD=@hZFJl_9BtiH`o-T0>L% z<*P8NBrKbJ#jgghuonqU#0WBr=$`0yYsII+U-09j6ZM5Jxv4n`W=&ci>eT4TWIEcG zHyREjlKSEq?4}+AYVkQGm_eF4;r!UL@k^$nl%wluwUY}8sZM?IGQE5v!(?;c@=P%x zzgC%@&>d-PY)L1#jA%UhTEBt2ewJ-xX;s|fk|1ais$Ec3O9hfME+7S3+~)772SEP{ z?3BB3so{S7MKye#QdtFG91OkxS;UuyexzkekGOLK%5fV56+nvOv{S?ogbgRem1D2q znAwIE?j@2B>|!(Vq)MRzEVQ}vNIfqod0H~qgxA&mI*eajQYlrh?imF1HDqMnoUR64 zTYsh&3h}GE1a05eIvyNwRtR~flUM0BE-k66YOA}Z-k!{_HI!q^UlBwNsbQ4}ENL>~;VWWi7p}^@(kwYydQ-(T|UF01$YoB>Z`+FVjy#@=qyWVo0Fkle` z1X+&E8WseU(cm?95an6={dgmxGiVsA%7=m?4{Cqe`l%>Q9;wc>Q8v!CTh7L%87I@* zKDfxaJ68H+O6xYmPz`zc@!mKm~u;7{o@nQ<_&()yiCsvMF#DBW~ijs+1ZinBa+GK zcQ}>PuCRAlh*1+;-(C&kCm`=gtxqX~dY0!SzTvMxBK7vRyHW|_` zbAVB3s{%R+9~+4>MwDd9yY{@a#pIt)_1ubueu6%Y)=*AZ`QCKL zr}9r=5wDw;sw%m0CWZ#m@J9X@LC!`f*U!Lu+_{o^tBhC6X+#~6WpU^0Ht#sYRMU^H zRnAr^D%k~fttJu5F)G6ApQS{;R>Qe&O=|3i^SQqn8ci&+?6)$S?WczCqN3~?aoJMm zXReOH)j@==GgGdwX2V)2s*Gasy89>AX9X-5V6nJvL$q)0~7DrE)!4XZ1sol-%RSqCGrr$?z{gjD@sQ9qCx^YEjf1mpn}|B?dyZH0iq@!Rjtz>A+qbbF35T8=qST}#G3YJpRj3I zvwey=>jVESPY=BG>)eDMCe*97P;f_{6HUZv4^4Hn4$<-3HiVxS0iVE| zd?*2lk_RFKS~~SJ$b46nI_+H_&g&BEiN`}PnAdaLp2f$lNyt@J)o_&wX|2*$z6o_L zVpUO2KQz6XC$CUov)w`*2yVWD?O&}6# z@$3-f34dK$=gm*R-JR3t)43>vx;BsnfDP-Gx_Lf!YmM=Fa#kI3XpU6>hkfzJ^G{jM zgAf@`KeHeXjq+IZ46H^np44TUEts2g8>%lIX@q`zQ%luF{%d;~_s2|rmZ0Aa@5YDhlouS_k3__$X@uA0Mema$M zoYp21S@4n(3Be{z1fkmG)t}gUt*h4-ICErCABDt~3&$taD+EVvIq$b~m;rrd+7}YW z;-*Y3_hMCloKs>47ssZ0e=NoK=0lQ)bXZ4Vl5VT7s9&#Xy@snyRSILOVb;cl%lKSC zgC4=9jR+}Ze;tDn6*090mP)o(Nw7VSup>Q}1^rLtA=w%yD5;ayeiB2>~A( zjBfNaRq}S+D^C&V1^B6>f4I67x#@Vj^^~AsO&jl=Toboy3hpwBX3+ZD z_w0?8LMcF7#7^RPpmY@MIQcP2Va`1HbrDZD8($n1BWkVyYyQnL16<%kL6{D0B22$( zdK)9>tcO6x42mSRj2OtE<}z$pLgdQ`X$~3suB5F~2FxZWU1U|k0mY@T&*tu?XLE9F zuhk%{aLM1mk+H2Jw&8xjG5Z}II+VU|R&bRxD6TU>ULI}9S{ZG-H}e_4(lOBQbFB?I zhTkaJWuB<8c;YJEg|}f;T6MtQ2t4Ta7#|o#=m{3-urtY#HBnzct1ep?9UloH7zpMJ zZC4AtQ;u7d)l=irEcE8vz3DvFY*CK4`}h&=M0;tn-DSKfx+IY%RsqVvVpxz-D>l>IVm^ZNE1XF2RZ2U?)QYG3-56dfgtm>9l2abfP zO#LZ}cTihZm!z=1#A@fco=Q(b9bU>!zHMMjXeT6K48jzu!Z_{ zH#uCX@Z71kY!=rme*GCtw3=TdfhAQ*Kc126*VQGRrF&4fhIoM-kXcupQaS3Ds;0WQ z@|={W)eQwx`b3*cHhCfV-tJQu|1o3Y+Az9j@9nL0vvGWicVevJ1N=(jgNaB?*LP^&^}bbcJya5BLx;Q;k?l5FoawjU)2btV ziN5D=6|bX^QP-adUMngsxn>y)wF)^;V6^YgD<8QOdp0a-_Ek*ihGSY->|#Nm@7Lj{ zB3b0|YDp)LG`D}-AewPGJc(K-%fEO6xG7J=zq>UMfQ(LvEnPegqVLbjlHSaJFDvCW z5Vw6U#-cUqryw+3nMpRX`@xbn{mFImQsi#hFB`yjdwk07!LcbxJRZ0)DYTVj{R3^C zH9D4s5l~s6k>@k6@U}789LbwKVLUNH)4PPu8aeOZV-8^Y{P;pM6{m9_OLDRak>|4d5E#8oOy6)^qJ;xt#k`Ch zZKVDitJbD@1Es5n^0TYBD`Zu3RFSwYg)x^n5S`#m^OvBUeo#Qx;cetR*1RwkuF@7z zC=2o2dJFXkHN7MrIRh>*;CDoM!aF_zX)&tMddnL+j=@tIsoNEtEk9sQFs_jUX7Q7QajQG2OSm}HS(a`hFn7x`!fI1!H6@K9{xRub5z65l*uxx%4h2( zEh`ho9*0*97ct%7f4{5)FLe7Y?`Q~xgknLr%=6YMOnSr|^hl>Q8*b#7V`Bp{mlOCL zi9g?I?%D>lts;{T-Ub(z7#p~jZCw6%_HXMa)l=*`)$`l>Gp0)ri#!8rYFkE$CR<=e z3ZbvDQnD0RTsIxUZ+~S+(Iv&ItIzeq|3cVV)g!f5F?`B7MG8Ui9lx}a#iR2j&rXZJ5+#N( zr-j=mL=e>5dA~a8d9|K7n73k7x^9-Y=-h~CIsgrAsbE`!be?CjW;5U0jH_#%wKbgPR=#;{AW98w8Kr_=P;mL^zM2@{p?9Ky_$B!+tLCr?U=(*Pfz9JOt+ zW{6cTAujlL>F4DNQjyjW^`}^Z9U2LW2H4Mc2Sa$3`RhZmA{2cq(hrmPhnsI`z(g#P18(Czo!?$8V(Ykrgw&F3uOHyCo$sUWSnbi>jI%U zmXn!Y&lqj603~JoTTd#o&K})_gd5{$`r_57k=RwM8`7vIB%YH()5g$vK6K<+* zEkIJzLbN{U6MDlKlpU)rnJl5cgMw|oiV&v&;v13=BK|DWK7`C~jEzrPh}giE*n{-J zm-{_b(wYI+siBK?gbEq=hvzD*m%rO*%d=1uYH?=H)7BF#PCQ_brF_bM{_5Lo@Tlu$ zTy0}pd{V-M=(XGnszuQA{>lhRakE++{Ww>`qGixQu+7qqgzF2O+u9Asek$5H;+TX_ zn>F1Fz^!#Qj75EP?oM=m^KB&daeoVFhUp-}OQ}|0MwTP{x%sS46rZOm>6Sj=rIMkg zMNoI}1@?M&HI2?dg#RTFx+ogw0`Hi(Wn(6kJe#m(F>k7=^5ShKQ9^=Prl5hDs#8Dt z8<6Q(QpUV`(*2N-??3}Zn+HfDzQN{d%Vcikb;95YE)&@RuK7N=G4$yPBW@KXc(Ob8 ztG96*AL>4VlB`G*ai!IQ<>WIiyK-($ynt$$W{l`bt>`yIdVCZ%9or$z{XNJ_o$<~y z`fo2`RA;a7iyUJ}Tc?S`$5yzt<;$dT|25x6g2rL(>ImaZM`Pi3x>J6holOtrB)P$q zmLPg%3Qmk?CqfJSdfjj~6V%c~*nDJOobF1ka!rPAVW`*K{sqFWp;N#NtAnYbupC0A z(i&EU#5=C4(yH0X&n-&ecII6(t$A|EdohVr?bw@ZUB88tv>_*P zc;1>{A*RWS*67I+VpXGxcAN_ubzMKyDF04B_h6)K)ePj#m=n zE)YqF8c+06?ez!}R)d)PuMrSP0H$3T$1X=fqLvinWO=%0ru!D!ET*OkGK>R02JO^U zCd^*Qho;(;z7Ks5Nx|Pl?o4(wCHvHc;bmW=K~GMOEM$6ND8r=qGaTbfMpm6g6|=sr zpT!CGw$EAwfleAsVce&EV4d$S1EA*yr~3v$GoJVmkknIyjV|-L!~6K%!T@G!xqLaX z44t|f_`xG@br#ACth`Qp3R)&!+m48{vEqqxCKYr1&GOlI(YNc}{zRB}Uzs^;u=98f z#_MSnPCY=~1ZKbhF{62_M-Wv-Plkz+C{co5&M?4Vy^zmc5jSwWcv`rFjm?J7wk4?Z zVMW^Od6DZZa!voE%4pjSPHPnR-JZ|cSK_nCG!#DDn zXpgx3hjJFK_eoR18OcbjtlpB}tCzLorPfX}=K#&pOxtxqKkp&q_1J%#UU<+RVrEi- z-= zvyiPBX~;~8Iz?F)G>kQt_5sU3Cs^ zqya=YoUE69fBPZec1BZ_RmWZlz_s9lURQ(T;{5&^RdQm6t!I}4hd7jhEhEb|FeDN7 zVrcz*WwiE_3k08`V4@i-z+s-b5r<_;nHi2WqT5@uWGVR7b$jN8E|RkbYdJ_#TrJ^% z@n9*FufW*ml~+w?7+DWEc?~bOBWrWBlw+gk(W&S6s5#;UHiku-Xb(o(Dk;tJyCYH0 z{1&0OEUZgVnGDlglP&+R1|FHv91KVmx}IGg!QAWHTkt|EO9dD&JOJ^ zR3cUm-}W}U?m_5i+m^v!V{Is2KhKa|fWLpnN<;?H(G0gPs9bHWL$7W`zb`RAF8$Z; ztRE4CWYfh#!DwPhE#1=c>S}j4F4Y`tKCI<6)UN6!Zg^jM$a%{+D&Jc;q1J|2tYLqK zJx(KTX$qFpR4gBc8Tb-{Z!Nb2sSf|bldunsB+P!#hJU~+4@6%&r44w;d#=fGntOYg zHeyaTz~WMnF-3;iMf#S=jPyt&wT$R{L>1Wmge*wv4tdsbW6J!x7h2%6*mwi294NBF z^K&T+7U#$?0!0n4X20#E{W&F0RUOJvEJN{QCbAAh+t$FgI=ag>M`axBA912H>nk0Z z$sL5$A}v4=|4S1}=f#K$Hl;-c6C=jlsV$6%6_qv)H)DCUU>=bXBb5AP5*|xhaz@-2 zmpv|$$eUfX8taeXg2Nqn(JkGrBTs6PwwNd*zX5r4TQ_uQ=z_w)4y6ZxL*n~G+$ydSRu+|7|^nZ^9F%4~B<2!8nu@G{;j zS0znpQ=RDH@TU)6uv%rsabURU8vpgu|ua8?OX`_@Yzj)_EnNk$%P+-hseNkS5?87 zCSSDGXK*QqZqrDa;Ur|<3wtnX=J5dK(fB^Sx8G`ZetrBC1kgnY%?=_bMli7)Toi>R z-$iw!w+;E#otQzPuB#MoE$9vRUFP6PWfTWgU@qst^qj|c3N!Kp5-i4_J-#wv{zaSc z`*hM)KY52K7l%5ySL)pC{_PggyTrHwNxn#43PcnA+o%er=uSl^Z1hZ;54c5=J|y~c zTS^IR?<4C}U0<>u%ln42<}-Z;+|0D9)Lu4}$Uy)Kx1e)EGY-`1tz2$ofewUqd3>lV?hj)u(y<X^AE_3h? zOqTJ0);UX;t)S1RWjSSBt2RITgi&?YEaL>&aPK+db?7H3XZP^A^V81S)f8J+WwSko z_5gVWSF(@hu0!%DX8Q3K!(Z6JuHeG-21fs$DT^?d_;|tcuZHXW0Ax%af2Nm z$oxX3$zf|_Sr?kAy=JoJP50=&ulHAK*t(jta>2-b-;kr(;rg=Z79Ln$r zY20(@wfjk-A&acp3Rpa8P&a_Zpf`MOD~}j#6prU}ZL^Z!yVNO5v&0_H9=zL{v+z(_ z1%SsVsCF13uWgrv^gl1n{W-+!~is~+jg z%ChIqjn*T)D6-?{z2dWrpI_Hb&|&eeT)tllWrrG&sP`_XacMcgnX9Hx-k+=?K-9!x z?vbckYxGWwEpRH`cObuiL$aiWPPF$gemE5M_AwuGLk$CcO0CkgW)sXXbHe6q=bddc ziM<`ZKSbtsVxkpp6y8xd zd@AY!vcU0zAQFMb48*TWZ?sbANwn-FGjd4BVLOARs4kUds0A6WDpJ`h7E?y(>}e05 z)9*0X?$!{S1Uoy>P#C!MoR5*g>=gTL2@zsyYQ;Xhb{P!1KbDrNN*Q-f^-Y1p$g7;r zhJGheFfqp>L)h@$dBfj<=OBpw3N^YjA4+&Sb*>$hs$Smw1U6G)i#6K;VmbzM^c?N@ zvLJFhON`MxWQeEut&fjwwoYL;YOgURPxynI*O0HW$Ophj5YercHQ@b1F4LHGR>P0g zG>XwO(=GxgL5`f}lR)xuC8T!Z8yu_G?GtU*^Q!2vMM`x|xQ-Z*3?8v{q$f?=qV8z5 zqXX$=ZE-M(tU8N{n;ovA!ss{l^23cGYU#C_a@9wwW2(>JVdRJp8T5^brZf%5Q#Djv zahHm%V}VEtVxfow8rl5)#ak$j8;N#q0=Fq$`wBY#d(q9pYYIP;6teh}Rgl@tC;MF> zKI>D;O9XFyx2^~B8RNJ#r?<<7%!;qF&{l85mLi6S5XkXoQCA{@T&_vb8X8xkLkSNW zHHGJf*xFE8aWhxYMW4=^yY;Rg98E;U7O<){r_-5-muhRJ8Y=@>h>a=a+`Vq;>li-W zgKG3TwDo24#PO*XoLi6TUJT-T{NN#4+Ms>H*-MDTXV+jDT;en-ac9^3NG!ferYp}B~E=p{;g~KtijA}mV;4m!Q^%IM zO*~*s_CO(vs9&SbHd+MhaAnz--13QtQSk7Ie;MC$Op!PF$C%>Tzc+GZMV!9T`@Uk$ z6JaOs_K_@q@!13N*>?9nv|^N}n3)iLv8b$zGT$IjrZOe`6L&{;_r)m0GRWK%5F`P1 z7$+t-JL>%~--s}9a+!YqTZRAw%V3(=uDYv>>+=@=5ImSY3nlT5M zclM-(?BgzJOLG;Ky7r)1#cm<;U^W*9WT}gb!CRWg+7_hAj?syDV$O_FIivDI1X1p7 zL?j8B&ohMUay~0}uT)xKd#e^w$a-khnl=`oV1eVIn(N9hI;}4z3k-(&4T@~iC1!}u z_#$7(EE2dPd)gOV>wnmqzw)_|5P3v1C9{d&z_SbenT^}j%0Da!X7Ug<>e^2-z&K&% zRuFr-SW{Bj&!kQ>3 zh#WlliLkZOx7Lo@LJnBhIiuk7ylV#HYr>RE(c_0t=pSwCRYby= z3KO&&)}%gRv*hDD_wTYKDy&Cj$;()U%b+zT#HmHMe8CC;RxRtUwI}n+;E$PmkDJ}! zJ++rjW_R^b%I5%?e7V=u8LEX9N*O*oA$ODvfB$G{w}X!>RLNtBub9D#pOJNiiX=5! z4QIb`>!0u^f+*Hy>^NNRo4Gu_wg!i>h(CYFy{*q#lh+u@h}IB{lrw{#*AA(2}OQJS@^yWijT?o@$i)hJYSmzLzM{x7m^2-LaVISI-lb-|5oIg$dJdz-q&Uk zG$2hUFl9ws9*~`O&cwfylAJ@s(-* zwLI@Antp3&9G_C$`$ZI9MzaJ1J<)8Fl4^_;zovVi#mj8Y8@64tbn_w@Dp=6XvN&J2?v+jwb`(6j=vOb#qY#gQ(W=3 z*-5DNd`9EW?hgsf5wL2Tw+vqMWBd+PDl4jo6SI3UorFstNrAGk6^TC}*F041I*t?b z!0JJspQ!@K2u6$6M?ZTbPQQq@@?TkAM_2ailDrIbhC&(Js`sO^96sUVu z?SAlDgXY;2VPHgwQX;x2m4^u)oRCO5aMRiS8Gu`_g&Qxuw z=n`j<{b%(e#Si|%uzi)NB90^e%6w^rPri;1x$qDWc{f2xeMuMD`MSwb@p{j3EO&>M zdG$7~)AKH-^1-d?0*)8O&G!mHXWOM)gA=?LLgfiCFlUhL zl+YA1*hxpjV((qLZpec($sI-L7AA}R$OL)`(!RF}wwE#VGB5ejft_f(VU@A{POIYv z><~QZh17I6yhUV{mhBWcAMMQ7C?-z4bEW8fGlU`q7Y ze42*+I-cu&E+6bBH=fC-WTP!hX@CwU7U`R)qAm9e%XJ~rj0l%h3Z3EmZQ%t5YP==> zU=b-owqq3wE=-gsV%%ycp2X0fJ5Qq>l*%Kpa}&IY^kMbtOj#y1`1+=J&%#qsqcW_!@o`+b2sS3z`*|7I{a28-@|2uw4}*v=nPoP;fsWbo z)=RX2kZ&e~UL#gtoVaNI^&pjtl44T_fMje$2l>e8FxRt=@bUZXp89Jd7-8CKsOT*^ z=7VVs=AQox8F$#I9RpvqfyWuy9kn*rI18qYEwRbD#}~|Raso7CQ7f@)$aR%W0==#{ zv(s^JxU}1uy5FWK+DJOyV+~f`I&2Q@m!~r2Jb-f`E!RtsmmNn zW_;EKja2~Esj-{>yLHFI*z?)l^QL)HkRfla{Ktg|)9+}%#n{7h9}dlep>V^nP)D2E zqL$Yv{2tTf)A`4jL=qcE*|z71T1811YNQw6+|wIIrz5m$Z3kVCubx+G{akU3X8n|; zHYAPt@g;Xf1k5~KVqSkfRGucqY0M(E^%YZ>9~yQTjv0`+Bb=cu3mKyb+?7;oM%nR9 zH0$Q5=Blz;3Q<@FpLVXHcI@oTuQ*pl>0~=*jc`{x2-Nb@plHYA&-w1_GW0rJ&yB?# z>@daL!8!;4hR{2%pGtwW_$aDkawDHo$Eome>uzc;umQe(EPQJr7GFjOFrQ(N*CwdF?$4y!W=is*|y=`*q{Ngy zml1kS<4K%G$BtMSGfz@c!;4}eRHzFH-xL?@(o)P;bNP@!vc9(__$(l%eaWpVL6Nxj zAogYuIrE<%vlu#&3bV-=PJx34lj!L=%%Y3&{`p@3nZ&exnpxz`n7MIUu55w?2rMng zjU=JoGYvaEJK7^li%Qs6V#~>j@@Ab(0g5Bg1G?cMWks$J7 z_^4!*ec_!4o1$9cnBz*Pa4rOTx=UtXx_C3 zg^#X#UtZ7hP`WMlleG}BF?NTiK}mOK=88gWS_3f8M>xxSvBQCwV>m6tGhUpRHs>q13+a>p=O-fSm=_hhbP z1R3lVjwuG>*u&IvHDMToqm!u}Vwni*?XDp;?S9T17M3%M{6VoAdc_=3Mbr43+Q$=` zAaTw-ELx8>E9ZN;0d-LY{$Z42M^K`@m=Av@0AV$IB$1v{43V?}Rk8r-Sj%Q(yj?RE zbWD=9FIp5i>BZ`FY{LysA$?<;5l0$?XBdP00C8!s8_TJ>S6V5X%nnp`#IKy;G|q}$ zs%0~ER$ze^JVVs@uo_eHz%KJY6cR+~0SEky07HHSwOSFNx zTMW#cG|xhWMTnomR8kvq(bmNvJ&(o2IL|1))eG113=99bU(jG2VjSzk_}!x`KF;Sul%cmzBG|3w5e+I;5@ zt(3=@y)If(ZXZpb%V?pA8v~yPUri1f*nha!DC^(5s}(RIEMYgff~;cZ^94gX0s8EwhXZvpcIt^1Q8Ds z5Y|E}{h5jVEjPb}0E54mOyXmd3*{kPxB;3KbavR2uqaI_C5RSRX?*| zp7aBkC-;I#1F#L@V@7(Y352~zUVP8aJnL5c9f5f<<|LY^BjlL~Gtv=Z(jkFM|7su) zrhHs$$DjOnyXn4X?5>+HL?G_sgbC5gIwS;18%kB85py9jCqpbZ*-&1i2rw(wH`^gU z`-43<=6$@d4}jOmXObbI2Fyf~k~Y0xj{x}I^fh+y(bw7q=O1K$IPY*Pz-%alR;&bg z?S30;#N;Q6Mi?u#GV6{@y5YJe9WD@(AQDEDg=C!sBt)~)rL?N7RfXI?cWIMf0ht%n zyhwtH4DX=SWe<*-WEcJMpH{Jko&6BHULfru1A0~S%V2%0Ga?WP%qlyyFU5c)NtQo@4`o@fu? zn-MKU2qbN+OiQ6q2go>bGe~i8t^K#|1xSz)9lF4-03pJf^zi~a?~*%g@;eLB5MftR z%*2ui>8f{5vqjHKFeiWEc&0Tnd78_F;+h+uwOj6f-fp_`Ec?k3dpe<7RHo`h;JcMF zqW{pD9I1OsRj5n3x~g2ZU|OmLH~Evl`kEm8|b8qpurGl8Bkx!fjqndcJt1WGR_L7+W?t%wcXqsqG-2X@GOh2rCTXkQ4zvBFE zLZec|f0M%~Xi3u4KxxV*eX__ zW6!dG{Ph=h#)*4?V~}r`ahG$h@V>YTVXM9**zAYD1YC#K)dhcf*8X+hlT1|c7mQX1 zc8QD|n$*!JSx2<*Yn3tx;|#m%nrH3p_vYK9x1Mj^I^zRO`WQ+R7|3OVG_&K7B65A8 zl&HVYAkWfhls0-Z3vYN?B{52n{t8F1qwTE19PyINAFv1RdXv7CT}bm-L=X$iq%{QD z(Q>G-(rbLy(^0dW_H`>n^7B3<`~M_}_Hpjs^L zx?%V?%*>j_!ZLjkgouQ;x8I*{jb}qFQBS3DFWDi+09^se_wzGP(+Yi_=CVZUDg?m%cL#1-uelXG?16189#ehuSp}%PJrjtCeCj z&bGn)b?fnSZ1Q3Vuq+l1E9wb*5MZ8O>VA3SWW+Qw!J&GpS|+oV*Dc#HuWP3vH62N`&uFIl|(ww=Tk12 zTHkx`yLQ&4w^O$mQ|T9-Oru43`b1eiWFzwyFh12|ZeK?quZ0}RPAWGojIu8~ejKxK z3&{pYeWJGisGc_exdq6SJO=^&`fH!soYOG>UAe&SduI`2fW|i}M`PHII&3sP5j#N2 ziLgZuMc#@q?l5>#9v~0tF75d&a0w&dY4JZ;Y*T$@Y^U$nsFOhW41sl6ZdY--Y*?dR%HzmRjY(ty37cq3^F^#G zN6ID-;*rIJOy(#N7To2Q64uj-kWKUG8x%zpa$MuBp*fvOG=Kf!5%36j1Uv%Y6$ApQ z>${SgR63;nsIg}HC(CSY1wttkJ*{MGQkG<}53yP~YP-RhU84nq)AAgAia1|%8o1N{ z802+mGMmK&xqyu`LJ(8g5I2qZ>rq&ta98f-Irk!Y2#nd7i%9b*2t{ur7QiU2uc))5 zPQJn>e7Ka!UJ-;1!f~XEF`kKD5@}Sc)CeciTrx~=oUp;vQCd2djqs7v!Jc__f=!(| z%^tqv65D-;e#C)5in!r45fPA@(bR0fdAZWta_~EhQ|p`Wcm~%+Ol%q0H5ex`XLPH; z2v1IHht=GqNLp43lS#BE@txAtRAfIn^^f-6_?vC3e%(nY!ilhxe@mj!Ja~C|o$Yt{ z?`+mQR)I?pf)I$1et1SC09Yq54{;hb;*1b(!N={WhokpUp7ygYwev2x6I1jRcGYiB zMt%$4Pe9f{Z-8&M{Rs!$SN~%yi>3%XrP4$w2PcFEu}s)CCzLM!X&K*X0w6Rcg&}@@ zCVy06KRo2m_R!tu+OFFVB0a>*WJQkPHG!AU9+4=@j}y35Vw8I=<#Wb`x3g0t8^vg| zlz26~8Nw0d01^^;C~{hv(&|ehF8g7Uf>#@h55v+enZFNdr`0K^O_h8ut;8FWQ> z4k1*I(luGvCKTGxMglClNUq$HA^^o4Lr66>MXlN4fz}l1b=6Vn)Dcw8;P(dK(r`-M zq#WcA^S6Jx-)_BcEM`*Fvm$&Q5myL_D@hzi9kfO@VZ{k1tYk}2i{Xn%n{pTe;)131 z_M;>IY}Z0K{Nj`Ynbd)=G&o^znv;|-iAhSp6A4VdLf|j5Ni3k^Qh0LouN^xBv+Nk= za@1E%$k5JGU6+>KrVq8IAmggrs@`g2k3avO{rKnC5e=GprI3%{8E%H?m8ya2I3`(v z1|R2WBqu0$x2!GcvY?~YQ;t9T&As;Uvy<)Fdwz>)snQS-%p!8)5M#|Sh9V$!D4B{| z_2aX}tL(~~##kferNsmh_en@yL&G|jz_d70Yy0hsvw5^DGaDf&aZ+Cnv48S8x7)ZE zr_-Jxev1%@AyQ)y?g{0eNaZwNe^nMp*x-e;ew9NuIMdI(Kc&+4_~9jX-`(fgk^Afr zXk_p>lD|X9O=hWMV_$mDPW{DQRtdRj9l?S&A|FX{?dph-?fe0-AOLgfs(mOsgXv4L zo%7oV(MBLYY&IZG7^i1V(&RI?0TbOAlXGV0lqkN{&E5ZbVKEw5O)PV#$HTUR~XZ!3k$Z9KBTLJCs0kn)yKK({Vgkh6KU7^k}Q4kc& z1i7F%zyX4nf`*txgNeRDCSRIpB{4gkFlmXM_KUyUxCbugrC?D<^(9IhufvUoHh3c0 zJdc?sj_mbbQ*%c<`lKt-PGTa0SzbJvDsN5Ll?Em!8MLD~6Z3cmWl%`ljrFqgF8&uL z;;ZbE-yBbJL{yVDDhNG`z~Z-H0VnE;YiIlxN%G1&ACLw%i^%Ivzkom3`U;0%9AY+( z_J`_;`gGU1DsP2F_U?pvcIj33+nqQ3k~^eJWeo<>*wTgv4eWlMY92wf!i+;>U<14O z=3x`4Nxs^UiboGE$8Xn>r(A85KUr_qiMptTuQ(G(v9Hwkq{>-isPdy(E2NL=j{q%=NU^5^Pa^pmX4d1Sh^)Ak{Srzz9 z#1~{DKWU##_}HEuKi|$ecsthDSlywH#v#q}=qHN0^tApN+*umN3mQP|eZ{Kzi2b*9^8SYwOgSG1x46<#(SVQxXQ z^}yA{k9O%{)0fPn#nY!S&b`nXhcRX6lW9l9S@f5zA=f~cga)P`=~+jbe!$;M1ugUmpGL4Wk* z^E2#}-TK>|k56TsL#|YxQqyd^A2Q0e?g!a~S+g`LC1*p`A-}4>OUJU|U)PO*aV|;# zd5rN#?K{Gz{sUr{gC!+SY57h&XsFguMu|I8D1@r6%Wb3O|}N;@lWxjC2_kM4`c z_aN)S<}am%BL6b%>Kn$`ESb?m&dR5@le-w-MA60|wz9#fkUDx08{jZZ;y?>; z&9Wu->ihGoX8a^;pw2|_e;B6^?>%&Y9ku%~l<$zp(a6k%BxTDT%+&!0B2A0S5yqMV z$nT5JJJg1iWn#!BS(F-s94T{wX0-n5v3g+8W9Rn>oBegQuKmg^QB%QK(rrU(4<4T+U8F}v1oq9suLe?KKq_^!pdI(kz`PQi{ z&x)uQufOt!-S*T{NO$HFkl?NakQEq`kh`0$v`a_w^I4EILD`6VkxDdDF~1Ko#GZKw5(s>d2GVqraHZLvNVr;7hmSeqYMb!xa?611OeU*&55YlNCXET})-lVr z8rI3WcgKtY;z2$QXU$z}^FG52!jT#bfFe7S9c}sQgdO{{tL(W){%G3`>%zdvB$gF! z3C%Ht4!7G}8=+D8&?<8k6Yx+1r{q>+qqps4JMGw&ReXdv2#^H}%kAayvoQtLgp)y+ z{6-jbrW3qYQ{p0NVKb{_N0Gh$_0V%6MtLWI%E+?&3;ERBy6JrC6WN8+?rjJ6wB1MbwLU#XKAFv5U1@Kk$@S?x1PG}eX!Vw& zT)wKp&bjz@djV3gTPZ}52pyG=G`r9mZSNOOm?c@Z}8%(9b(W%lYT3+-1I-ERN5>gULFXr-cpIATCIb_!%i zKJqr_v$c?KYBtnIzNM=XX0qQ0v!yaj(}|GtT%mOM znRD@s9NYitn#b+dTc5LVVR!NkaVUXH#4wyrA-ltGwPj!0K>>mn{;DutUa+VNA8^a9 z9{;2wRi)t@f?R8im)SX&+y`+Iv7aBiKj-z-wKzNNme@`sv|}c|67dB!e?=YfNMI8c z1IbBU$w5PSSYO;5Ae1L$irQSv?vHS5;F)eOrhB z){eFlX3dQVyIGKpi9{|$@GUm(g|{q>Z$v!zW0FfbU<#H%E3TB?8@Jr5hxP7-uT~Zu zs+g?In_C01zY48AHcW8spWNfWsFt{oIpsPVbJuU}@cp-^j?uQkT78Z*O=r(vk6HMm zkdNdqvk^Q*I3t)xDlDTZ2mh44Z1kuu_~R-h{n@r^MUzdOGRLOQUO|78fS9c$n@kYn zXzi$8tDmFJXn`Xp6LQ)bSD3^>fidaPyrnHRA_?jtTSF`uSgh8Hm|%46*qOA~+4}0$ zwr*jw9dYtr&Nrv@MLwnf`TeC2qSXRf8fFnjM3>^`-4R>n+upkjwk{oM{}8ZINYK^G zEA91nX4{;lOtgqA#7>&h%1p9IGXb|2AJ1BfuTT6&x$=SlpudkoVroMP9bul2(`SaM z*K)B@hxsN92HbqqcGzwU8{V%Q{-?q$8r9fGbJp18>5F++^-EfrRM>D8R?<*+YStj95Q--El%cT0;iyw5G8^{-$CY}-cLTS39)NCX0wYJUHovj;wNaOV9i&r$- zhaWAn*^AdeKG1%p5z1sy?iMb;={Xy{!wB1d&*5O&?8q4Pm;UewY;FW3hlM3?(Ls0a z(%X(ZYzzC-t?#k!sD6q%4vBHmh4(oBu*d8?3~7Y6gDlp8jXJVe94%vvYobq2vI$Kz zR&Jjr*j<`_^=ln8_Spc_k5L1?p@x%k+fG;I+JplG%ucS?(X)E-0Z{F6pm z8GTz+mItJv0HS5B+-`{Apbu<0G|uQUA88xrp<$Uc-sA zm%8lE)wduQ6|e|Y!~*3J5WX*c__)=uh>b99(>_>WSKjitO2p5Tal^qur~vcd)(?n~SRGPchN`cHJ@ecrR_$bS#^~faD`uzjOU^&qM)ZMfW9*bQi^dNP8TDvZV%MRf;#o;MIy9ye z9E)dpXw=2f8tgl03p;eTK6dkyGq4USVy&{l?z;O$Gkg~s zXxD662564aV^BA$_h-a`k_2N%BQ9+!)~~UWp1qJOz?cQ=2%GL`!=c5iqqbuCIx8cb zTo$k7V>u_c5g8Ksi?j#YrW=;COSaOjF@ipP%VGV=z(?dq8}%UHvS26+i9`3he>B238&Vtd}>Czf;jikUvFehc!m(9mcap+PC!l-y8ofb2r9! zcEwI;k(;)3;xW6}F$ZsrF+~-K5l<`&8J0iHp|n^U=S?keOM74Gma<5)xyt%)H5k_h z@31wFG#WL2H`@y=UZ3)V9g$6&Ao_(1nw^mT>&v6|@XPaD{bcEqj4EHL1aFuNf94VJ z2zUfM0{>+MzC?of_ERU)L%Su4Tw1Xj4G#&54Dbwf3@9SVkdx5pDAL9YkRr}hn1PQm zb(4oSQPJ*#A%vzZRz?#zI@SOzGl}4bgk4SYh>GjFtX=0MEdTlPd+hDE5R>pX7jlzb zv|Y677j3YE4j6359=sJkUkF>8HWFx%*kpG6E{>i5asPO$sY7Fu!Nn* zxqq_>&)vWP%mkYVm2~A>lTrzZt%njs*m0anbMfNe?QOdZ@5ekJ(^st-Be-nUzsQCS z>uy)xJQjk0i6tw7aR|a>27+sLzD=8fZ?LLnRz{UZX~;pEkk@}c@VZTzwj3b}LQv!o ziB!I!Tp5z2+6j5&>|X4@^^-45SxN4xU2r|pAJ)*@t;AUHv4Xx57Z>Z|@b z#`eU_rZb!2gjwxeu`b(gyyF!(+6JB_hxkfFR6)_M%1%6Xq#bj>md@`?1QW(4%4hI^ zLfd=C0rv1SQ|y^n=CUG>uop&BL~Cir2TSd?yT;fR7oCK#B>F@LfBEf%I2Br(gSiBG zVV7nybjh#xvt5Rjuu3g65lRSW;|a`>7w_L_*W59V%|nC-^+<(}02jj4=<%@=?U+M% zu~FM}x2CFuUHr3M*ra8c&4S>&@S2A(8Nt^LX{JCOxnzlIJL-pf+8!gjV#UsGldM+f zmvu$Bsz;E7VC7MjG1IIsl!xSVQe=YsI6nKvG`r$&4_K(A6K{$bqz0(`5a>pXD6n6h z@B{0Pk5QSfhbeP%htu|$Eh^vIZocy!{PBSu+9P-!LZPq{%!=$c7vE*O4jalwLR}%( zsu7y^vSaq#iXGP)?3Na69}G8dlRiUF_A%K z;aY1Y3FPH^>&2qMZ_e7!`a$N0AbKL0i+#GP+{)0#EujsC(Fn*Wh}r#5zKvH@!DfC z5Kr$EIbNsUDR<``SU?aPC`2%!w?IM-DTETz8_D)QyHoz}&v$l~P1pdIzlYxZU^25a zzw-S)-}Zbz&*yobX;z9{Qfz4Yh`+RHUDD<)pzQ$1yx9_a;>o9BK?X2r_~;Ydh<=ml z+iJ(o9cfp5^gKW@j1)qu`Q9VH^)ZzsX_;Z4{q~PZ+Qd8x+d9_~V1SUNbNwsZiPKgG za}hcBH<@Fxs*LI{fX0f|ma8A&Fd*!N(Q*6AhnHZW$i-UpGA8=6!)z%@AYOQ7xBcVy zA0;^un@>viey7$P?L^a&KV^ zVjVK?Y7;oH@Th|QjUm8QNjTI_ZcWsa=sYX$z29!Tdlj}O#sFj0v6VH!urz+=gY#^` z%+buNDHt@G(*fb9_t{xX>g>9k*4jN!u#Sn5k6{7_Ph!>f*_XfeJv(~k^~AzenV3uX zPe*RNx{rl_3KIB>NI?3OA8_8sx_Qd!vjE1M?Y1X&Gw;&RF(P*)+w8&%ud#bBJkh@P z*)y%K1S1P5g<@%!08pe;ZMNpo&34tl-)t+N+=U(nXx2YRyww7F7#9vO(Y)7xxLDzg zH5o0^9rS#ZvJ?PI7Q>H1_f%1ivIsHs&^NsRLp^)9+OJo>z&K{m4LX=!+_=%$QJ9M` zU}+c-uXNOCyWkxY?8`T9W`1FPWiEbx3oI>#aL{^%UVG{p^KA^FHvHUQ3HZE#LVcPu z<$WQ*<}in=g?p~X?`tQyxs%CEbrVpep9aP>`X9tSEAA<=$$*~6V?e)SJwOrqVwMcX zKe(j>cANkoJaU*f7cE<2bLxv=sgdZBFd)LIw8llHXt}v^(1QnxpgB}wWH5vfX+(nFz+@*u{ zQ>v!Sqp{+wEuK5u%8Apc_={Q-`dS*Sv4#7EcrG3c&>+FYSjQ8^HmsCHj-FxY4Y(rX zJ@r4=-a^8zX4Io9=2qm(T&p=>=3gZ%lDg_+;SI1Zq;WZa@2RuwHxKTxy_Cg=?!Rm6 ztH_#C!Q4zkW|%N*hMhdSj=cqL(&*EQtJ{m5f+UuiK5?c^sD8v=+|T+0h}Ml^?)DX1 z?9_#`te&-BaiwFlQ>r&;pZV55*{XH>kqxZ&Ugl`REUkF>D!ib|&>;mxQ#VRF)S>;6 zva=sCV>}tBt4L0XmjLYv_0(=4l+lR`>+Jl+N1?ZH7p#yXOWgB^dtE_>snZvp|`VyHFob%&N{fEqSy z!UE88+(MUI?En)7&ew(yS78?Dr=H(s*Z*o2F&CvM0_0%DbaCQRB<5HO3F&j7B zD#Ar5jVMlvI|fs(gRF)p9Eoc;H~rTiuOY4>N)4H}QICNnAx!SepOm)>U@drRQ0FnWQDKSIVziE#Gqa_gu4jQ|-7Ho{a1E2p4arxRiK6 z#Ih3*(@i~#OG@m@51wwHyy|8^V$dTg`)t_dR@(;SYWcmJY%VT7kuXe%bR1KyJ6psmUa2$Nj<*cJWww@=vC-Ew`>c$I6c#$nou z*>L^ikk<%Q$ga9QKv;m*4igOu-Gvmqp*mB$VUu9xeF(8%Q|v8 z%*jh(vi`>%WKyTkAQ1KGEDW0cZC;Wm{lab{K4%~8D<)(MG5S`(W>)`FXa&VEO0fx% zOYM8lo@S>knd3r8#7MX$A#*K*C<>ybgngr|%+;~0oW17PzotmHzMA^t;IH0dAJ#LoGoif4p z?AzwD+P_K$<`!bL9Wix0o4*)LNy5s*e)JL^0!)uNCqtruUaPOHwwC67$eghU@Wn%6 z0+E@WWIKxgl;fuKmo3+kT!B-HF-7tKxxHrqO5=>rPhGme#*Zv_@(;pZQoj+Syt}){ zil)`u=K$ue`Hu%JDHk)CkY1SEP;%^nHM{KDm-gBsSfw%?rT9I~_@gA82iV{YGip;< zGwinFFoZsQ{sJ3W1w#ckOgLPfdlq%-f~78iV#3%m+rJhAjc&pCz$Ao0C}aCbvXKVl zPP35=AYVUYt4$#xG&wlYt2aC7)74X7i;><17!jxb8H^)6BpLYr4G*&hYAzAj4Hy7Z zM8CcJq{*x~6RilhIE_)o$I@D=e%Qt9^pj`Ui<@79jUKYf%1Wyn7PnD#BZx;@W_@jJ z7Gb=4T#zwWaCiTKF5ya4_@^L&KTiSz{(|(eC~*b5x<}YYKJpIh2`sm}R_%fj#~Q`h zOR<(+Pki1RZ(2zrwOU*?VIwkr+B-A0W!pXy*a4I$FiUbty3i znLos+3Zg@1U?M7Mp}=*}f5xI9cIGmGrz8L&Q!(oSV?No1P7o)01;6bR0ExcBT=K~M zo9q)L!8!%Ns2osg-3wdo509+318odYA7OjAj|@ACTiHbtC_n3!%setir6au-(|dcw z7M-@(COz;nF>fg{N#6qKgMBg*Fj0&fKg^bqtT2e48OO!ht zN8w3SZyv9uQ-+#u60?NxS}7_^0CB+vq{@DIp^(()=35@I7@ip3=4Pv&GS)6SeWBAq zvxFs*D|(_gZs)ycq206ow}63^higOBK@#*b-((XBd+!PL79=!BoCJZOasmw%HCewAeilue0?p?4=7~7$*L$60)SxcT!Dl+y~wue@k7ZgIR>WS{%g) zI!c+->+I?u;c^etU;WrCLlSES3$mSeQaw63eW?if(>ML-l374(4@8ODQ87Dx$^=%k!A!(qeW&!m+aLILc%hEM?c8sCVW^MJV zwf6gmUj`6G&t~u9CG?DAK{D1-0H{6>NiJC{W%zc6G&MKESFA>9ynO;OQy2wcglb=; zQN`EjDs5I(gI5lETD!cR*mIDg-EO$~VKSRH+ObEEg2b4#XP??+E7xqd&LmfAdw`)* z`-HX-oAO_0nyleF?EUXwV9#CkTRYIn-VYs3o>brY?_b-mRy=6q>LC{}95!v< zVF#MhRzls{hzrW@5m})lVJwyr+l5n6=i&Ff$|?=fb>X1|TKKLYfr11I5-3RE|EmPF z)V}Qw2STz?1OX|W-o--UEV?W!LJ@iaP5M~;Stt2kiY4bc>WbbER~-QW{N{cK@Z*m( ziiDI!ws3qcfJaV8@ zq$FZTA9Vyk5Z1%e7@4Apdr6RG#jxw{YO`K|+PeA?++nj@VDq<99prkc7vgjaakei@ zu<=&`EA~>!{^eKl1ElidUbF0^%07$8$eJJSdDB?%35&y*xzJP+l z;+<`T1b{0=48^gy10s>=P{rXKknF?9kiSg`0&)}pvP`vmL| zzbp-FvaP+*0w%yg zxS~uPNjC7AF6K{3qLeI&Sewy@*sBvevYlY?Z8jYsW&TmqZ6$050i`sOyHA??KDTZY zK=N@GCxEvs(E*sCiDt#M%*l+Faa~F8Dnp#j%dqNUSjhbrqrU`DOa+$7?d+`|+zVxW z^=e$vNzmdA0eJJD>m5ASPePP;E?aDqN0G4|SD!LiP(I4-SG+7-!+LtlkYO7DXv&tp zW3F9)^SxAweu><()XhU(Rz11iHofqQ%^W`pYjOY}KerKy6&-N(c&)6IMOCAg3ff;? zQ|dBlhS-z|+)!NAfuQ%VU3Ac=eCy=e3J|8T-5z}8DK=FaZ#s~$@E`Q4>1@WPP8`Jsx0tZ51l0#<&EUqv_CdtfT=q^j8~3k#+_u8Xvm&{w zvniF9&8Ik^_!-LpqiV{D)f6ShEG|>XMw=4>kX^)??O?ndJvVO0FW7Fk{eGPTy;Ldz zpils8)#J|*LSc^$ud88`;3H$^e%tucR`zXdqM4VpY0ePyEDli4UYS$R*9(*voj`x3ANl7VBZ< zqxQ;n7#acxG%*bvB*bB^O2Z0q%uO~MlJ($2V}2lbKSq&baD|>TVL z^KH=D+Dg1&!emU^Voz;Cw)A<|=d{Bi#^M7HuD0W5j-gH1n9$egHq6jGSF+bmP<@o& zsHlw|H_Rqa8qIhhX;~=&_yJ)DKg$O@qXa_-QOkG@-r5l2pt*^9aZlApK&TEq>@bJs zOvOERkRY=yg!rHN{-JfW2k^18z15Co zQ#|=!KgxWnts-p(TRP6BKb9E5hK%{t^=r*ll>7B!KTIhLUl%0s$4Nl!{s`=+c$_%g zWIX=trKj7d;j8TDE4CAA23-yV1CuZDiD9F^vfn&g!~$lmM^|A8Kz|ce7kvi6&4VWk zqthx%Gj_pcC)>MEo5$rC;b0{9dI7971Oez=Oksc&W=l7o9DdK0tj_!`0|B5N=ap1f z*vTi)vlp*_fNQ1CaZR|(o?H8>J@>c_f{a(@IO$EwF{=S!6h=YbGkpN1VM1P{Fz{86A7wQqe(P*xG%NfJ0O&pv%Y5To=!Lye zTXwP8Ij79DGThoz09FB5j=oURrp}#g%cebLw{6_XQ;LxtH%8_e^y~$5>TKeedY8yV zYmRivT$%DEe3N%gcLKD~p&~E}$BwJ9Nvtc6J`a%W6H__DTBLS1ppD=7j02aN3 zxjAm(Z2RS7cc3%J0Bg~cG4u*(e#db$Y&aoqLX^ixm=c8u$^z(~cIvTq$HULs)&{i` zb0oht665f?o9@R*N#9a?s@@oAMhq{pojV$6eHnQ1wj!qJPBI!zB_63NsN_8X&X2Ly zc6Ef%rxx4tyLQ?}n06sDOM8)bcd*kYPMT=P%$b3nNo-O2hFI#lfkHWj2+t9wub+GN zLfgH+$!@*(CA9E;z zYHj!Sq`lfipVEHI#Z-hhNSpcHfD>^-ioM31c1lI`4KxcG#yLlQL3<*_bQTe$16^$# zEX*bIN84@pY=eZz9>UYg^J8|;LmTbx`=8_rwF7`EAn~Z-!|~9w0fwpeZVU}A z7C2%UuGhrLgn>F`TAh97vg7P~*Wq12rf#j@9@0SV*_E`tyLUN#O3p47gr!+JZ=~J) zhqZ28DaLdf&k@(4^lX(^henc)KdK++E-Cz5kU&8K1ql=+@E4K*E5Y0E(8fux@&pP8 zn_;n5atBHTt49(LO~4@77OMzABnu0+u{W%U+sL69%B9V@+Ht;EHriXFO>jL*o&ZU{ z&?dLFt&4bMEN)`xXd#vY%OanK1~>^T;xsZjCdh(Y42TvElf@12!dctc#D=5T@o_OJ z#yWW9jFGnLnazM3TCh>Bap#kEx^+u4F6K=(wjMVSeeVvpocDk3f0JSi$XQogX$gSA zC_q;P*BxL0%8y$L)$YZTt4*;}w)t-GAvtO@uFbDDnrSi`?jzn}YnuQZohyZlvcoj2 zsEAqJhzeXK03h`<DkrD6j(o!cnf+aQlf>6EALOW1B=Vtard%SV6a8HDq}2(&m69 zCC?)}Pz%b$i|6tIg(GbDt$G2_Wiu91z#3$$xOGa5qYUCHl(9a5icMQlx+t5Aoktrf zRwsy!J@NDgJCnG1vcPfzufrTXZrY>~fFfZlEibWR=!sF>wNi3z!re6l11U&*g*w~p zSb&z5e^^JGQyyfMJBX1BISx_ zsjt3O07&hWMq!dN_sqJTD4{6a^hX+om)ZwL9`0xhjvhz7ipYaP`v83V$tWq9qO9bzLPvPp6EXS^SkyRupK1OV6adoZKV3g7E(H4@g!WTh#^Ff z|Dxg&2XIN&uKxl^B}ty)BZgu!-EQMYSK8jDtthe74HmD{laaydr`OvBXB~@i0>-8K zwd*5#KlspGFc#Ks4eZ@=Wpc#DFAR%B8&)aZX)%TAx9Vq)J-wOd$UR7NK#na;6Im6; zhdI;hVIRk>s08K%jNUvbs4`1t5wT3VT5S;`Y=)?tfd3jV1Zkz zx~qN;EYIE4UG|3mAW^{CN~F$m5GfybLg0nWdM-dxQ+tQA9K)Nz+T$2 zgK@_k$Gvo@2=1W09qZW1khz}*svsdyRb|3TNxY-vXM+J}wMP$?3&Sja-N8+h-7smi zwzvwoM&Y!9r@ihHdKz-3-8eO^>)1rTuz45Bqc~OB#kn+R*ddB70P$$%?efwDa~<^_+lBqD~Bw@_+m*UI`yw|)g z6~&7p<$)P}*6EW0%F=e@Evt!R$66%?iv&0hyn^)>hsk&LsYlvL^Xf2MK43T8vMr~c zq8}{3^-lZL1&eITsA0~aAp=r?gn;Q-4>)Gf7Gn^dJ>e;PVgp_s0DoEoORKAF=?Sx} z1S7NNE6pRCzw(DZ%5$a@_jJ%5%EDZPO5EGoWxW_^Qkr`~BFR^6k@6z@(kITefByGd z?UjA7t9^KVh<2_?75DX5ckIPrjZs&zU;+QK7)is-+vNakXPz_9?tW<}x;65^2&nZl zROGj%$6|2710upak^>-LD_g#dhkx&%r??~t5Ef=0s;nxqxp<{Ky7obA-WY3Sfb7cv zgiWww^ff>0jS@xnQLnjkW@D&cX?ypP{ao`Zx=f@L_x(l0|3gkbVlDdUBPopJ=4-RM z>QcM?IM=V((S(fo_+`sT`m@G;WVaPZmn?`D0tE>aB=F}-fEDTOcjOhY8YNmlKhcI?hXWc|@Yq7P-W`y~ z1w$MzmKNW467;yKsRf0i42z}KM8%n7(RB9#kdboAO*=>|(9}xoJr+$l`KS;A4fM}2 zz=yJgfIzvV5}y%;O^Tv(n^YmOsCv_-xY`8(^vZKs0AD*WN}F%oMw7TIH{cR7hK*yM z0Qq{b%H0$ND8%Lxw+58Ju-q$A1O(2Zf?@SUS;YJo6*EA>kPK9pL5DV?`c4T((kQEq zxH?lfsm|3~(sU!m8yP$pp zq)4#|Zy-Kka|;T#)3GEpIrN}FvCG{?Y?^JmP^8^+)m9V?(|j+@ zs{gy4yUEswuyV2NDAq# zDyd`Ca_i2{B-wQZWRbW7z{Mpg;=Fv{JoM3Wy%pn8!RJ-a!<~2NbqD=T-|8ci@4mex z=1`LW<_avJfOJ0?OYxYMR{*xeaBHQ#!zjl*ibFEu`La|?UYt7uaIKh(i0#TrBG5=3 znfr-0@#=mQU|mN0`kOb>F~ogsTn~(V{Qv0p8(Gk7^Z%xvFH-x@V8is8Nl`;3@`_jsr1IX z?Ur9W27>_u0&M_tPhB*JFn3T+f{1dx06>9YVw5ru9D1mXdemXcD$q>{RNTTqn^%@c zDJODaUKAiG&{{IdgV$=C1niUqiOYaWDTkgZcQ$4u=HjNNR+s!sZgYCBzGGBS&HlMb zbHDzkJVhi+D2DASpg;`ZJXoOi*0>0gja*D=Cnl~MIJhs;;P$H6TRS#20Pp|+KmbWZ zK~x6LR9~V`(5p$p)QI@_8wQOVgN$hbnjzwjC1A-$k%L^&1C&K`kj{}Dw2=<-U4s52 zpjC5<4+D>vI*4p5kT%EER{Q1zuje183Eo--3TG80Fr);~lIUh$<`we}W0+ywh%}LW z#cLH+C3gJrbFHbRm5>h2wtH8*HMb_w(D2S+e3q8Qtaf-A#vkIzNgpDnZV>m;;xGxz zD)7L7%^p-1V3}sSyKK_9(e|5bKWYu_upt@u#Tf8LjF|&?!u%K%0LrQ89-3#J0V+~w zCD9%`Vg4xM5KppAuk5myU>&yt$SC3AWY~MtCJbjTC-yGkX3kuCv>iKdD)#}%OH|p& za*{tW{sVYmWC24Nfedwy2j_*NW*Uz)SP?j2X4|gMaz3J-+D$+xF6{ zfJZsw(A)`iHv8y_xSX@z;Qp-XPV-cluo6MMLrO7TL%^IO+IQq$;~5Tb%t4IBec)E39~bM+9+$q6UC3B6XCgINjz7)!p{sJ5y$&xtkq$V&h&KR6;y2h`mKwwyLYpGF|X4OBVk~siH+?8^wZ?0 zmT<|0h)o?vS2*dknKoi(wPiYJJJ!BndC(@+kK%gTUuz_DZGO^}E+0ULiIqtA$$2=; zo9QE2<5=6%*kfCF?7$ei-`WA%MRFKkS&Tb&IgG$k1B#w(Ws4$#*l8Hc+*ki*1K-AT<|vX%G4KoIBzp4R@XBT zbjL<0b3Nk?xZ70{@S3hpChDOKvb95+hkuV3+V5$%)Lt|=|3|pa{T~JUqYcet4J`gy zwozwSEQTmH!!A5z=o~T21juOu)|&0(l$BL~N7Gc_qJI^o_wsn9CS2?O_7KHGR5#A= z)VL6rV6UZ%_!v>-3faG+xG!GMpw$67)i^9i3Dm3)UjgtOS^ z75Jn{jZK$;5dRd@#+Rv$_ka=jC&lU@=bu$*1}`J6NYzTepUrjTlYGQ~@(t7z=UtTU z2)+OuRq`pR5u*vJSk|2o`yh2|GFA zfs9Nwf`mZ+UX!FNC+gWuPsC6Yz`?t{k`7oO%OZHBgalh!5+MQ?v)~xyx{K&6=KMi` zRu3Ij+QWw&>5ijr*}Y$eFWHTbRxu55Q?jF^rVMh(@J&%iJXn>wpN)VfzEGOt@$n|| z`N;D(1uMmnSeIWJD0V%EwIIJzFhz~W2CzMb8EBya#!>`hMB2-37g*lw1`3X#2aObb z3j+}Em`tMAeFhv)$l-5#_@GYmy%2p{5H{ZhI{&?Ju_!XWWY!5sqVDcj`famwt;g4y zm+GTDek#-uq=x9sAVE1~8BKHE(%R8vurQq|aFb&9-#H5=z90)CFv>Vds_}Sje1Gx^ z7s<#Y15pe%B=gkDm;Nwy#TWBaCi{gUDEr$(9IQu?Pvp934ls**PpOfHLEsSk@sktC zgioHL_%2#EE4`hplOG6j_B#MYAEk_J1{7Pdu8xzZGVQVdbfRZc^TwuDi8=W#^!?Wd z$rO2H6LO6Nessqfba&L`F6C5yoJOkUGJj^_xYI@$4}xopIKn-I{Qa(+s!E_VrmrME z^CXiMPc!Up{ZJTG`55-@W6sCTqua`%e_wczEZGpJVCw-7ah96qNxcyt3Pc@R@$OTC zD!Z>+NTtTdA6t9Q9*@60^Lc2B7Mn==?5h&p?ax@6aNDNFCnfSv9#yB*7kcYu-H1R8 zD8ZEvmUSxe`w4Vn3BBkA z?Ta>Rd_ZX&S4avXAkkIwkoocjM_lUnw%tW`TKg2=ux#XWH~b|e?AtTikuhLIb$+;m zSh+iRRySI17OZEU5dt%Gi>xmS0YV{@J*6?5rNC3vSL-Ews4hD11|0UM)GRXQM_?nt zmG0=bLTF35BjC)P3dY)zO<78FFL8elF7yQL-WyIWfwLjO-*d=K7WE*n5a|xJi!$RW z2!+0K3M}c>2}v#pC$U?u7t!Q@FA13fZhzsLTD)%Nrv2d;3(2{eANi!K|^+aNb`8gn&P|FKvs)# zlS+zanA+GNLte@$HS&x0eXrNR8XUtNd;x%dTOi$ zX?J6x`9^9J`Nchwen>h)A*~AEnkWEFI}jc`7tOZ)Hu}9PJ$hLl04W3SYC~4FPK4V( zqrS(q1to(0N!YF+Xbqt&B@V5_T91mtV`+)4El@JX91Om(t`^!VmKSd=>8nWYF^icm z>6`1MI-AAKa%_LEHx);Sh9|~520Broz^T$61S25 zB<(Un-Bea)DFiQdZ=8Pw+`)`1ip=3}>z_<r;b<1vNL$|K3+sp2Jxi6ALQ ziOSsuOggY413kX6s9kZ+xBU$&S+q3w-E8Wct7Is$M{A=EWptb>6WQpWInfy`YMUSqLP$bVp?q5l@e2Iulw&GlsyWDFrAIkjMk{0S{}J_XUjsDS1E?IZ^K zALmBcT=cGHG`wvj$$@4o8PUbI7T6E2;@>24V>@sZrlL8DI;!l4so^&eSJYH#aNlg` zzIk5FWv5$g`dkPFBsCIvD(XQ8C$cH@u3lHv9LW8pGQlOIBE;nY=r*8U`ll{~`&>X} zq6%W8K1tznDk>f5N#Ns(16(4bz%_C_X%;;f^r{Yx5{bGk0%Zvytuai?kOjZ*T~hRT z%(UW0xbCAWK#0&)ZeKXb8wL^dB+{yHX<$WRxSqh$xR1pvb$w`O;2g$V#p#BW@Y2p{Iy7`rW@-R_HGN7f_uqog zU3v&eirVI(TWSU2OCo7UVaUcYWrYuMXlVS~hmv@a`3XEi`Y7zN!PpXw@l0p$33oL; z9muT$R99DI*HG4I1dTHFdTL0{FS7@I2_1y>QI==^3Qfov;lWmnqm?kx$IF7S$1cK^ zRuKgiwjn5Z|4@L`Oea%bwiEw-dKGNl91^@SIuuR^xQ#?i$|2-drBCkqQFfBZrA>=` zW%5%44d>P+)+Z!5-qEfiFLfN(&wqqs0s#u~ZIosGU<}t&l*pQU?Z6rNGm@{Z65GHc z8B{`g`>LAN1d=MXq(C1O8_etcjy|}z<&V*67V2O0b0hU}eq40~V7+o@QCCyTs-*zr z_kzZvAQK@?d?Eitf(1W2<syuCu&124C-LDvI)i$D@ zoMU4oH6X?c?RHn?&a3gj#po}Da;*6m-qvN=Pvux`;Yk#1 z^wiz|WYLpbQ~Ao?y6Gpf8y8f_T3r~(IiT(72k_RplzqG?-a8QAiSK+_H<-x5?m1g+ zPi7R5S&_#_^3sQ{Jpx7D2IA%VJO^fIj1%F9X9VI#Nf=Ud6MZ3pdJolh?N# z!?R#8F}fCg1m@Zf9VprKv`p*-bLiWu=+@RUCN7>l4JLW31n!o?1 zz7<64SV_u&;}kJdM~0+>Kgm;RI%_ZieYipJdzJE!JKY3&X%LvbQwBz;k9f`N*+gjO zM|eGyA>!c*?t^m=l1q3l`(PtDc5`~44myhC3=rXEb>Y8=NI&Y;qrL7ZR$2=N0Wvt( zfga+?56L`SRvY)Z@?mA}7*sic?4~9)*4Tdjfvk=sAdSH1b>+i`ez$~{4caSn>m5n^ z@3Hu-Mh8~L)ryn=v=h;c_uAV49{u`k7i7_iwtSEAY(dOXC75QB39Hdr)cG<9Mou3#wIM5{=bj!cf+=C3p9) z-5K<|s~;*Yh9<1?08Ouxhw~E*ODrRXFK(#HwIB)OT-yYg*liYnMwtF_QzAy3Wm2I^ zkqy&+L~eWD7AW*rw&RokcaH&<9*Ib7D3Fv(OwUD;t@n2&C_x5y>Yr&o&Tp;gml;TJ zOL$AIlQ1uS)mmyiJOU{&Y;4C@A|9mefRgybPKN4^DJ zgq^yodlew!v&~X1ijR=R660@5jbD1qRCW5Id#MFd_iB(NJ(ZR2RwWQp>HpaTyKvGN-&@fUX zSdbU!ey?>dVVY_hg$TY6K*mU@El`MWa5VXzZ3t01SrN7zJ8i#i$Yj6rbNln!#v-Ni zmug~+rC8OH(b!jTak;0-<$l>J5sF5-fW4$H9vr(ye0n)KVnB-l+Q7(s8t*eS41(ij zdWMYuuCGkrDeTUb7LxnL)t&zu5?_()HYL^g=MZLoJL*5JcKb03b~SJ3D8A1*dbfQB z412Wfo@=98toYtWP>`hpyrz}B=OwmH{}2^^%=pMYY{6N2>vtPo!K=U5Y!pE-wT5yl zqO3e!cdQpo;Tkf8twkkX;ij63#?;?Rsn&AqLLr8Lc%-`k@SaFPiDY>jU@{KI9Ya-_ zQRH(=iOvRQH4}`hAeL<}VpYIbPp^L|ZjJ-BpPtR!gK|qRZ*149^%30 z@x;!{h!VXW_lnMj3?oN6y}X7BL#NrWZwbz=KSy^_X$#_4S}Dw#cyOK&4Z&h5Ng6kl6^-A?i` zy8xd_qyLt27*>jik6QCGYa<40!8B9u7Hp&><}etFlv^gVB6nO~ePLg}aO#GBX+t4P zndSg8X-v!5QxP}m4>fw$l}9hg;WTH)06rlPd@3bu-sHtrPGUOah5cc9LTNbImtxbS z>>dAnJ5n=|g>qe{(PM$dRkqY2*m8cLcRohZZ!iRgJSHRRMQ&k2*4M_>~k@8bo0Ajr&(4y0P{6;s)=Z zEP>-&G(wV^p1Cq~@wUl?^h`VE8qx`+&j4cwMT^gMAMU5|fbSb&{qOls-S-f*?Vg&A zs31~rp)s*o9JwP%CDI-C@WFw~FsZ8A=TMd`hwCL#NDYLo9q+e4WDO|FoBvz@u=y1#X=xdQ|Tp@B~hq%ZN^gh9|D7dRZZ zkz7pD#es@spxkxG@=tH4=j&aO319SBJZ{B52s%%@-*&pp{UT7}6lzm31=#&N6g^#H z{jeRVt{TEMf}iV32|T%44kc5)7yPVUUUzgFPDjO- z75`RnBIFttjWQd%pxXC+50{U2Qd*k&wvlVQMnKQzM07#f)!c&)gHz4YT|Uq5zD(?% z!SUEg2p9IcK#Uos&8AEl2S>Bpj$xl z3PsAw@o(ZkO-cKC;ht4^9m5X)y^c_Kcm0u}c9>&b_(sBL%D6#|cmIC+ybhl6!yHe^ znshAj&doEw#va~G8=wjqEOws%NDzan@lM8Jb|3x!T>#xo0qb-x-TJWsX#3cdtx2?; zAEWTaYfp+A4FGIs1E>r-5R5&A6+N-n;HLYtyRACB0|s1TssRgN!weZJ9w2laK$}je z|M@X}*1ohMNo6qjv1ctv3rPsgM^+}jE~mkZ**xwB;;;=^DFlZh5b&>ydL)mJPx+=U zCK&v{Snc~5Mqkky2C0K=JWnS&0WV0`q>%brtl{I|zKiSqGMY7&NaN0tGM%-R*6>}9 z7yJ>5W%}ikha^Bmz#&Gt$K_rjtc&mkJFD{C2k6ez}v@Wg4o+GgYWuje85a<<-0Zh`GNN0^00tsWtQt^ z^SLDJI^0`=oYP%}S96~0c0qY7`x~vd&pQSVXJs)3;BUUB$En6D@P*mrN4 z9{Ga|uXHApoD47^N=I7Uso@hTKE{09l+W4rTWwHQ*F1#)WhxIZ)vc7s&)Ru~`Z;4N z{{z~za7Rc26-07Q6*{cH!h7-4^sRGdR_xG$Ew|3wQ4(G0!w&Nqi}kZ zPC-l!CFz5hMytTaaZ`N0xG134N!F77Q+y#1LJDl@NzrVdJc5>TDk2v%Ek!}5lPqV$ z?@+7V^!Yn8aSPn`bWlcp*gk}mLLrWa)g^`C{o}_T(%KdXli=S9#L-F3{3el+Gh&dV zdJHRky(p&ghK@F(E=yy>GNjx^&`ITaq0||Kid;V)r_l?ipzshJK;fcz0b zz>AEw>)8Xw_wW6vNR-RW z)_X{R?w@oy{A_!Y-f23hAJJArk-6W~SklTLDwAvI`(;>$?QwVEII#m*Rf1=uI)#}PyM{Wf>FBwoW%D6#RZXEs-G41`g zL2HB%t>J*Gw$$L+V5aT7%C*MEm2SyEC#iPIH#H#oR;_x=N}j)a+>Nc+cJhVLZN3tD zb(r6^GRx~GWuR?s^8JT-S(&O*_IruiUAz^>2ZO|RrG%h!Ob=2375Ex3Gu*T&t%t7j z#^!r~2DkWOJC{{>*PlyBm!poiXV0rsho#cY=Tn!ev0U?m@r3TU>H|_WGCO%*lmd2cMOcru?D1)tOM?(y7O-?@FjM z-SOsvoJFpAaCzDnUTR-|AX%5yax}r`6zID{9#vUaI_O0rMxmHkL?%QZGN}W1A(1H) zG6v=|O)-lOJDWlx+Iz^TZB;VeQ>kBJvXNwt8T+58z}Lp5ISja&`rXM+F%e(v@5u+EBW(NDc~3CD3Z9Co5%Zivil%Cp6_oO;b+zmcxny|wdyoiU36QFhcB-nB+}Fl}#Z zui1?SX?~Mkjtjbg1RGwkxdEqn_HlUladDC}W%*2#`Jp(F=^XM?je;dPPYB7nIT(hS zSGelXb6+5@jo$YffW2<*DF0pSXM-*D$T}5B@}g~BUc=P7df3llPwMpzQ=pNtt_>E& zLEE@$`r*gQ9Od5mzOgyDRc>+(Gm#zXw0pu5U?4BKAg^m&pVmh>;H^6){Q`m=Ky$Q@Qj`SV7VqaQes1I$%bh~Ak($eLPInvV0mpZb6}Uqe&FC{HMflTXpMDwOokXtzosX2!6|e==>dGz8o5*7+$^Z z4j>}iIms4~?eIk2^F7{^AmrHhl0WwF2N{Ph7|G#!VZj4g6%DrE(^`{NzZ(E+j0`X> z|9SHWlJ+?Jpw@4SV*HG?9cEKSP-}(v9ta*FEGnilOVe+`iLZh#lCLtV8d}%i#`Wb? zukBB}lz;juKjVMG1a{(nW3-wzK$?vKNY17v2fJJmto7Y>URp!8*8z(cwgkSRol-~H z4C1XXO04G~`^;ZxJ!60<-7%RV(xbm4!P(6*@|&ZwB*kOOn77si{CZSByhodEgv$5c zkWZc;4M2;k93Co9HrI9PCF|LSYW75z2D(7~dL3PE>)m{u^{=g5lWY^-`g?w-^rjUc z+zb)zdln^7vq%(Rq|?8?gKhz5!0qMIv+4g}6owc@n1?8oT-$KgVmXkyOI5Y8u#_%P zs%%`pB5CeBTGe??WPM~33qf!W2w#;GE~Bq%9b|ledNjba3Obe&+<-YJF{5ZsO!sW# z?+hWQ<^)S?T}9{$zBw}BEn&`gai6UYUjAc0H;nUu^J73qVl9;qQH?FsL*JymqKvWm z#E>GQ)G$d~(1YR8;aeSt-Z3=|gPRyVKX9&0tx^Y{(%&B|5ShGl?Ms9Z8bBH5v zxh2vNI%T(Q+-R}z;)NBg!0Lfs_nl7xAaAf+?b5tn6;W#dO_?#a-CI9eoyu^bE?@MN z+XgttSd@{rRJi-k)m+DVidGerh;^r9=ic4*tSDISb6&7RNMw9wI5gOt@Q&4VR4F=f4rsjnrhiagP-#|9ha%e zc+-R$2WxQjOZPowJIB`AzaRRh2HWmapBm6Di^bo9-mSipGf!@?Ps!Wxv#cbO-oDk#H%AnV zADOp&cM4?RORP@(DtfRn!A*_!)kzB}OGCm~>HfTu(|+HN8bCMg|2$(%#FuR#?mm-(C+A5{*CM0 zn%&K$agwCIpw5@0xoM>>X3b{pL9C)5fPqTlVqxVM@B^Tqr?ATZeq5xcE_TKMQVP&( zHMpb8d!ve`78?(RUJiE*N!@Q2L77KIu|sdf z9tMccrAp28hYsc_syJsQVe|VFsl@o`I-CEa-`7~oEG>lK$I$O?j$lUFvpuIBUc0>T zOYB0nhQuaeQJRfC?_Kb=Sxl^6{_0gz|D_TpOc0#6BBvey&xxb=wlN5Tz%8Q0E8?HH zJ|pA(GIrOUTshU7NO~6$Nmn7XNJyNc1H-*Wo5k-9w@a^V((f=KP%?M35njAS57*Tn zf4gobwJU%{TCPd2w&uvTCCi{}tUq~$Kk@JZ?Jb7%2PLOH;7c#2*IJXejZ^;4@t_-l zub(vq{$$i)ZU9Ri9;PbB8FpT&9U-YDgW@GOD6x+?c&5G8K8|N7>3`IR&Y(v`g8o&# z?X~3mK)keN$;7uM`UIb~J`JbdDhS4=-k5-S8-v7x*$K+>Tdp-yHxCb6{rj)}(f?1V{j#ay6iV9wU$Uy%R{0T>TtVL4jZ;!Yzg7C+_}?xJU_7|0s^n%~3u zy2ysDH5|~nxE6vM6y5LFX9A2M)f9%>i}XOeHO{QT3f?x{oc%q5aNDf8BV6|RKmqz- zWJ<;uV!h%1)r>HWwP-FdnlgqZUmG$UOJ!Eb3)CplC{9+8+i_y`TYrfl#}l7spyaob z%*97qUu6VrO ziEkO2I$e{lHPvlA5BThk{UFg+EM2D)sa_TEJy3ZazI^Lj6p&xk)u5SjRc`0sg>2lR zYV~@@(te+Sw|RO-aw`nGsWC1j09g=a%hw^;|Cuk2j#0@~03s zB{yY{p&X}E*Fb*vGt%94qT8n5PR}thJy_{6@hMsM*8zh$-Mi%PX#>>Kch(@*XXE^w z*kJlLgbDbyE&_>AOlDIv50W?0SLwN=7pR@+THP>`=WWLZg-^r+^rgZRAkQqoEPRfx z3C)o0)n`lNPKLw*JPO2P0Cfbc430Ge{gm-X^w*>uZz8b+*ta@$4jQt->Hi3HrSD=26?rhlu*#@T2q4c?G^{_0+R^8KyQ^hywt=9gbu+4cJ zk!&(~ps5%v+BU1{0t_Xyu>K{iqj>)#Z%h7FPOt~jpb{-(XJ#1SH^RC^(puN`&!26v zML~1Ux8|!i==>~SMtYQc>vc5gy#2Eg93@?Y4{Q*B@LyMtDbmr8UP1c%O2AvSigqNP(?ardWo#xAP9M~JqxsH`-0k_7a&d!D%#H!Ry)S_D;$j~*@vqWbqjg0eefN_ zm05W&i&R9W^X7Ye3;0H+#~Wsj?e-z(UvW5Lk*>d}(2aE)m%84LAD0y=%uof1_AzI4 zh6pgp7uATNlH+^~YT5cxd<-VXQAjYMFAZ7;m^S_^<)F$XY1g-y+H2{Tl(MBjS0l9=VpOr_o{ck z447`$cp6BrA5cgLa5#d=ol3I1lLMCOiE;@Hbdv;K#^Mk{$82#HE+^X*AHX+0iR|X%!i)q7_lK@eLfAZuewC{$)s~7kkM`78k zVi7tb6DsU3rKSX43I*WA|0f>!wjm)nUYqC>EODVE>2pq_tV&Eo-+Hzi*)4fCkZ+`S zR8n)D#lvtb#v@kc|Jr={MRK^oEa7fRZOytntD#7zsD9hkKH0gIT?yOEJD47ildX0V~9&cx<#i+VwBmQnt1MB zIT)g!`{Q@F+w-_>y{K^tL2`Lu6ht@*9W;bwTngLN`FvJ8@nPY>k!553R^#7I{}&s4 zv596h4IRVvTnOH2+n0T@5^Q{V-D(PSO{{qaQxvk9;X^(43QkF9Cg}I;DP#~{Ao;wF ziZ_kOP-{9w1&jn5O;Jo42&VN4JarV3Cs)=Z*xIYTf^O4P|MQH??UXpXj`;INarnU5 z@~{*n$c8K!(4(8`elZM%Jsvc&KET-4-nVWDAe0vU%=!;7E;9*+@p ztr-~VJ^G5Jb$-qzShs>{iz|zFaWApRh%MiQg|(b@#%v|NODGHPjN?AU%dm9{|HAZaSkz z+&dF4xm;~Kz|XxRr^yQOK+h~%fnZ9A#n4>>MzqZWj?u8%KFzmy;kD0_Xbmt*5{0G- zuOq?#2*MM;-e+F7=4tA%lKtkZ7C^=Xl~nf%4ttPY;vB|#q{`)!T9N+KvInYXe4J6s zX0If=>D14!gzYQ=p0Yv{S}&Y%SP0kIk^R^Q&<`#IqzVx4ZLzH-H(y$#X5`rz`iqHb z9Pbyat(wkK1Y`g&bHNTUKGCc?1GoAc0A>s{Ddu8=)p!oQAu6-V-U=9mi=j=lJT(*PVJDtDwDX+>&{u$cKNn0 zUHeOFmr^Ze?e6PZ51jnP-|P2w3oYpYr1=?ti&5uTYvL+DSp8Rsc;-o^71F~zX#zRe zi}Sjr_JMTOSp^gD-9QOJ6F4drJ<=*B^oYCH>4>klZms|Rca+`Mv{Ki9FG)s|mmDri zi!ar$@BxkH*pR@iZ3IqVRG`%(PZm#KPN_(s<HzkaEHN=Ws3J7%-Ve2eAVYD`56XIj*-ua z5O{Y(|Ia4E-#HQUKr`vCJgN-N;`J$kLz7o_!|#bT@t6*Jnyd8_-sKz@4Sa}MYTTL6 z6O)JU=c5I#;d!O3rpYr=t#1QKhsi9SXd zJ|2I3h}F7P1=Ms#eTb)y-Tlc^7%}Sq!*6*KAOo{i-AoO`LL|m-j87LeX&8T@cT_h^ zLQ-(KKHfVYcwVUC)%)Txh*gfc+d=Zf{# zwmS*vm30(mu*>3@ErnvcEF-Kn7>a#2Q7IK>q&;;Wshpha?CBfk*qx^^+MNFRd{;+N z5Bs4TP1f=SjXQmbq(r|3!*muk2Vh6AA)-sm!dGYKOIGJXl5Ac0YGon;%Hz@o)+tI< zMz~7EOc@HMqf=Lz0Q@T;V*n}3@-p(S{X}R((&aLRwK9V9&ow0>i&c#i6wXqFHd2lF zBGP3YAwjy<(=p0`z+po$Pu&XM)^;VC0o)#Sw%?R{Rr@J+b&px>^Rd5`tRMOAqWK#A z;?Au}>-3Z?0@f*7shu#=cfeeJny`a&tQwmUo0c$U8uXWsh124iDboW=VP+Hnz{C0- zCi-H8GB+N`ZPV4|xaAGx4vVxb?i=>a30IdFLWD{XB1t6C_rI=2-gm{N>pA-oTH_ zT6Ao=I`U%h8gXAWET;OzL?`$`Lp?Bdnmh$D#{Jv_%_`*EY)}!Lerh18;6liU`dH{7 zvWHVTS$7wjh))3vuEdiHo?e_7ui$WhFA3`D{d>T3z}(zEi>wX`P7(Uy1>r#VqO zbe@B*Pu)!c0}w}%tkl6^$tv=V(ach51Y>N{RTXw0J9==rRdwTYj8l6nmoRHA;(wR> zt=SWI{CFZXRvnn2FjUmArp93--J!Hl1Z&&=+JDE@re^#tYE&Qw>T}eJhvygTfaF_X37rhO5syd`%32>;&dZcvXokA`;ql2vBB> z4smomTt{%diX1uw{M79;*B$re1C0uS$}P;(bbS_ujaX%Cw$>fH`MN6uID>g56?gA_ zz!D}zD1$3-bk*Ttyptz$w8P$bY-UmS&aTBdxJ9C)+F>l*43_-7?-ELEZd$4TlveYY z027jRH`1M@g=t@VxZrJXj_|ZUw!b&|nt#9ccMSvyq;QloH@4h9t_q_uXVtpIE+9pH ze}vE(rUz^d2p?u&bd5x^V3QRzSHbo!V$v{$#^dy|EC)+DvHwjtwP%T%Hy>+V95i#; zgJJh*!Eb6$|7zNZx`-c7mkZSvyir0R`c0Jl%qP;VqD~j;c|IY1r(R3jsNl`4ValRY zWFS}ktDA|-J7O}2ZSca=qLQ!PuH@VnNfSBxkN`pp`${RNaGf&Pq?GWY`MJJiSu)B@ zo6zp0sFu?i+?nva6fxsO;eRth+n4g-TK($;3&=mLI!++@B++!?c*v{Cg_Tf_$(cJ%B_`;#%5VD7)R*!9qjfUD3ep_s z^uCTa8V$l}H`%NR(qc2|*&y>?_4I7{FCZKB)I8l?S8)bP?sB;`xN4}=1Jtym8r>QI z+-BkEhqVxhor`nAyfsr;;I{7Dv!@{o5+t_EikK-j4FHyY8;5>{XX(f>gCH=dWGro9 z+Ay=-YNR3ur(8HXJYzWR8$G6XRU<@At#6!bQ+x#CRY}wqhPSQ1G4(~F$B4loM)Kyl}+TtYO*8-@qZ5)gdtaTMd zpoj{|L1Rh`Jxz&8250!=Gz1q&UfNli@)R(+7%IbKko>Scwy`*CTb=LX<_1>dx{U-= zE{QM;%(Z2!qxgYx&GoKEKwc|KTNg}<71etHE|~Dz3XMXKm{p3MHvaIycrq_l(FOsE zt)xJoy2{@DI3KCZn3iPU6g7TyFnDT~5Fp z2rH|iE9STCV-TzCXu-ox>p?4IBth}pXUHXi!~qUTx0h5@w)Q?;Y+2h5U~g>wwc~jt z6!bg4>(w*Cpjr|86+@_Of6sQWrgZ>$L?f;ii4W69a@B`x z`f%Qq*TLM}!|Mcoqeqb%RZ?mxZ$fjg&MOggG?*ZD~H6f~BKj=I?7KNa&kKXE^Qt!%6uZF3+zCl5EkCs_>$H9Lut@s3c3v(OX` z51!KqK`dtsU|9}Q3}hiF_!`H)c&wp9gZ+1%9biHLljawi%W}$fHVJmlih*9w5Su zE>KZ4m9ZM}yI%R1Yn0O=@>Ld$ZAZ^#1PWIGzi zeka<4JupHe9aYG6?F*}^Gl{(j`nS3+_epLdB8^^mY(<1 zqJLuN`CizU`FY6ZWimBnBF^@&LBPK0KNf%sf*y`l;0Mipe#|d#?ca}U z7mIqQ7FNcUz2Rb6=(SSig>k8=hMWdS$j}lmkf2O3kBjp`#cT>|LY=k6x}58}E$;M! zB<8vd&7cRivl3m6IEM@joNBHzV33sQPskfc(Lu^i3gLI@U-sjMTGCJhGE;F`K3hy3 z*#Dymf9k^OxGt!=4PvSzz~pvyZ8q6&@n5;`i2R3H^j| cRK`=Z(8Z#I%>TIJ&9 zp%}OV_Pc<95iV=Q_tUj)ZQF*%Z`j`AAPF2Q10a+R_O=2Bm4u@@uAmq)eidW6M0^Z4 z`GE>o#xueA@SxS-P)riZiz#r0{1#Yo!5K1866(4Wgbh?9*dWMlhV=9oT0PB{WVFq! z5L(QDFnJ}979?oFl#jPLY$9*rOFCw$T1JkdE#!1{a#xZ0Nm&&d>v@BcI7*ymh2aLCRDAaFu@nQ_H`@Bq+bz1)T{k{vG&o*KCq^mVBm~LxOy4I z538ajLO^n!0sv5o^+0B~G)fdz+sZ^ui!%hwmQv`9hUSlN*l2ha$ zpJZI3MGmLtfAjh2i$#?nUsM8>Zy5#g+nV0N-=$)Vz=smMghoceNmxVFSGp>03K6Ri zwiTk+af{$}+x4H@R(bU;xWzqeDO3;441X<<#etj5L*W5X<+@s9WOT5As?GdG;}z>s z8WFEj27EcWFrcZWUV{@1fgr|04Uao#0u@eW))LMaw}+p*(!TjL&Sl()q?v`Eav{xT7d zK)1#JV*%{*moxrUcP&kd<41v2Z?payXpCE?LjgD7HHEI1yd;HA+>e$1yBOek2Z|TCu#c?RvyTJpYVZo|DM}p@B+3_) zZ^ev-A3~lTpnwk?sGKG@jwWk#DYT(WVO2J}^x=0f6Ks=A!x5N~pLqS!$WW1X2u!}d zaEu9Vg0{h)B!UFm!3CdO)0k2IPGK)qMgmsr<}7BS{miXlh|Lb_fvy11w}Ex=a;9%k zoJ^DUL?;Ou^*Cu1Hgt0>J-+-sItK+l&s=iOX2FhVL6yg*jFWTK9l^mcNs`%54^#0d zN=Esl%Yi4}{0HqY&f2*D;Jy}46^=F0@R2LO#Ut`z>rVu=HA$6cGqvC^11CZs!t}O zrnU8^^%>Y7K3v9((135P#EEd4{Zs&Xr5H%}zt6=Q|4%>f&(|$`GP3=pc^#VQK%4(Y z)&K8DcQg(sZLl<{5;f0|>k?GX_zJdazAfsJ8)UhC(_+dD@`Qi2 zKDXz>c%L`1!?k}8Q2eYJ_420oq$Dhti{N*vQ|Y8(*^U9NGw14pxI2dg;cP}ln$+_$alK_{t6=>A7awW72?~p@;yOnz3 zi;}?yD+g)S8fMURqR?T`NMM6oyzBfP#~!_>&TQ2Wh zCys7Oo+3#?@%|56-vAs5x2+pvVo&U3;)yk}ZF}O0ZQJ(5wr$()*tY%pzvrBL@2mG} zRdrRPx~liyz3}aCed~-^j^ha@f)s?+ae6mGxYSqwICRAI=(PC8E3ucPP(0;#WsGuz%tHhg5 zVd4R90kKLME>u@{b0N*$I16utlBgM-RSQsG6;QTIL%x{L3l&$(T18^Ji{l*$C$WFg8{(k5Q`K0`_sz!XA{Cfm}hV$~*K|%yn z)9A6nVegaK`dCR#ciQ(C%x!qMV%E5b?4tw=<^w^jN%brBGAvHaln}3Q6$Qn;))D`a zL{eM#FSYu=gqM~LcxX$ZP!?`wXw%*Lw=~gz4~j^$KTE$_M|H9rlpwGPggn||Caqj} zj@g`-Bgbyxi)Cf%W`5cS>F+md#@t!T-N>TU(yD>b@3LN?&*-59M$0%qRc)#zZhJ=! z6-3br;XF)B zBLRJiHm-4(?PT}<)iu^_GhZ~l&5oATqJJ|AeE)w;Uq^~azhKF!@~ngRX%#m%_7&zZ zUy@M%HFg2|cS}Po=HvyOviU4@K5s+A1@Fjn<;Ap=0ixLYb-#J`u^}RJD}0faLAxg0 zh&k*U%o@U)?pjC|44QcdhQN>gJH~Xal-H8Fow~AV(38B6SAC4xvY2(+F0v$LF?G?i z#bG$R<@MznAB~38+u3c2{EPe>&n(*hHkGSWCukmcW2^?cIRU~hH`U0)-&N}k_{k~G z#p0ngat7V~djgZMxc7Q?MLIq3L8(bwQa7vy{m7JVW;z%swuP}bDS3nB4wh;7?KtVx zLAH1X8DAU87E?)Ky}n|^RKm&O+EeEsUq}q zmJ4pGTCKO^ovI5i%SA&&tW{RzQFby^Gno5$k{QVHN=_lm!KZL%@XgE0(_eLZrag<} zo#?{b$_?gGm7(NjdLJ+ex53N)4mvZQJk{pfV}yrju?l~qT z4IxX#X=*nqg5EotSfQGW+nm+RwI-wdM--+3(kd7t-FmY`)3C$LrNDrBvSeVFgoe4X zWV_NO@eEX8d4MH+)!j9Lg4a$XS`&Vi6Rr5{hm9TZw}4B)OORTb5YFJ< z2$Er!E7xFrLSFi}3_dhN2z$ori(XYO?*KC)uA%_>%ZR@Ypsl+kBjHRijl#3m5jiIX zKbkd+8AJ9yNFKc6ehGMuVaJ9WXlX{+%6~h+ zsB(B}g|~P{dt_CIjtN+|3mUXPLwNF9b+XpkaUzVgdU(@#2r-*~Cyu7jHrlpzeG!SxM)iq?R4H??y2CwXs zw&Yx<2Y8+^HHF!K^pbd-O+sgYN7-&TT=l1;FhX7&`)hg%=YgihVX_>~J4HD^KQ-0h zH{tNJv6Q)q@|#0KWV!Ns58G#DpUSOl*>a!n0hZi9kKcpp5UWRPq&XgK@h_1MmfK`> zWI1<(Z2(qruZ?%#M?|Eeh)f!s|T1vOVYT*7F|Z+vXF=6iBY6|>M` zZ=LS_xdj+IOC3UsrfQaU^=@Qnj#hd3dTX1eBeZVTEw5THY+QG!zWJ%QlCtjIP__K^ zh@3co4(NW{xH=!Bsov-5ze@<4qE*EpZ@DO`oQH@D9Z~uIwnmJ>CkZ@Y|1rO6 zB`{nv&@`IZb)?eui}hb;?%d6p>lclUcWy6B&Yo7o_G|BXFZSaNjrdDwRcmAQOgA&>A<==qOIEu|Bs7KGyW1*Rex8*C;sJ^-cqa6zIAhzq1A9A zJ6T=#Uyd=A7<`^5Axwmk zKH*0Ew|t$8kt-_;w^~t>EwvmB8p68X&K`WUbu><=hK0qUuIm-R(hi4Kf~^HL+Trre z`UMdmOTnRCi=W}G4h^#eR>KEv~)Oy{gHl zlIkn{@o4E*@!fmlD@@=5a*pbiZc7e0Gg4ONml6V_g zB>4Uq;?QrEMv1#=Pu3Hzfi%^{Z|3sMOlsx-^=x7pO-nZ^Hp{B%d5dZ$hZ>8TrwcQ; zt)!nhC4%6*E7#PV*?eU)&GVEi^H*^HVQ{<>Dm!*m^gBBVuy=+XvQE)J`j7;979%#% zi=DbbhP|?GV>q$_#fuwlgJ)V2);FQY##p$Em(_OTml=HX7P>TX%PKe*_Tb+RCAXnA z%QN>=H?t|NPM&6zJW4yIQ-8_{9`>XiZloDOWob(*lu9A z8Obd+Hkso5L|ifpclk(LQ(f&(Fj^X&b91R^qdr>Z8bMAc%Ah`=r2(SfhvL@VF2A_U z*VJ~&Yv{>yT>M!y4t#17^%=1nK1pcM*y?)!kBV3Z42P1J7c^KE_7g@E;d%N(6ox_sU97&j%6yiCv#ClM%;71u_Cjl{M_Q+>7^vm22 zXp2K;O|xUyjqVSS!>jRyG@&5fsAvKrH}pi$(m_t-Z7yD3QSC<$H}@h9Aj<}7UMjj^ z|Ja2t7;$X@QZ#N=*Oa&S=_m+^ElPrFa&SfX!Ll#;Xq6o599ryW{Q5Ro4z8%MkO1hc z4cxq{f?(jPD>AaEuq?5kX*k>g8seOYb0vt?aJ!`~=>z^}lQ{o!!-xY7Q5o}c6A2p@ z1_laxPBKy-ml%ihiEzQuAwQ|C*i5PH*cH(e_;SlTCUvYlqe6FMNk?97yZG%wE3Y2Q z*SOn4=V>Afb^-|p&2KjiVn9rxTk^y(7R8?GbrQ+tjiCSF{s9(q6N0JdR|Ku6?th&X zziMhwp0^Y_EfdPWw*DJFUmvM45NLI)%1gn@PK{^uJflq;zjIhw7jDiEPG|`G=-qa2 z%E!8RQjo&L(hfp+0|~p&M;_OWx7h!4^cbl8yyV)~AnP$gP^m2|s%?bi_`OFHjw34h zV2@2uW=q5yXUz&pH5E$}!R6a>g$F_%QS9Q*NEP%gyf)0v7_ndchiwxsdp9Sm={r^~k6*+Iy*WLUcfMF~WM@j#4@w=Y{~@uDWed)|WzECwA)&+uNDN z5@jBLWFts`fyuU+3-caRpw51u+B~HgBRB5LklNECWM2s;Q`=g8BnFMMXtQ?8jF5+K zL~B^;y4IY&sJsn1Xu#hD$30~weAIes9?JL7A(Uv9cuVTDJ0iGS``1z3QiToNkI#yW z`E?tL?{z=h1iVff@bl)pdD%VZ`?@DRFNUCwpy*YSv5Ua6mnI}v*A5}1%zf`WvU^^u z<_?As{FNIfBjZSIo-OyUFVqFYR|4Cq*S&hM)gUB&fY^VHZL_(fks!i?kMJ}@NQTU@ zzw;~{@-$%Zdm!?=F3dq1xprS_tBe6ZK)5R@$G-q9yY{_xJUnv))R+4U4>Rt8vG75T({$as2sdY&6X@MpH?N`F_AvVXSSy?MjAo?fS|BH^{`QWE$JECeBp3=Q{|Hwvn^ z{#}3Q^GNYeyLVO#9z?BQ4cpWKdx)PY*4{PO1o?izaP4Zw-C1ISV3ve4IG8;CWU#C6 zfuMjrd`Z+Jl8TVSjfYqg=B+UQ3T9#3Qe*Iw2itk5aB9IPfLpcz5E5*~F1H$vZ*0a6 z@4sFCmq!HpGGy7QW9(MfSwZgiYtr-8BVA=zi;ytpv<9m#JD<1VC{y+BE*(0Jd9xGo ziMbo7BcW7tt)GkuJRp0@zc3tS4p$&VwCc=iKenOy)KfM-P=Ug-$7TM+CN@%rHde!` zi`NHD$}aV*>2Kk&%M%qzyCnNJ!-UQFF6%erD(wW4C+V=TBl0v99nnidE}jYh*-E{7 zi2Dj89mmS)Bd-vL``r=Yoj4O|5_d-M&@th;UanuYcvz9w`-VS|yZ=d9{Ob zS*#5C*by@o=O60~d-s3Y|97aFsU^=b?aX>f_Z;)W@|@4Vw8e?_E6N}EZpQUTmK_8R zfHkFEm&{h+%{?iOfA@b^pa0aM`u*{~Bg1Pp-5b%IhpGH$3SEK3g!yL7x~@Yp7lC`u z%|>+IpLO2=YL! zDi14VgXNC{2;BM&`Engiu|Ny3#Dfqref|YViWV~gNnF%j#wa({Edr6p(-kRN2ER|z znpVce<4`t{;i+jQ{e~P%1qBq|7FguqL*RdM4hIJZ_IvUb7`P~@n{^gn8Jmc$Af8Dk z99d0s|DHO9c{b)y+-P3h&WOnIP-IQp*nt4`(6N{w#y-||dCe%!iJmZ-zC*#KkrFGY zb8;`MNo7fkZ=Lz8=9M=$pITzfAgXoPFdC*QF5BFLL}2N&*eHJlFXHdnRB{;iqB^ci z-lgLV<5}cEb`$M=IxE`h$@-6&Ut2>yEUjL8WO_L+B>2Fdc}R$Z`hUf0%WYIMhUqs% zF@7#j;LtEnfhx;bLt~;OQu2d&DCE5Eu#zOqJzu46unCmdc-&`^gZ6(Vi2rM4Z^((_ zEvNnhneB06t5OV|=*V8NUL^C*0QVLhpTV%DQVxqosZ-xJ*m1J-^@0xnXmJn5sM1DW zQGZrjj-&=Mc}}n$%&00Ou?3v?hXrU@m>UW(=5H?);&cf8@J9M*6l*_2rf@j*gtJGc zjd0+j^F5k41+72ZZY{@XwUsF!jF>dp8Ay7Mjg@)V=wd$pfb7OsqsN7p!b1>=q5eQE zvC`m+=uqwsC#K9u$D!3h8pVlGmjETpKTBqk$YwPBo;Tl2s~GD{<|Loueliq|Cmc&% zeUCnuCdx)kv64(TRSk~BG>a3#w_Wkrh1OW9~VPD8oCmYW{|c(B_gAE z=WTDTRl1aHv$#P1AWQ+2><(ab{=W@S4AB<@y|Z+b?G5mD-H)-F-G#)A637xj51-*a zSn;}8F2)ONB0$H5AeQts`xM|3z3XjP|BzRW$kUgk`T30(^BZPva!!_b!vbnh5MGQ{ z8OkYQA5&InI}|C>i7ye>1GtpVhkHL(XnjXXj%SfVI#vIl z0DDn4PG1?}*s|ra;glkws%6vpuq?9A%Hf?tsbhM2E1$E=hfTitORKAFw8MNLCvbv%>%_;Ka4 z6&?|xb%5wiuh+G{>AHuoJd`IAVL30u?(~7p`bRnAXzM(?q9J<~w2ajiZUz*8dzn`{2 zjaL(DBBpqkyk8SKD>3VhsID}0`J2LA(Q|)T;>AWQRQMVFsgQ8J^-C)B`|bj2wmX%` zMWKl1&j9I0X(a?%t`HEtfM!T(A}jGHfULN2gg36h-kMD5qKGU#A~8zfQv!~OL{WKy z?CtMtvvf7K+|nZPg=F!q_$S0bDX)SsZ(b$Uq%@X%JXiV~4J24xsyX7HI920so?9z9 zyb$}vYdQSdpLE2Ud(Q*#5-TijO5Zy2?F3kcVuKnaQNY8#rAtipBx=nWVA(GnFMJ)& z(l~@j5ch5vK;6^fid$J#>HrBv)(a$Q^ex-|i)8XTI#zriCvsLdyMxX%0?@6;kJNWD zKJWbpZ__@XhTK;jcYln#P6)@7>FS%eyw}|Cj}0;`>qeIW9aT?GUXx!tNIo^)9~U;( z@#M{SSbCndce5U|B3K8P&THLYA6GhQOVFzV}12(t1@<>dpZFmDMplV8$d$|96}}$%$|oEOhZt%4BYl8|yrxLJiVB zd0|Rza-*!V&=xorB8+SD>&)+F2;sqw^r($HKUz(g=J55A9zw4j8tWNq{FBCu)Ml1{%1HM~%QCC;%zXY05r9J0itnpPC;SZt0@TOi8l4xbYpS2IXx= zie8w+)MG!zNpuYrSjaM+jpWrtQF=y6-9rCPPSe2RMW&)XJcvtVMZmIB>n{*n;_ z)oZ$vj{~#!0eOusIZ@x`j1W>Iu*LumKfhpm83Y*KN_S=+8*L=K-m({P&=RIeDdGTtELI3$6mY%lW#CA*u}T@yD4s&Y3s~{i{`D($1R_)p8O$nRf5PY+oX8D}D zn*05%82-x-f7J(ZEk!_Vb=PYdcL-&+XIw>)KO($HN+%`Vf&Yv+(iMtR$b%Ak>5<-bYRD5|UOzI^5ZZOP zwOYZ#)+p}5M1-K?Gb6RkijGwp(K}cw-9=4xdMnAzM7uYlEXEH-R)(9)^aqc&_lBq^ z`V=i}d!la?mB8U}d(z5Wd+vClHab}~vp<@x&Su(mitCIPm)p5QqFy20iHTh`o!84< zDyJ+#mTS~}G3bbUAziu4HoIxr<+bfC?{(Q2mjpJ3_tos_FVLq(X$`n+`#}SE-++Lo zJFr5v>i&3i7-pez1nzdrMfS(Jsq^Q{QFCIPdBaFw8nY=^!izk!Qv_X8jl&e@uzB4f z%1@~itnTL^i>K1!tU8GVidF|56_tbNFf;TMZC%|<@nQLlTVHU*ngAr;l}*n(nfABK z_KOg{_uTO-;C6YUp&r{p6m0vNs6!I41OOsE8&Zrh)NK{s(?7Zzxb9^}Hkx<-pX9Pe z6gG5!j)eJ_SES^b>_Ga@3d!sL8dC{ z0s5c@AX0OVevDNZpE{PQS=Eb40#jEOc{2Sx89Es=OEsfRN;4oF9bfh&!XZ&MXNmq# zME@%2Qgpt`@kG~4sdqUN2@<~f52hIE{AW=`jc2h4XcW_u&=2I48#7R3-GV&KC}JYU zMPYp|S%Jr51(`^NnA7+)mzCvMb$N}82;}vl7srBb$@p9nSE)D!FFNWW>hKN;|1U+?~qu`E*;eYTl48>XlIk zc|2VlFCb6JAn<-R$l&p4noop-ExUdmOQN}0HO+2B;(MPl>f`x60JCN{jBjF;gX5eC&&9Tkft^+?ONUWXrF*y#_x2-Ny!%^Niu2O`JmdoQ7DClX3*3`*7uNR znq|j}oL|)BboaclTCq&akINy-{X~T7kz7?J z2mSRB(bkZ_*MMwEWSD~$5goGThimKXZT-yx#ozI3KlE>#{{sANx=*RhP1-jV_6>nS8Hat=#5rHHrecs|hBQ_arbZ|{CoHUU!? zE;@0Yez{*afe9fEByiupX;wL1B+6+(8n2q=N2!wLqN5)i@qM*Yl}K90o7}k_WgdCr z9A4U3XlZ(r@ELorb43yG0L+aa&sXPpUyt)K>unFvK&h-`$q|^bY&dt}e#s}|Bq0*f z4mR#HtXwwu0O+Zz9^OW*E4z_HHkj*(SfP0(0Zur)iW;*zqZ8BG zvc`~Sf-Qlzc4SY0TP4>gLltew!@h^$LCcw?M^R&KGBcj|qa+~(;?0CChdsgPOSV*4 zH*=dtSJhwe7Uja*z`pf0kW5=y&$~fm?oea(tEL(QLm-aBQ7kC>E@ulQYshE-Q*C)| zSczg)`L*3lp|et3S5A*)qUrFCUs`>-Y9my4arxDerg=_KfetwxjECdPdAkyUF}xzK z-)4s=PR0p=Ducz#uao%`Eu+3Ac#CzZ-XksQ`}%Mb9_Kn&3iaHMJv6`C5);7vHOxGM zSZP$ugg%q{HqFnZd4POZ#$Jo`r2obCL(!zrmq_;aZvAgJR&7i%s%mOSG69GoS&X2_ z${wZ(#p(+48YJFKt1F+Mi$&ArwR!5f4}c#-LM_=*-&dw3rNW8yAfZ5`9mNZ*ZBG{{ z%TyCq|7f*HPmRuV$jYfRDS$tv)S!~&q@)NQ?y#4%wN2@Ixa39o*pw|U6jk_Se_OM^ z|B1_%(~N;3Uwp>dD3Tt_+PD8|{~!di_d0?}Yg20>!>I#us>hg+FTWysTZsP#l2 z#O8Udk2_Odo`kWtpfd&FB=keSe*!uPcj*m3?S(2_413ufrII#!!}*);+s_a*tDRkU zt%iayhu=%BN?8x5qi%R?Gr{-g@Mg%dh_C4~XYUfcRlAFT#H54>n5!x)Po7+CMz71? zRWUJ^m=6pGz$tLz>Mo~*>)m6bh^2M6d4jx5L=emnX7S*z^!vV^N18;ChTnz?-x&KE z6QbBO>ZqoZ?RY7tQ%wow(oNv7$Sd105x{N}llL`JWY@EKQp1D~z1m%B`vlDtKs=Sv zAYO^K-Q_PX3xcsaNI8kQS&>IRf``zb6dGmzGWAo)r5Q#f7ge?uAx4FSCZ!BiTBLZM zZPb?|;Hw*VawlmCbXf~t!cT?0h1|L6L|g{X%H&)9ui77w2I2o?F;Fn*a9%sim96Ke z;Fx8cAk#Ei^67jPWqSJ=tp%>h=gxlCh-n;O>y|!gfU*PrbQlbjd5~fREg^?lB5@I( zEE?KJtu1kOlBNoZ5i*EX4uATo&JPi+70B5KbZ%92Yeq{EDydOki0!jfJM23e#h_tf zj+oj&u7BuH3fB?HcofFbZVHMq5z8OPk*9V*nlqw{6*2^LWF@bCth)$2)D~p;J6!~2 zTndR&lK*EJAb4~5Dnj_G8P z#9scehh%ywxvJ~+j~K5coC45+Ef&dTTVv_E=1R~gcKxvF{%}qht&@%@jH0Y-P%4&n z-VLK{D-(&VqN8$+_M{CjNFzdfTPW`EW2@&3de~c~ zUUewG$AHWEu-N61FZ5+eX|8yU5OU>Y?+}x3i*zmi<9x(W}_S;1Ky9Y)61k?j{GbO=u{==RD`VY4`IncpIvRSKK)zT3P&KKQU%i5^*H%F}| zh#Bz)fe1FR)H^HwZZMCFm-3%zWsN{RQc;iH6C|tIZ$>1Od?pw8H_&!?xzUoLt5@f2 zee@h}Vr=^P^pT|B+ed!Zl!%6WS6YgtZ{$JZ+2H-lfiMGrozLeQ8L7Bvk>K;#&tkst zt7TYA!&*0yQZ+-yfvbyLP-q%yBG9l#+H$ILy3#y31&^MCk6ucH%;xk-)3JZxJ1;%r zt67CRBgUUiR_>o8K#zqC3~xzVRn$=Mi~7DWD9dZ@!+r0IPkae7iAYpF$ri8vQ-@ns zu3hBu9xmZx4wta*hS2NJxEjp*Y3i$l&&Ej+owz{bVtxUT6w)>}#c_d*%kvxA%bz$( zsNoNU?7WSNM;t96P8+$rO-&L!nU@3i$q#HY=ix%P*sOH80gDM=5^LgNW zd*iV-8*+JQv`cUF+9#gzKyd;`2;@-(p0Tc?H(Pvtc5FC5p|KghN&>s*cyGm}R=pgL zZ}OPnAq1IwyT)!k*9_hSoOd|+>UO-^W`()736rM1Qq5+{0-POr7ME8smU;BQT#xB8 z>h%j3S?#5tqT0V&L<<{f>Tu^)f4ltxuUqP5vVJ?S&HVUe57Cf=`J|OSEtJ3qPH^gA z5%9YG?~4^PA5>(Cq8#uLJp0i3U*Uc}##H(zP;Vzs&P@?MUrID(W;H`xabY9_M)VUF zarU4Z!xmFJ$QKw2MXY8Bc*J<5R-!15GBVOl+|qgZpsmFn%6svrs8#dpZ5Be?$xqdf zkQXJog&;I-{gcnbaSrF=*OxJD8H}dAAknc9d{m<(qCPN^wld1; zVZF2#AX>+fBT^TrZdBzMahd)s0^Ow&9BUu)dgN#iYB;fT-tgiQ2CPi2b(S^cs~~D6 zdQ7(V`qk1knH`SOhTtCD*hC>YJZcsF@32)#h|GU&9{8O%oYdAFrg<_o>ZZ!8j70`@ z*EpAIub)|$wf9EE(hzBW*NMv%UNo&u0ddQ1&$&(8egyjCv2+MJu=8r4k8`lKx`+XVAwtpQ9=aOEHQeAW%Wq zF4FW5D7hdO7iX0;jc+5>TWugDToP|o;``G;54}{olhw&vya#U;d>x9B}Q?*kbNWJJL^9~8ORzEl3ji_UY^ z)%77)9^(~KVIHBP#5VFO@I4_tFj8|k=ksoZ&O@zFEBVtMunhtmT!=Y#6xpCHW<2UU zupJ_TmMnS9qwqh-f{&BMF$uXUGG;E_?^lt|^CD~-gUsAC@|fkz31Z{rI@h<6NjhI2 zNHmw_P4scs`;A{ajGag9QUKgGGNQ|Ek(!|T8Veh6XDwkTem${Vea|Fr$OXtG*bN<+ z`DxErl)O!~avwvN?`NgX1K#<^xH)0##4oAA6QGK{xFYA5VtTa+a-EPDoYZuMT@b=> znm%?SD2Yf!FbgouyW{h2kJ~Fq=cT5f)AXJ9EEYY=!`C141$!FGU9*ywMzka{bO?T7 z@O5B+NHzeN8SZjl8Y6ko2@OAbdsG7`^x*yJqnxw)Bkf7D4nZ}s>T6@Vt%~(*BPKJ1 z+C@eReea5}Z!96*I8!e5`jT^5-KYC)0NvT{gH@g9EZp{ARwuy|_6r1n%6l3(h2;fx zTwjrQ2v$GddZvJ4J||T(EN$kcs+L3g2u!EpIZcL1GAAN5Uza8*r>EKc3gj%#eohDP z;O{<6X^jy!UNf>^^Bca>M#{>4ZbAS%7)yY&ev0b8*pG~$XG32a9K%NdwA4l8-skV- z^Jkm(*FH4MyQsHTZ`flfqD~Fb_e0-=lRn^#zYUS)ReW}yVceqiide(H?J!39q{g5# zD1fC@GSX;3M;nF5_GsASHk#>L;nCNMx7#|wc}T~io!F*?=qX`3Vw`9DQC!MJpq{o^ zfz*@;=W_PQxhwYP(J19iv@jTg*c9&aeY+CwdCOP(l6A|AdHY`Q{ETo=WN?Snh_+^W z=(?d}xCPUn`Wa20oy4>Av?E@@#g596k~541ab#&gh^3K|UN~-*#z$T9etFe>UCB&N%1bIZr+qelrrS zx*l=DlL-1fb=Htxod}b}m`%Un!BvR4YTXemzUio^J+*I^C!(ED^f7^|N;B;+-0?0l zFew`+iCJ;p#ywS^F2Coqz%3HeG1;i{gawKZhwK-5-_ns){Z*=ia}rt@!r$L8&~|fu85^ImnD7wGd>< zAh3r&(&Ny>j#x5o8OLd_q(4`Q!VhBQo(JQG(gVm4llMmyt@w=?=QY*9Vfw10N22(Z zzFiMAnE*k&O$1-WxSt#)Q+WbVVJH~A(6C8Xn)<_d-aqIe%PXn)e#4bBHy!mBubI}* z$d<>BaU3#EXhy(H{GevXaZevh&gOBV(&|aa)*FrpH41nd7hHgESAQ|QF1Soh~Y>MV&+5GvBlH z+uLM!txhwZ3FAI>r3C0b3r@L{85e=eEym+6jS?~2Nq1YhLzTC_KOxAnH{yYME zyn5Hwx+7*NbD0s#4v0mI*~?-)&6D5h)cZpdjE zbBPs{NXw|j%n_W<#DE;ggLS17vcvaA+a`%b0b(jv7M+xrq^7@O{lsFr`bg`}$rttG zCJWU^Ae8*eRa_VUbJfJpoxs1<<)uS5@Ab5?yiZEo_r^2E{hWC-f8Il=XVk3gkdAPS zh-hyeta{Z!`iaN*y(1-PHV`%t_aPUs027Uh7!+DgYAb^Zhh)$QQXS^I?;=jEvhlC=n58lnqcDFk2)iQRw{*;($nK zY)(qIF3M{FV;3MRg>p~D{!@V>*l>zHzlP$<$H1P6D^D>ejcze6Z(1fYAEhEyGGCHE z!+=mEZ|K+oVxB-|3hK%SC3d0ICpy)LeLv5r7=)!SrHnfc3!;e1w?>6WLVVj1d~YDW zAXq{*q;upXA%))~(N{Xgru85>xhf3i{Vw~LOP>RR+*UT7LH?K$N0MYlseP{xT2}i6 zaCe?@Y<(Tx7vwcnWIbywUPZM0IlPNzK3(T19)|DQFpwsKCx3*!)%L}Zl?>OfRxi1& zO@yEy8g@x0O3qYQp5-tNqJOO>D+|4g@4@!;;8mDK9r^{IZ5Q*)QD_ZIGdZ_m^T><* zhE0Sixu$^{@xzz^i@(idT`Kp0{3LkWV=yS3Ol=)`MYuFy+l8*Hb>^&>N^)MxzU+;& z!S}>Tx1dtKFw;@5b`V*A+;FqNjc&EpsO1MH%y5&NZa!U|KQ9gW^%+y)D`i;#5Pdj1 z`vmUKA}}L_+_9wB`CWf7A8(Gfn&22(Vf`!P-$BUnk+H|xKpYM?n(@uFqAnx8_#38( zO!+cYOc^@aMk%DTgTM@2EQH5rZgB&k{mltQ5o<*TXQ(#uBjhihA z*?t)OMl=Arp}kh)6A2zQ?^tQYRX6dt+0^Vb+`u!*%IfiG@3GT3`uJJEKTjgKfju?) zKIr6pip{>d;=xeUl|$+i3=17+msWx$(caY*JXdD z8oM`Ti~Y>+5}|U(+xx=DYSYbT7d~AO>`5u*WznLg7rM^-F%PTaN@yTAjwU?~IpJp{ z3NHtJ=R0u*w?pYpNxV*!c6QvskMlP1Aj@JP1w&(iSGe-s| z(rQh1H4MPlF=U13t)ty?;ls;{w5lCu8nOB#6b48){}+SLECm%gSqWl!S=VFI`(^wq zBy7*=9?kNb#^X@?{JAgbbUiLTC#)LNhH(sdU=MwOVVFAaci%9b8r%jg<{K;^%71-Y z`z-E1yZ0OnkoYEdmHDlNwDERf@T5tZ-%> zJyI8T3L7=K{=;wmrxKM3i!yseGA;%=gyiO)04pAys)XtGqGV4YdK9bh6_7V6E&@30 zE?0U6{}aFE7O5vQ17{mJM2OVLS|}h%pJq6`+o$Rey>Kxk)Q+4Fnv2ttF^g9?vLvK1lF9(D5oE9PcA0i-&lapo?5m^!uc~Z z`tGV4F=aRc0S+QR+D5ANt>_jBjy)?G;YH zT(r8E6NQt~hRzAsZmF6Vd1lL=i#n;9vQysIms@+sr5PU-9Wl{~ zQbd^*XSuv=U4(JVhAcpW2+DG0^MMHY*=H8RKftg^icWQWXR7vzQGDAN4N;GoLSBju zuT`ha2;%gyqqfd0WG%BMeGB<~2nP;7v%u^n49n9ny{Y`6RA8wTbOT};-X9|t9Fp)N5C&uZ}$GIlp3Y!&P7r96I=uD{{LtJSmd`5h(u8H zD?o9szdzNoeFkuvF=3MWm=l1Up16R?tSZH9K@!IFuj&PCkrj;iO%!cdb@PY;c~q_= zLo&Xx_(=z%NXj@O;!H%r|Bv!nWh@>E;zReZI;BljZsYL5H!ql)Ktf;%}{XvR)x05yp1rqkT{WAdv>YWkUX zpJ^Gc&c=V=>v8ev1o|T+Hu2XS#30qcU+=9>_WD_H;>7yj|yi$;vt~u)Q-%X>T z0q1gR>qxMz3$Kr~6x;G@xXOc_ZT%DwasKNAi8@c3$uZf3i!`v0EGV0aSd=&!c*1p2 z>h6>mp;tDh8{xCgfq2ovt+6OVWUZ+24H;I9@5tOQf4kS_g5A$ll1x=LsIB&U1e(SX zGumT<(QhMjymDhOH23!3{zD@Ehwe&-jOxjx*Yyanu-qSsx=`zW#UPx&z4&Vk=8${g zwsLim?hsSkkGMu~mWdO|1hWo}84Ww^$BIWCpgx`e%Q%q562&huB_ojz%Y_mSyBPv| z+XCxiE&ztH(3Bk6@1jo)(+(zM@`o^X93>PLt9mB2;ahL4eZ-3JhXRVzHhZVeL-gW6 zYmHrC8=l?Kb%Jfib<~LXE1;u=T7+dTdW63+sSoM*M>13)^AV=P$*W8@%T0K}_P+mYeukqL#SMrvbM+)?9w7psce^7~Ap7vm zczpD!z*A8YPK9hw$7N&D1pV?S(^L9HCZ$aJe%p*HGQrDOqMRJL2u}*%fH0pjy`u|y8o_WS z_`#fP6_0p-Fz0DI5%1ceq$|a8GJ;~UP*}idD!}j9t;;#r@#%j4*oTSqE)cMVz6ME~ zRYe6K?b}+6p9siDCK7?Tf4&jOSWT6A>rn$0zs&%#S2$a2p9r@lQ&)&Jg=Cr*^}C6O zix#!8>Y~%FnZVR1X@?-GL%x_mA?4Db+Lu)@NXw9!5-cm2DMJt8_%kna9%f1*7%eUo z;TY=(oRielw&#}&j+E8Pp^Oa)jj)478`-_F9& zHGqMn8m-QR#*DW?aqpCT%usvu3@PwR@yW9o!J0(qBrMz;C-DD@8x+b*j=7@1>pkM!5E^B$AsHkZRyRPhZY^4d%C9dCI!SsbPgO{bL^ z686RvWVcA!xc=@Gb}X3eJC;aFs0JVaiv3aXtxih9&L~PJ*1SV_C-CP`NuQj}lB{^& z3FcY(Y)!r1c{K@wsu$4F{6@A~7&Md6^*BRwz6cuT0Mpp^=$*rOT$#W6JrodZh8M52 zjj@%Z+MT#MN;h-47Kjwokc9r|>o81)+tdkqSIiYUV;H@%QKaL_@DaT#y5XTgII@_f z!ehA*N-gzUG7C(6oaJ;Ci?Zq}F0)rStP~_#$URbd7#3rm5GfyaE+r9bVY>B3x6esRi%}1FJWE1?C&|mpCOE zU7h?PSzt!0pF`-2Swg3p)olFq{nT@WOmEGt$xu)u{CjH+qP{djcwbu+Nf!)#^%J0-PleV>zU6v=l(wTKd^t8 z_w2P7Ue~oczp{i)KK>J>S0vp5^e-8|?Qr>BY$~4@vnMr5@LGZPr_4h+NBG$X_bZzT zC7a8#_fY~QV}miZ+}7eu3X;X$;M;QC-F1|%C3uu{;ypzEkYjSzV!xIE$@&p1#RK!^ zi6&Hjsu@uJc!2s0cPm@P8>I0AU{P17Q?K8ySIDeSyAy7Zw)_f=wLlh56cuv`# zHl;611m?e(5j3U2rA_*Wfx?M3PR85%J--X5{!%7vfiCTS0#m4eQOsU1TD?MS{_TOe z)7Jlh=XMY8r=6$*Eem}LlsX98ihp=U+X;uz&`Dal@fMIY)uaC(2{AW4bwjYSC-c>Kd5$P!OW_%me$w2m#Ch4W zwhE@RF3R&9L%G4T@SwK_6jGtCGG1GTuN|#(U@oso?>XrG%$Tu<1WoXtO4@_D{=NK} z#;y0~`=cV*0VL>YF!Sa2&5F7IXX?x2)m5|VdgY+ybx;@dQUmmm(eJ9#IOAaPKx-p^ z2Sl4MkdjV;FzeC9ywRT>1ugjBpt!#_B2Kc$$xp=0g)e3F!8c|8erl_bLbAv8f7_h5 zqj+_v*3dNiLbAl8@<(02Zi4|N8)DO8I?y?RDn46E-!kyV6rNhy)P+nC4N!7vX1}|c z#SIgPH>=hElU>gQW0|?dhzLPZlz~t+N#8sT2)t2(ktn2IK`NbMgIrU1vMKDo-iUfQ zcB^Ai$SImbYGpABHiVMU#&D%lhbEUNO$%;L63VrVyZM=2_BYxeI+j-Ku7-xdveSWk ztpi88=DQm%{a2<&p6{|>zK%`U!1R#HUFUfB36dr(vb0;fK>8Mv1t$ge2VaNyr#l82HdMJhvv$$ zV4r208X+rUIa->ag*v%EM{-)X8btfzP)Wssh%c^xq?iI~m7;gv+rgHgWgbAW!HpBg z7-c;nk3|@=CJ3#=0x~$xblnyzzBvoUQ=!{lGk@LHo;x;BwGdvhBRpID^=G_oIySa# znkPv_^@|h6-3~#OZo?lrZo1~Hi>8{*k0e|yGvu5(UYTBoi!R>4j;VaknU{YTVVOp0 ziaA`%LItotE~A}Ob}bH+kzLO_I~^i_dHu@B%n&EZf_%8+jl`Ew|GiipE=HVh?Pd5% zc#8d06Nx+}vMrk!K-NaC$XYWlvLyH{uojcuz(1uGV{{Y}l;^my1zrx?#564E0-J%!_e9v#@%?)if>yoCfrt;=V7@kvg3%gK}$j} z@*(-JB;QkxA%YoH?VnM6kqd{;>o3Ec$KnF3mptdX@E%9U`}hQxcIuPDR+Z;7`E}NQ z(_M#j-Lq5CVPQnDx>7mfo_?oLyo_8-q!RC)nV}SAE#;)GIF$XXY(WIy|DKYLV*Gj4 z|85P2DLn$oAJ?6PaWw|et&)8oKVCgJfVeAD+J#_mdvgQ`RKN}n6dX^J*^bWN`GKW5 z-}H7DdDpZy-xxQ8E6MS8hucVkWJkClqQAhZrK-@n=nW*-3dWSAO2bYf+flw4V=2W# z`FXa)xV&T$4Z6iL*;}mALU_=1Yoe`xr8=DrKbiR8mgCzg%_dIB>O%M{-svCIlxU!! zWMu~*r^JrTEnI*!HA@!VnwE+51=?#F*KfuqS2`{p$kYJTC^pqfH*z~1-F2J)w3Qc% zkhjY`0Wa=e0g)1=FBN1gw+PSuaHK0mAOC2qYw7P!IjJPoNrVHt1aCnUi9>IfUcKw7 znwW&l-TzYWFE`gqJ=)5f@0axXr})tAfg;!`e9H{pU`lN|Xa{`EhFZjALWYD$><}g$ zjhd!jjzgJBm~I*a7y)SsIO5-OSuGWO`VZ`_0Xkf&lO_p&cysHzz27glLJ!Y2-GLck zXM)WCz>$mJ%SH~F%SvMhE9OZa;T0D2cgHLMCH)AjXzAJVGFCdq>Hqk3IvbGj(N*9h z|IttFl=?x|U#Kv@(Nn4e>2z}5glaEz-NE28A0(JrF5*C+`BA+ErkQcJ3TqIoasus& zMoL(biFoR3E?)zTAdU4PFH(cC$YuwvM!F(a%3~!kMd91}?SYY2^TCyuTC>0A#`!!# zszXfF{$PPxkcF@$zYUW!?82y?p{?GZG>>g$LmKmbKZ}cvW77>*+!7M>0X;M-0VE_P z1@Pix{>8y&gOH<=Hj3i0%VNn@$@t0Kz9KwfB;cBtcQ5??@QzF%9X&@2{Ir@j`X-;b zwCdVScy^--pK2N}qM#rLMM=YMl!G@Bm0;y<*+HKSn>=`R;O`F^3+*~?y02ckj~uRl zRk&GWJ;P)ZE?EtaA&>SAu9!A2>Yn?k!+5 zI;;TjOfH8j$xUGsm`(KEK-|gJ>-bMXwcSrO_|?Kp8k$~rGUF!#?~T$b5~5#xBS9<) zFE)9kOn>6Ss;%Dryjpjld`;F2zF{92&KfX!5=4gP<=CTt5RkXBDC+4pK|G2hBKk zg?EUHU>LyoNRT&|aq5Z`-H{*NVtQ!l8C*c#TA*Ca;+20s+ic?;VfsscA+Wx=$A43s zc4k5r1AdHiRC1HCZa=5H2!AA`f7M_I4L zyA(|r=2@X`zqL#AmsK=067zSs``-$Jsx6X#s|2VuP@ZlTb|^pFC>|QKw!Bvl8FxwO zRGjgf!+cOB_M5QO?aM4T;F-JG2f-Fj1VokuHKWk10f-KNf~Q+v3-i{{U$1Pt{WP}S zgQzG=hfsG;0Pg|)q^W9O)^Iy2{4x8FyxPkHM{(4JRDt|yN7r-j zptnB2c~z~uF>_gHJA^VJD4>Ebo`z9E2E-CVw1VtRs_Xp;XGs(WN(p|m5Qe)aKfMlR zp_eWd%_-{%_J;o5X#A{^JqSgVq%0X7nyj(F`m^kK9M(f+gLt_$ z7-zAnl(izi-XXgb0)MG&BqE1ycXHq$N^i9Epu!0nW*}}<5{Qxfv)vdd{Hv`Uej0iYrKOZ;bfg7v)%1zZBg6!B9dW>C&jD%NaJwjN8ONJ zZF{+798V60cw^?aLq!X&4e5=kjdqfz!;TWm*f^e~v=v*nVzQ{K;l=gn}UKWVRDckEnU zX)sq5LdOo5$_+x?F5??Wr;pkQ*a=L@n#0nVdkBVr+Gtq|1S{J%9u|J7Yp4BO&$&AS zM>w}0zu)p9z7o4F84?7iZ_xr7{#fn41K|it^M>J<)w)gjPEy3$Mq{k!N1ED(2Zf`R zk6WJ~UU4|)j{Lw#ai16&|LcCZg2=LH`9&Hv^^{S~pEA4ViM-`yfs2^ms=w(E+0!Du zKa9zn7|ML#L{El9()(t2R-Jp?GF^@BE4B^66_=M0JP45YvB^8YE>?wa$8gj0jD|`k z>y3)AS&_~AR&x22EWRg~o0j4(QvJp(mgboSUtF8<3dADl_ARM|kedL^=o}sCq&y@2)Xh6)S}L(k*J3ZxRz+WOgVPig zZ*Nq89j`?^jr?V zEMP|bNvj)eb0d=*vgJ6(`k|{zXbtWS;<>6pTVr8DxGikc1D>l>1NS z?{gY?-EjG)LTQ&PK_7Diu>J`orntth@!g3fPvmghy}N6u-4w!wud4B6!YP&a7B8 z^Dj7gB`#<+6)C4&-L9r5xFRQv!>;A17c{Oq&HTnS&b1Bd_-D$0@&t9!O7q#*A?8R= zkbYKDi0fMj=9~UU#9R*{D^fl-cZx6IU0>ij{>x^XVb24nA)<|s_jpBkwY~SLr@;H) zbk|`&0|Ua}e%AV?Hy-OgYG0=o%KC8lPO^rnS0V4HCTYy<+_$4m67oNBKz$@?=wzl9 z=4$fz9PG=TBLCnsOD2vGqY}Tzqa80*Au{arksO5z<~bqzC2uSQR%KD*WTu55Zd3Q6yTi{N=z|Z(nF6kr^VjNpH#snordx7_V^Gbv2ITG1& zP#O~7F5BFzYi>?+DqT+SzhAH{E?jqSW5PahQw*x9FIryvLplNIvNr z5giqv0jl%_D9SvGX{PTqkepu`C&`NR%qBAQt%Ed(Lot3aJn6uPV26cIK|UG$ljNgq zq$i*|%wPOMfWWj{95VAGUxo){aZ;1Q46BM~a}Fcu(3FI%)z=)q3e3@^Q6*=H?9yDg zf)CdrXk=F^WQhJ9Nyah^h>Dz{v|YxR$eheZ=}j9--;W>@&K*YWlXqj&=DIb<8cydI zhB=An4Mc3z5E4JQ6^MurV}&^q>xmR;xg;7Fri8NCAxc(W)}{cr#t^=K${?y>SsEux zKSK1xlg(h*ELxGZ5<8by@zt^Y@Z9HKYonVS$YZ!cX@!-=f^e;#I(8~0*$)c^^DNm6 zbC2+0X|6E&4HlQ1tuYi7Iy|=>f_HVtaHR#~k1nSn-q@j{YKjsPMux#9$>}!3DvD-8 z@*I)zyI%a6w>Ai|5%SX(XLPfr@Un-kf9o9Iq6iY4e!pl5} zZ@uW%cm5N8Hr7{Ge)}Ex+fkY_&!2AGskj*qTZO7xzXuyCPUO+uMRJ{>4qo2Y^XtJk zqDa;9G8kI6dJkj6kV9dh+)w4A!cMz{_4a#^f?nKo+=zh9AF^dQ?CGhWTVP>%r&dv( z>%>WyoX{Fgs`^ona*+_D$Nu4>63mq98hE^F2z|9Qx+(fOD!)xH6I}QFkl~(Uhu%N` zt9s!uS_8s9n$k27qnOH^zKW1&7B3kd2<#&l(Ei7d=qx97mXFlc&bE^%!uNgkurKb< z%x7vkv5MLdluoV|qzbA;13%Dg0bLe2W`lnL=FjcU{e<6|0{+QD3B(s8L;YiuFtN(~ zO(^0#sYPMGl3cq~=hWcQKWc&=ZVGWPbc=|#cfKC4FQW7h9)$u50Lb$-X@q|gRmdpL zp;1>0q2wEMyuJ3D&X)u_+>eGXie};^E z6yrNeDrQOFSuV;}jTTv(Hu-dPjtt1&w1+vv&bev?B#JuX{9ufx z&HXZ*ZGl_-PB(fk`&(Q%c!g+kg^dGGYk{hU)aoe~?-G`#{lquSA`QAJc^JhOUQlM- z%%2c8$GztI2brLPj5Ke!wo2x+{Fl$>w1Yv>HB^Mt4a=;4E;E)MD)kMt=Bf$p+bkO_ z6vMb;3Al1K195*!nKL%Dro#juy5(}*J$cN}oF`QVQOx;v$>;@)Y&xs;oh-M%jj(xa zZYcq`s{*g?FBo3T4Ej0J0IFzZAzvcQRez@al3Bw+KxNv`$(D)QAW&`Rlf|i$O975< zWd%BwIfu|*K{cVpz0tb8eP=w09#SeS(OXSS;{9));U0v&Y8`#d*u%0sV zHjhYb4+Ha=;((haKd`5RUttS-OmyK)_GT24+W*!-il+xVyUr8}Dh75b3EUj{v-~}Y zgs5)%Y5dZM%6o~}`BA**P&LJ;OL3_f-ifj3Qbh&Q-$qhp4odO;N?qL#tPyH=BHuR9 zkZd-vc4ew#2!L*Rh_Lr zSVwmr?JVLW<0$*Htx&%x8zsm2rP>7abIkNUZ8JX2$nML(F{&}~J@jd7do@9pdMQeT zCCp%GVOR)?u=9^PFb0+!d^zvhUZ5vG*Zr3-Nuls}HRJv9>|nEh2BjG@_n+~#Q#GTM z&`WZEAqT363y@>R1VX6tV=%D~l7q0F!-4 zl?#Uz94BLQrz9m*c;^w(`M;or;pg%Pl?CubG$zw34a&=iNi2Ql9>d*zGyXkc zTWwSVbxp3eLbj zhS{e{1zQl4Ih|^Dej^S>I(d4MuOl~`{sDC^Q{Z20?B}$AfbAtC{K$U@6!PjH^1oCY zi#+_&a%#5ONbtHn55wh~)&u&UmnT< zmm44k-Y_eZbQ8wdOFRe*>-}X`=FkTxUJD;D_-?U@D5Cfj-q=?tTc{)KQI+Ei(n;zG zW?4OMnfsb3Z9U8ju4tB;7!ie~RT}l9b-$;I7n@tiD*3EgW<$*6(z#TLv&Uy`>h-Q+ zkELGv*Qczgc7K}5L-`5%8q8%|k9k*pBW)+2GTpNf+lPmemme{Jy&l=s@s4kh2OQuN ztycI+m70=%GM5>xIa@1iAt0l=J!WlX+r$NFIBZVHJ;Bd;?EL?+(Y{E!kS|fCHz$S) z$-%vMs=|{wgt5+;wNK9DMCdBJn;DI~POH)5a7`I?Q{ma|%v9>7z_x9< z(NfPzhnq3?QPs#CXiT?ku&^;I(>b~njoI}G-ei5c1MEQJel&(!roUIY{>p4FrwaA9 z+=&ONdBIxiwNqanVWCT#N&2bVYS9sN`y}j0p5$ODU9%`^hR7Nit7u_QUTO*k-u=;R z#I)Cy_Auku)N-KZ9++y4;)O?)p>iCri$NkF8QO(N2zTcw3j?R@?QP%@JZ8BvgVv{+wp&M!^b}$GO0JmVJAm;+pwGP0uE^B?q_AvoU!OT%JC;lp+bKpp6Z)f`3$grZ}681}lzR?b@U z^2CF8DK+^D#NucgcR@GyDf7H5KwH~@$re5Ou>{;+Q%n0$j7;e6uF+wmrM#3YRS7mums}{&PYvM#0ziOh)2HnOQD>LaR#%T zs%fHs(H7`k_;8&Pf4E-pVpI!_?Y8pJT*~2>4?N?85aX1P;h08TXZ5?ePr4|(VL$IP zE~cPM&?TyT$%)4@o#yYiV%9rRDVi+*6(Y2|hmp26OYzFKo@h+&@64BGt9^R+ zQj_bJx(1mtz9DV#FcRjwHX`n~DxG#+624Sgi;W&eUrBh;m`Boh!6m%qi(}eCpU`n= z*Ea=n18?-E^4v0aT76IIu}={z_MKPG@ka6=ot4{gbSK5#REUKPZSC&RT>CCW#pQLw zrc@#0k&+Ffshg|qJV597-XdnnDGr*$lgLX+?C>lJ-pm?NrY5*Ymf@CpmX&uH7;QQa zkv3`(13kQczVH(^ov~zjMKQvym@Drx;Hx_sk|ItQ-(62X>3aVA;ivm(_Jw=7i~~k8 zjhf7JHgDKNWR9ulMQM!+UZw7`%e_O){h@(8Adc+)_Qr+I0fd+G%X;1JD!|GOX9>f^ zx=^vG0nnSqsWo1@gB`@TDrY8tEx9UFPb9NmY`GNog}>xQdkw-|3QTSuu3NSWS^k!A z$O;d&qX;dxg`zyfkk@o?Du1K)^BPd_gR2=HMq*ve?(VbN33CF>{{@lGy%#9 z9`!?h;Qua1Oc1JlQwn?zbC}dx-U_BDY=UL@Y!OJjPBkA6&oD3ksiOt|q4;hXm>8MV zr_G*-2nmbmg|k|kv*@{^{AqIogwdyzM*Vzx`ZS^uHHBt0=&^_>Bf zunFW3d;7MwGo&eO82HT<`s8cqtY+@rXaF{J?=QA$=0|bf>wCQBvX_B<=X`q1OS=)% z+RyP{@2EMP=0f*5hTFEd6)Kt7+Y+|X({Lrwu_(D_V8KV9{Pz-Blm9$lCYXCSTq%OR znps;&l13_Jw(Q~_Hap@!FQ~42<-QwYBu_6uA+z{u7!wM$)y;p4^ zayeR~Xw3(kO0ksUAKDyC@I-2KJWtb{m#-JX;L^gQtn}MLAc}_5dGT+wek1Nfdq)kH z-tJYA(8~^{oowMV=3O8jZZ*f48-9KX;~7XZ{9-I|-9P9raKi2{6u8`hLG<%`H0@@% z`SfAgECzjj6luU_p|2^Cf7+Yl9}+Uf_l&d)EC_9mbp~2W^<8Lq#}bl*mb-^MO!OB^ zRm-=qe~nMZ&_ks zW^>0y*~?bJ9(&dp$}yIG*onVe0vM{v$s~_|)yZdBUZiimO?4P}IdX}QB zgYMbwoBnRlP%xw!h;HYkU$FRQqY(1^p;j!4kfN}lZH%q|u-R4X{22Lp!HoM38gECP zXK{A<7H^)bDg7mHl*AiUNX)%uTejAQ57-tU_(o7&Z_(cUxMrAb9Cx0$x}Vc@F_bpL zP5=A}wxI}CJRls|%He(k{MQr&q)`aM=Jhe;&cbVh&}V!Jd z{qrX1+o2XKQ^A@Z92xULX{H^+cPc{h=WADITBXzrQL)FS*+S*4Qx)m zMGt6|&|6)rWwd{Q6W}j3B+q8NYJuE*UYGt7HOmZILFxP?fGjIg zs~_Sy2%6!5R`vF)=+y5~2~rGwGBF{9c2ZKc=b>kcT!(l>de~a7d1O7?5b5($&aPH~ za%QG1i8Ds9k-F{;LHjw-^xKm;*wWo7jep?+c(-7g%>w34G^8sm!;6?0@F3pv z{$P1}%3`iMXvZ`D6@~gOiW-lVC`h+QQm^1XnWIu$G0{N>N^kVbwjcX?osBEX>{WJxfj$-x&-uB!#Hfj zy-F)^PD;wM?Y&IRG<1@l96nWR^~Bx)v@L~A?Fwtjo(f%ueaVJvXGbEX4JB7#hdsCm z>oh}d+predKvm3o+GoLE`Goe_eZEhXYW-GSlv5v;O!Yp0(hDN`x7h1Ncmf&1N8~6y z@uACn706{6XxNBuVC#V(N~jPYW1^EQ@Hiys>h3{#w<n+CwIeT$_jb!0Le0b>*K?8T+tN;pt>Ez(e+O3+agh-)Lu^NCH>k9 z6!k#<%Xn1i6DuLwJR>pk(zW1>FHq5`kb4vM_VVi4^|;rEm$QW)_Z9AHUH|e^qbH|b zjj3lF%hunX$e=^aBp}|SI+RSnCDZ?L4mHnw{P}}tT*#_kDHvAMbD6hP2WC+{KUq#vWb;5 ze$H){_bDIw9Q8Pf3m={5-zw)M6j{9<4d?s_(I(t7e{6G1ndg#dBNpo0J_t;8X_b{9 zbmMv-{!I%(^&R^E1T#sD3TH@4>j}7D&N^a}k;5`cwThO{r;E2YN1rm8^f+s31ki*M zV-pBb_31D>`=q*0XKI!BZGZt;WRlEeSzW+WhgOXZ<&#Vp{BEE>e8e#R1x`($l>|?; z!DO7gEga1?3*-dDIon^#0`6x8%y>Lsrjf;vmHuk)H=*>4=b8%M!#iT%%e7k84HxT) zaZW$7e3ks2*70NL)ok3i2GI_*wu!b=f~uZPI%ieMIdu4RrfB-+L-Bw73}MTqc&s*X z3mYbaTELp6gN6rsCRupz(Q%(y4S9}6iSg}6w>s5dfpj2QdlU!#qZk)tka{N@`i zy!bZlZX9Zm3;?tO0^V8q3q2uk59_G1W8Y&Vve3DoIS%TaZ{gIviH(le6*EE^t1rml z#cc-#<5MKTLOMzLo)K1Bc6P2y2NpBDL)b7Roi;MPLz9oiv=WP<-`4Uqr=}q21mB@f zXq|s~2rlSZbFl#NgWTWF?*Q^C!GUfzR!X1T$9%LS_X3wIxEzHORSe>Su$B1N{akuK zP;J1k+xf03=bD)CMKUv1AeR-(VFOz62I&NMpPUQ(VVq+y2QAhWg3jtJrx1NOYZ?o) zg>{`KrvypIp1-Z<#w-Rb1P|gP57uM$t`W3ZFm>e5@$SKwvC9C`u{Y!8Y#w=k(pexU zEv5X!IZ_%g5|^0FR&+=oQf4D^>7^N&_g{K{4v}w8WGmFINyoMub4`s8vd|l+hS5$~ z320c>?lz&>(Rl}9%t65brB>HBq3r+&Ouf|(homl+7k;0e)w=7$kuVMkF!);pu`WH$tBhAd#diK-rMBqgU=M;<(pYu`XmyYNdp!d-^^dBKOJDFByOl`x^{A+?Wx$;9?|u#Fq`Xm7b7UzmZ;RO zVKtq##1RI1|xvp+Q}OaI^X{E85QNF#Df zdIO+rGl_j#IhJYD8v$`bDQ89AS5COq`6HR4s3(RF(oZ3!;0;=|OQ~U2ut|OILx7L$ z+%8{LO0+XlCh>V7j#ipngNaf{)COd@g7;lUv)-E6;vs8NMXhGu;8|6d1Gs78%&>>( zDbz$(#{0NIyv@bp%x{s|G@-N|*#z*B^_3+N#ut@4u3HyJ6NX7$ba_i=`Lwa*ba+Ua zaSFTWTG;JM$zz0Qp*}J7V&Q(3^pxt627fgJjsLYyzPNBM;UxL=ts$Xt`X%o?{w(4i zb5SG^%@5s%C1=Hm5n(ecDf2ue@iCJKdN!GJy6wkBGTni{K{ZnYVET!Sb2tLMlf$); za1RUAs;uIXd#%23G;-t!JAM6%pP#1{l8t2awv=~Hx2Q&1Ozn9cVMfZ|ANOuTGP&Td zREHW(*anLr`VqmSx!A@F7ct9*jrKd#K91q7rEu4L%~3~4irjJbd9GYkQO7+}yf4gy zvii>Ztcf*wqIrT+`k{;%XA1goboOb~Xe|E1#Kr%a_Ceq}#;FcO8`rRzV_Row=&2%nKbsQ8VC^0Oju3l0a2R*d|}{wNIDZ(R3ogrsn@U1NCIEYCfOl30qt;pIN@6w)Fx_*oGNT<@=r6l_Vn9wWjRkifR+eWcO@z zd$=T1$@MJv`=+oVB>**)ro`B|vQauj<_sgCiAYOwm_}%wWhx2^S3u)2zA0+4G2oO! zY;(!lr~cbMXLChKsU$h_ElMCXd8A={xOAypp5D#v;k)+4YuZsxIDMX1_+S7hX3ZRB z!T`0AcV=3yCNzRlu1xE^o=n2N_b+Tr@*t)cG_;W9KQ@b!cB0XAU937gvu0? zR7TSjQH%nlWka2Q7)z%V`j^&}2M0Ux1%0}SkH5h6mciY5Jc!G*<7@+7*gM~)iuROFer550VnK#1$vAp5J zo%MgW&xe?CBu-4hnS#SByu+47pPCQ%BQQ$k6yT5B7z4e3@}v|3`jn1@Me^Z^Slyo@p9C4Z3u8@dH*u~Q{aYk+p+<<$0Ej(K;{=aFZ-1kQGzFxP( zt-l7mU~a|oa-*F(?yOWc?RqlyY4@r4<(>Hm6ja4MHj!kMV14#2H6&TspGga;ZT!KA zcGdUaM^=1Ri`M_Sn<1%~70LfyOM01@@MzcusmgF!?_-?3OFhic_3u42}|VwB360VO1L zXkkZXxT?1scLoSZTJ#J3uGLmU+jw;S)OJo0swClMWL2eQIpd3Rdc?)d?Fg#4h1OI< zOVcG?;&P?%HWbbGQYkTabuczM;EWf^=u_?~N?j7*SF<*;WUXnFMWYAv4V*hsBn<{wbmAk#OXI@rULp;hak)|`pPVUB=PUnIs9P~TiT3Bh>@|?~%mB&F4ygw!QFk-!_@M>==^r$! zocPEEP^u!NUhvObK3;aGhU(<%%1~nx62kN|C{$AQ<)TCC=}2(BL=XGhnOxpr6aW}h zRdU49UsJ{$8D>e^lkWd37^AX8BCyF4uqhdG2gonm!~jsNM44d# z#)tES2=7n{QfKknncx{IhOj;u?UQ*D^~}r$ zO)jDv8tSd?)2O~KIh4qXvI<~jdINF>`k+XvQ(u-*$7CWF2}g!2{_Ftg(RIVC#DWo% zObsMEtSFkf7+4IOE6nMBke&2U0k~66vJrw@#lZh9LRlADKFvC+S(e#JiHF@4yl8LD zocFwQ+J)J7AuKba@F5XELQG1-|>% zR0I`SHB3p01tq~F17W5gc`XBF;xw*SJ77kyE$lITbzhFdj4G0X-V@8feSRAwKbIh` zP4*Y{x+_Mb_R%3Fp=lOAMVK=>=0F?S+bky?;#K?cTf5Y4w-_r*!0PvF36L0f06{Ao z6D1~H#I7KKn3$Qa!A~*1oYwhQM!a9bt5bA#`+zTo80D2E)?a4T`ucbX%tU+$B?IOL zGCYc)V9fAEljyqUw(x5rgys8%6)c_H0XCe=MNN#;%c~+>6Xe?AF75hEn|a|C^Z0A$ zhnX$Hw$Q!5eY^x>tbg@Wj)i$h8Yo=q%&vt-uPDqFhApKi*4?=-p%_^?SZiikB5ON7%#H$rk!I+osdGR7<_HtGZ7YA7p z9znK2_juK#z6C~Y>m{P2^rx98t7AQgCwR{&{DrN26?^~nKhKvMrU{?OT{0PX|4O|3 z<%TXS8VLixr~PPel*~v}J>$F6Gieu!@5JWvKd}njr}yx481y%NS?;2@AZvO~pkaPg zu%3vo%5mcVy?5#85G5rUs#{STHS4~Uj6}JUD*zeV`13GqEEopZ@#&2yI)nf50*Lst zgHuZjDOMkx-H*Ihy~m5_=dZd@A|mP%R*b&R7FLVSXafW15`|-pCAm@mf@hXlLWh0i058%T+H%Y|!N zlfWodNE&@lvUiGxk z)C>1`Gr}-TrvPyU6ln^VRH{WgNt7_^q5zn_zmwbP#bd05hL zgXbdrNQB_;p74L`7I4iWvWi)Ms<4{mo=l;_Q4a~(isfiiW(flyOJpw&G0?M;7!ewI zH_T_Pf4TlqQ$P6OjdB*S-t<|FSodSQ-&2dnG-z6AHS(yyVU=dI*=|i(=r9;g6qntj zq=>-+(@JJotLAikdFvx`bWlbIcMgH*oqQ~co>G)rL5JFI`9oRBVV$71yM8Tfr8RIK z_4y*H*Wx3z*Mgso08acL8|%OAPzCzoZ?ZRY2kGSi22&rYtZRQMKzi zGkv;?V;9ZChl^dD!&yG_S**G}KR?cv--F-<(L`;5`Sq}Q=RuF)6@R(lDB~y@MXa|c zd%1BHBO#7>#dd`$BT`Xk%yBy!F5-niRgfJ@JHQz zxY}6z&GWh#@ISpyX&}T~Q-XCF(J%eh+R4KAFl1sriNAhVf_F|Vn9qvYT-t%gFG(9L z=Vo^cqt+sf(l`)DP5)AUyBgN~ziW&eg2*hQ2f(7ErM)JVrcdPg{Lu`AZLMzA_v_x| zJ1bbOS6=URINMljndS?6wI20f!^2`?WGhRcb zT(zZE|M>>I%c@Qz8`7Lal3K#IT8><2CQ7t?=mIAZua+!T3O_rbA`og9cHn#PAp6lB zFCdps$=X)-$?24N)MSl)KV)6)H%|e4RmePpjYs;%nLpYxmv-K5o$2k7X zCa2ob*x%DV=RHlzN8s<_G~xMR`D)E?tTb&`5WxRf;E@0N@UgZ_W9fTA#(Kgo4I9TDCIt50imFXmg!VOXYnU8!jspx{;hd;}2v|oqeud<7V zFfNGZxv9(=?Pw2Mq$Fu5!&TyR!w33vtp2a}f-UdZT23>#UUsi^OlWRSf<+i_NoKFj z)&WUz^HJR`^)*gKJ);qZ+8e%GAO1;kU*=EPXrL2{Z$o(b`hdHZ<)BHw;9dj#ovoYc54R%+gYe}3#L@xcB-@ER!mu=rx8 zr{|-h1Mm)!ln#%xaj>LbQ$xMZ&FinvPX_%K1xK)Z_{pCiVax5Y&VB6xV7-&;B7Zb9uic7O=cm=`5nQW7;3M-kNyNgV%_{g?|YuiEFagzfSvH1GQY zj;n?TB}a@zW8w;4jKrG)C>a1_8goL$@M4^78>ODiMTL8D0*h*G(B@8oY7M_@q}DeS zvrRV1kJmt*LKKenTTd=Z#1`JAY*zZDTFUQ#I#S=E$J2w4R{wuoU3FB}S=UuU2?c?N z?vzgH2I-Jcq`SL2C8awg1q22&)H}1vm*zM zC9Om9%Yo&O)LP%A6l22<>*d|GTGv&KNPK9Nk^9TaV`)j`-baA*!m?Cbq8k~DUoKXELc%PIf zmzpS^v^w>)bK7pYE5%lAz)#2XPz;yLHjD3|6?VY9;vV=`q*{2sQFxViy7eH-^N@Dl zpJQkoXuijLWvUzCJRkHhSh=k6yy%=iPiU%CPjud#AH^1iR_Mvl^IUw|`^Db=h~Tfu zG~Zubs&f`l$!)zPOF=#wHeBu5>v`|LkFMtb_(7PTwUc zNOn%@+!`<4aqDNVD&O8@g#@q-A^)t}uiE-xrF8;`wxbMzQb>vPURNh9WM^yrsjEPN zC|dlns!J|SHci_D4CZGi<*&Ax-`mVDts2_RxV@x!Rnw)4ix%a|jYwE%^gC#viE@Uk7#&td2MYiF)|5GR!Ftl2i=XSg%Zm3gZ zoj%k*ReyfW?+qLWQ=B36G{qW^M;*!x)`Re^Z3*1=&$h=0-=+c2G^H=nnEP?=Z)p&| zKEl8fbKvnpONgEAbVpIl96BC>r`SFkd z1-)vUX#2ts!pLpWXzK1j2L(hlubI%ajBV*sjPSdd_u~5c*_3UVq=#ia^=U~6q_K!@ zBBXq647_9ztGB-Nk5#Px_`8|_D7BwGd8@0Itb9AF-~HXSOm)=i>T@Ybc*F zH<&FP9*AFb;>sXKMdhyd+4KbL&$u!1ODOQUnci1Yrq9O<)z~&CD_#n8cP3X45KmWI z#R30Fb(LaGGxXpQ`0@G=qhE7v=9{~=V#jYz$91UAh>KRJ4eczwzkP3^8CWu0oSCmQ zi&J9~j8kG>_Czvhy+i33}USd5y~bSj0>=D+?(af=nia4FBt&FukhgL+d3 z$zxtBX*oUO#$uT2I0K*9Wq^wvD*0<=g#w+H=99hI2FWO)mvPxwOnY??BL!YLok2ac zOSJhNbmX2bc*?vDjk$pdJx|Q8JH}JL9HIP#73#?}EcPj|*9cc>A(XC|S&u&r{Lp>0 zHiS5wv(EKUe{^X?hUpZqAq0Bz))!6TF>9+ePCit2WJ&*Qg(M_IFBTu=cuSKaQaCmx zEscQdH5)B?|6~yYBC^;GDQZwpk06!jA*u)SOwn*4jV!Kmc^fD>?9L_Fb`Uz;`VgTB z%oI?>A7R~L2D;6{YLe!#+_5RuEY(=QbIXT}-Y--l>s^70cv{x4zMIQqx;Z!}aU+o| z3K8KH*(`Jy>FQ=rvoDh8?@jb9`Kcnyif15(86JDwn(J=pvnrT@Vb|9BVvZUd~!D1H}Ky_)Ik{qBv z7ELM|KC$MJ;m`!w`+OElZoE3{0-gM!@)l!-F|Pwoc1ca}XeUgVDm>dr0VOt=sZdy5nevD&Tc>5)9nFu>O^nZ72PcK6Y+V3*R1 zA4{OD8`JSof6s#W^^qFOKGe?y9*qg%0~xZTAY#za(*)EKkvr3}rpqY5&f%kIF`>v+ z28!}Gq0wnFUsqbH`f5#)WF#5>zjAumjW9EXl$2tb^Ts!ZnMi|FvG|N? zpY@o$VYq3Vx8jQrUbo=HAeu%Uyjk*TQ55>VZbIq0f|j*P*vZt)xz~Jc&3)K`5pmGf zH$-_EE-u5SzCE0fm=a;8<&q_$7!$Zx3t>0Y>!}-Ri@8-x(oo-LN#&@i)HlqgRo93F zu7#SSGLq_zc75UD&&UOob_{Q%Lf;qWWSsy`W)Ct`qiz>%-a1e5F+0jvP83t&f5C|UbHwR5XML`aO{gFwwQF+ z(#q5%=k=FBYB5P@{a5cFTLf&@qqK>E*;Nc2K?dnOPL>JdiRbBoOD<+u1A${n^uSz_ zc6eXdY(Vsy)&m^kiTumemlMn$f9u{H7+o+!Z0`DL`b~qETa=H#a%d@4gdbhOY2Yd@`(heWmu zq0*}yRUOK5h{&*;EE{YMZ4MM!1sfQXp?;?XmB%5cjfM;J%}y<3qVNl05q^;ojTo2u z(X8ije_P))WMgZr$bz2JAf_V$hC=K$)pmL3KsOO@jbl_kvu1;{)f;xLofMi+Dg_Yo zTdhGJpVJI^X|rGvYUF)vt<&9P72n+Jh9U=)-s{1(+NisM|d`C3J;?MJ2UxCy3cgbNJ~gf5Wf8aRYidYHJ18To+_#LSRv(l2UF2#gdqfsh2@h zGVDA`u;2PdxVlnpr7QPKee379m&D!&WtT$z$JSwzdv1P)fr;eNzEv4H)aRS|nM9Qn zthNh6OowG$)HK=Lof6sx@O?!ZHSYDgSXNl|i>$CU3}fn%*<_uf8q^#-of2cp3We_q z63v$O_u=95dG~7D1KdlO$O9)}6GRugar`$oH@kK(b}9zX@IqNotc*=kKTZ}1Bchm( z6>d@rOvzZ0;rQ@brk2lvEj@~AjH+92gvBGuH7zl*D?&n*<7p(ZitSnxU6BaqDIx|{ z@*ee+dQ3&-)wnk;*5fMQLe+ColbnApIKXs(dwi`o8X8mi;l})E+`czUX7NJ}EOF^} zPl16>!XAIU`|Eh}PK=;zG8x9D5}$*+ZdQ{4RP?RvUkcHdGo|ks>uX#1t~Gftjkh3D z((hJNc3=w_<~%HNt7>_+9eZi+S#0T%RGrRYnt*i zpx1(0X{0kX@I!)?MGc?H;Jo{G(bC}2aJ3P!b4%@wYlO|`0(RuM{h_Lv8sg4v#U+%jmqAA03^5(qg<2%pTcv(eqJjGVg!f_9)>z9O}$RNA+Y;^q9pd*^Eoo z{y5o@1=~525%Kv)_BK)Wj?jj^dQzgr&z2@%nx4Wu?jrKsE~=3&VlHdD&(i_n4U z>L}P>nCp!#%{xxb>uZCVHnH(TBM~sGjc&)ftGwN{hV%AN264Ws@gss|ymF9U%O*em zRH9a4yy!LGK_ip;r> zHXFz03DVZR&fSRJ1o1g6sbv{Ec1A!>*EB&twKM1@Cw1+jt&!#x+VEb-t4hjOH0(Xq z(&E^;y2W$ovxVk$*PB7X`{Zw|?e#6k)y1{jmusmu;Z-!#%0H{ex2t#VuqHhmYO865 zh!~G}{<9C!8(OB_w3Rb3Q_;L>cRCR1tF z(;OnxJdbFOM$_uLW`}M`@v-7e9csh87no*IZ&u7?6fHOH<&Z_GUh92s6)g~6KP_}Q z`);6-cIrHzv0VL?$0Jfh!!o@;akfN9@NzMjShi4ForATZq94v`no+ZMNK+o$ybDr^ zDC;^`|7yB=h6mYzY|3(oAh=Cc&no@YxrN%hI>Nz%fsw{_glyQYxYX;~#kxC^u+#j_ zxC2#+-e(ezo5Su@uQMCB(l+i4v*`PFH66U`zAk=X;(9!ny>Y!&P=W_l_VF5RN)Ke* zXeOh;*f_YW81kB(KP{~IQhGe#t`1YdeD*SqfO~M$d-GPV{5+S;GVHv>TrBz9fbieg z+wXGOkCnU?)iV$?F60UK+n{GnD&ATb6^=WOp(`tEt-Cmhks%(EGCc|*(FH2SNq$M1 z6tjbT$i%w$;x0F}Xp+6}XP$xT)K9imCg!;dCVfgZnfJ7I?*}In#qh2161qXY zqUq&oCc%{2!26%nVoIxDLO zhXD%FSLVYIIRw%7mg;Y?-k}5%$E~VvHw6>9_ZWV0j_gd1kE4>aSCImFA$Q*OD~zXQ z3WoHB%rOy8R>n878h5wnI_(`q#HKQ6(PhHD!D@9@i`PMA=rk}RAF98KV6Wp_*M3LH zc0Bh1=AIo?ZHF#|7>5V^J#81c5GJ*=-RYMrop1u4Hq3EXpA&VwFFOr2Oaz-5Z-b|5 zv~}zdAoj$E|&zMoIn*6nug=N>!RJ~8F5 z5e-(3nLK}a>D=Y=;>D96)w>#`0%UqmgKXg!m*3mIy7GZ7PTB9xAtz4I8M>gMQX{P~5+^c2H(`Zb@iUV4lBx!V5mfb)RY zbksh3U+FCf9wY-Q`{L$6mB?@nH{gD=csnPo?Y>D#{v#bseCmpgNKE7S9!}UEX;D+1 zF%A5u2RkA(0eQ<#?tUXDD!iexrMh#q+uIAdQ;ACN^E7YDIdEo0u)k^2Zg4JApvZk> z39qQ_1Gt#D!ZC^8z})vF0A}I|?*Xj%YQ(5)y!^lb1^_YWCW&_M;sRKE`vsta>S|p=K}q%k}w|6=3omXw|J1?_m_NRtv-9m{{pwmlm#G4IM$I!a6-<0VBind? z_w>axQA#>;xWuT+#lCp{hH;W?%0TI6QyMd!aF<>$7dz53gWaiap#amDyHiz|^%dp& zSy>9N{M$ZaFPr4$8$snb=SfOL!adI>Uxtf~F1{e%ZFJJ8hbyGasS2uS8ZC0WJX#g! z%cf&SW|JPBiWoDmp4i?!6FL=3uko5FvVs;B<*X9%eTNj+{`Q-a*u&gv2V&}xNu>f6h6mte=kw&zKG|%?C1-eI6htZ|H~*^$ z2L#{jvm|L$;2{Z(=ZM_wIltbxNsXlrfF&@9**Bv@!9Jk;e8a5oF_^X!8$#AXQgc-&L*| z5-2c8Jn>S6NX` z2CKE8?R6^WcD?H&cLXW;T*eR2eogazcFrorKa;Eb*pUG%BtfEAjeqb%f~*(r^_Hqy zi#1yZdua3=CGShjkA&*bN}D|Ch)=(mU(!tt{Z`|OBEmGYllaUu2K9f98RyBB0D2l9Qkns`MZ7~qm@aI?T z@0EW@Fqa#(eiOr^7u7Bun5cDwVy^^xFQ)*h_=)|hm2 zyRtv=`37GUIs-Z%9#jB7Q;zyooIg_LU$z08CHCLb`N!*422Wx1_Tcx|!WqOAf_E1N z%XmE#hBuD}(U(H=W;X6fU=sSOu{)ejLd-3bZ3xAz`oEgJSgf|5M4{{ElofNG@E-Q< zPp5oE@x*S>2iLKe#O*5OC5h(SUTm^-2B`DA_k?=6;m5|itL>u)jF65x@`r;k z1nC=ON#aFZ4}=O|B+aqArlSj@{hE1Zr)7Yjh(3D81nKf)_#~-f>DASvvd8&9`Z;IA z4LLZM+x0a`cdK|_ASk?YL<(+pC{`)L>sT{y{-xc0*O3Bysxjf_<2Cu+vQL8O*yc$f z8*#CCnGi2{f!UWSYImP`^%Ga&eX2p0Nm=8 zH#WDLa?ijkqbwT% zDU>xLnP%ENexN{BMioA2m17?u03Bgb00 zXTg+lc3_g5eM>nyAV=-Nw+WAPnfH(Zsyx>$I+@j*yVE3TmnkV<4AbfAqRWOuVAGV0 z69h0|RxFQaib4f16X{ACM=Vd944C7gs9jyT@5pASHLA>wI+pBlRi7%te0ePd-=hTc zZT4TdJ+)uEoG)W_rEYHOJOC4!07OHl+qnXHW^Z2+@tx=kYp9i5?7Ke701;;Y)8`P0 zxYocQ28zbs3hUJUWdTAVvTsC1f*;@NX^lQBTPBJFfPD(;DA6`le<1s-v2!{^6F3W) zEY;o~w4-)0{M44fR?Mi$rWbon8|8+e+gn#DLY5v$$ct35J|b5w9)Tww@)?=3q<3I| zrR=cUYFb|t6Pr;pB$sd=>O*($PiOw*s+729CSbR=d3uMya3awwr0%_#`+2j%lau|Y zNvF$Rshef!)Yvdl{AbA@H+x>wLI{dBdcI%s+D;lJ^@?F@y=8P57Cyts+TgNZk>oz^ zV>^Gpm4S{x0&}L*@#s^z{JZ~z;$t7UjckeG!@KK!&coZnTI0^z592FH==?JF_N+6) z1>|%#4soZI!v0r1BO1ti{$-Lc(BNaNGVLZoHbSVMSCsI@hY|c?NZ6gO{xQeDDIV|& z%hy)#OoMQgwYLIg^(sHGxgohcvmJ7xhyCQb93ykDkdxE4Scm>*gS$t{_Vy?J!6#9Z;A3iE8MK7uqtN1fR>(9D)d*9{O?e2zg={{N0EYEGCl|9oZ1 z<-3OcW;&M{yI?7}MXb&+*~hEyZ5fXRNLVx_TLpX40=X{dY{5~>(x5VNtjFD&-+#4Jtw#U2wT`zvIXjurY*bG--S7oZ(%uAKE z$31J~(TQoT$5VFX15o=HofdDAvVN>;ChA8@z7878lg`uC)^V9@1EO6UHY>mnBQ~A4 zhAh&M;&q2YFH}sUq&6lkQ{yCuop_m6Ttcjk=iu?CvoSWC1YH*lx zkSx&M(w2Ngwz3Np>NjZhEcz?zi z#rTc4(^5a=ts4=;X8*}s+Yl6Fm%~yNHfdAR(|6H`(#bwGHCv1qAAxp^6sX0H0$cbD z(9FcRrw2T?vAU^6imz;{_-+m)Rn?lGS~StCUIgkjlEew8jw@JJxU0!CF5#{jWk+1+ zJP~ixq_GXn&HK_5csszxI2?XmJI@;1MBrJreQ|R7Q+8c z0sB)9{?LpN$ zGfJ~%(kTnqVqL^okk&{|RdTC!MfkuPz>%jqL5llp416aN!(MYta?`l(Cd5rwC$f}; zC(e6o(7)Gl_)_NHVQVV-eU#y3cdkjJxamy2^0H{b_Nk)5_>bBoY)xCgUUZ9wMLa7+ zWMsBR9PE)4q4whWqtac}%Gp{wWp51D^(lMGmz=*!O=s)5Uk@m@6@I_JYk14pvc$SP z)z2-PdKRJSb^2>fy}V2%yHFP$zuy0UYMaRiw9%*`r=IAaiK?HpL~Cg145L>4TY14- z$2dsWn8WuOlg}?EK@$=e%r;MR9Fba^NTXgvt$)jAyhwl$&Fix3m!K2B=_jH=1kV}n z&m62&qD_eF8$Jd^=jN;{ZRX!qvo&_`sTht*>fM`1oLp;OV``COr4`j)URxnv*VZcrHKtYCY+= zux6vkA8)_ue{!%K7)1I!laFu-;K?6d5%{ZM0@Yg3fm|R!sMoLg8;zUjgQ^s4v-As!cP^L-$|8b7h5wPn|SYf6k($ z$+(b+MqujLI6pw}=u~!dcHQ!uSD#|(PL30?b{)+~r5P;9qVreRGuMB_3i>3)L|Mezj_BdCy`|_ciO5}B-=n!coL-t{^I+fFggO6H(hXE)3!#p7J z7|nd55jf)UC=TF4dSx@b$ldbeow?Bo6zlR_Yu)tAkvsf?obI#MN zsi_&ys>m)UmN@TDrN~Y^$9r{vUgf&`9nxi;i)lETCr47w03Pa2mBVU=9+W!q&OL^^ zEw$ZC$(3izjT_dDpoL2wJ~9L78X0Cj`^5NtVceb$4%=^Ol{e&r}-!z~9{d|8tP!f`Fm1@S?Z6)FPhpb)FqciFjHoG8 zlmnA)P3(1$C^Z3v%bZg|rIkxLuK%*S-rzuYU6n%?lx3Ms$%8pwzlv{ zP)SKC;E=)R=1`&}amWAo55PQJ9L|wIjbh&XRSH88EefDPxi0H<$J!v!Km>>}lhJsw z)_`(-$=^K^5?w?PZmn}X>9zknhJ}nMbpyph9UZ?l@6~Vf!K7nOPEfsi^;R3OejGBo zDbWs5ItGve_5{pG*Q;Y4i1%w8=?jUgD~`EA6}<|W6483?K`A^90@~NN=krj2kVJ3f z$?0jOxNEn!?E+~4qikV2_mq=^jA9As;T?fGOj=Vj&CF(84~4b|6&g5Nx1QngaE8VI z{P~uRmu@H)3P20ln;#s+gD?UO~HKom{+VJA8U203v%L%nC=4K)|hr)$=tR{(J{QmeL1Nol!_ zNlc`|cqz}9^{DsEP>3`RCI^#P%|@(&ZIEx2Sub3SPWH%CjQ-4<)vaI6B%LzT^XQ`* z@%j%3kF%W^TsC7#Xd*+uomok+!2$c$)mdBLN+W7zV_$DC3*YW_AzAq-_h09nkTA?m z>VOZv7GqLCaInnVxA7g_-Kj07d@i+NNYTO9C>t05UPdIDzRHIBv5ELLjl-U{z!nwZ zP!vv3mHAK_%pK(4p=}FB9yIiH-l?a~n*(^hwh4`Ee+It>NP*X+7M6aI-1}~OECynS zhxB?u+pBj039s>ZfOoAuk#I1h;H!oQ)Ah-w0i0w5l?T)MVCH^GebMn-f{w^te+_TR z=ZJ_bO!d7cCMKywMUQ%6c{BZSq?!I&_dWI=D;1vjE7VnOWz{&P)-zN_|Ay|zKt z8)mxL0|UwBIUg(Q$W6rhy!#lTHJTEPHa- z+)9b`YWf277okF+`ib+ty>jcwMPfZA%hwxk?HhcV?ihOm9ELK^_#__3X4B0^++x-v z#PtGl9TM|maNz@Y20#MK`y;+zb1r%cXZv<`>G|er?Q(t=X`DxQNSI`LMjeWN#U#G; zHdtf{lnk8(H0KQNlHU~MueER&=dR2TaB4r@}{S3oF8Jqo3;-$}WzvI)ug)R-8U% z3DEvqxECDbd&_H6M6wwqC*yM0UjwtUc;%u5g7%_o=<`1~cn`=nWh*Ki=pIEw85{ak z+^oRGEpb`&1Kw+q5Gwp!!UMF_eU~YXYD<=}Ocmcs;^^e?K89{uP7?(T^}HnK4)dNw@;D@Yv0JfCu#ZuafVE6}iTh zL4&_#)Ce6fRJU@(7ArIg>~2mfxH7%K{qsjr&7Ap%9bPpz_Gi(sM|Pnf?(($oi1E_B zCJrx16Nu$|hs^A@ZBW$n|Jt1WgnfOcFF7+c=){jEno+uGLA^xq(@FN9dC_CaM=%ht zLh4sWKOiZ5Zspk6p|36395)oWK~ywNd9Xk8g>8`6@f!{ecHY+fakL73pa?ps;68!$ znbJ(v+8H(Aflnomw!nMHiL{VQNw7fE&R#~ik=dHC2w z3K!eiOCt;Z-DHpVO?_lQ0xEEok&zKu_&^eG-7GN@v1;D^#?bfM)U}{vW1IZ3>(Qo@8au`qNW91G044dN zNbsjLG+yIc+u_V?kaycr=das=2@?{#(kKRtqshgw`rnHqfV_?S-=q zM1$GsDxsLusKRvbi%%Ldaw2(t(4j23%zM4$b>2BJm(hk0ZN_S+`~d&&X6`;Y8Rr}5 zx~4GwnoDIRmVEkG3E)SbC?qTxOpX=EsQGVXAzsiA@U)@8gyI&ZFZWf#7u6Vx$#NrY znetP}lx1T(sFr*CQrH5Ed->ih4y$i!*>z%y=tXvpxjEtZK7F8WMc{K{C0~AgnL&+) zh6aue+9650->(+#5h%=H7pOKN|B6o9mybiGWfJMpbQB{C_!k2(avw;A=8KhQnqa#0 z_@}~m2D9}}a{N)_B|1!DSPVx5yiBzhOJV%M3BvIPX>W=X?1buwnhOiS-R&YHlxB2p z|E*=B_IpGIn(2>b>C^xCS4Of*esI`Le695pOAzpen;macRT?E1aK z62w+pG|j_!wxEvyKgDh{r}>H9LM2Nen$C2W+iZlQ0?vL3YTS|c$VyD5;rU9{*34fI zwa`PE1+x<4vG26{uWyOz>uYm_D^J72qt4^BMWLssNA&m)7}?Y4`~xtH|6VyeU&$@X0yucuD(77^pKn^ORk{_N+|i6h7Q-s6I~4OKRNycM`y!D!hVm!%%9FnLq)maY{%!NC3q?#q$T z6mNVu1n;KmaKJNXHj`+sJgsPOhJc=vT z0Q`){ep7~PR3hder}d2L0N=5!iSq3Gzm*FwhTueC+|PL2{=GZCXod5{C|8JIE^t5H zGTw%Kfw4*%sC$#bDrUOds}FL<;)cDWKh_^t7+qu4n~rKVl*a?2*pC223?%yCb0E!* zi;YD}8%6s4Tm7T~_$k!nz+?0KUmiZEpYO})jEp@s|0;wP4i=W-pVK^Vavn{8?y0pH zXLJL--o7#Ud3Bx)_pNVjmhc(uOK;EasygZlDF9d)pb4{#2( zPtQmwapM`B=p?jD@WLf}&vEs3bda43xBAHV(k11dnkP7{`$v;LoT ziHrUf@X7LBEDpsBBvS*xzJ>ShfN&tGEhU}P09PrX5+*fWVB8BBj>(vsel23v(3U9Z z1#$2G>)3Z4q%XUh4MP4%+QLsD3Sh6HYjD};0Ex;@0YI3KKsJ`@&RV+U2(ObU|K|6) zEdzn6MlU-h`Ojr5gcvX22l~IC#p)j@a7(a9nk1OT{v{eVP4DvFWNHgZ=9F>( zo`o6M`yR6lBiS%$RG&1g1R`T&)ppsmBdJe<((IwY7;jp8o1(e?IhZK6{&GJUiN`BF z@ppLoQ-QZHoHL62uMZyI`WcN2d{llyuD~v*?Xib^qK`YDdDBc&*rhO<$G8s%0~$SA zS=`}Fn4e}JI^(vUZVX>Nz!*HP9AG(|9r*h7YuBj>=L+L~bbQWHZRMC6=UvBd`5vd> zNM1oBu9GhgD*@uC-c~!o^#>#yuXh4;7p(p2)-xUc=oR^6R7|L4vxeJYogXI z8i8WfvbLYRfxR%#=~Usxs=#tc!3pMw{E{wMBPAtubT(}hCdX6slADeWYQXY7OA)>>SHQlAP91;e-;h?0SL7GqgC5kPKMwt>G#S*<`_2{ zbi@1KDJA`IC(`!hPPo7K^FQB?pVR^6XF!~hlbfHPgq}Jgcht_#riQY=4ZIvIUQ5iGtZxGk znS_rRFY#pFtk?femf``J08VtHriyyT-&@RInnH}xTgA2V8azPDjPtaWIQ`00A!b&E zpwIQ<;-dZetjjeoB|yicq9Yib1eg82n^g)g-cY^yM5dhQxx6uUt<6>9 zw)rI~7ieV4y>Hzsj6EVP*1Z9*c?B?o6R6}qab1mS{l4FXR1gCR*LPc6|B3-x=EtE* zl{kD4T8XMmhd&@&0FYS$4g1p&ca=W-YP!v4Ospb>9&WIlUt%-eX&HO-Dm(8@m<5PT zk8wX)Z?zaJ)}q^;uHhVu>XWs)*3;1L9>;jYM+zPzbKSn0#(I$pWJv6mp5y(^fHvax zfOMjry6#NpT`Uh#;t_{^m?4fxer5d2$6}=uTPGIdjVax8{IR4tFLxzg^66|uH9HlnU&8^i4)`r2cy9z zFS9*nwGv)zBJHKRDVNGITT(?<0#uh05xQ4^zV7%a6! zCK;KKChhE4)-8q7tpM=v6=i|&cu={`{3f>&}>lth}@r=O! z|F=yRlBCp5Wi0xDw&1U#P1Hh&+68M6>6W$HZjfOpqs`btio$_v(dh*JrVAb2{2Rh} zh_|c`IBJzi0JGHe0Ew7^c42;J8Uw%tqZiwQp>b~nXcQF{*9fM$N@}cj$8L8Lf=w7B z7l}-^$BK@|%Y9Z-&E`p-EK(qthsho>UTFJoupC18$NpR6p_Kdh}Wk!aA>(SZ|F26}zv9_Q9<#Gz5u3bnU@ zqy+R9L@^;D2vHYL8@g_&JfAr2KY7YCX7KIzEP#eS`L5;=XMr5uHn6sh1#4=Vn;mwN2l#O#9!WpVHh2)lmM~!ho{;} zm}}TFuB`g z1w3EULtSR@b~P*#Vy3mG7B`s6X51GKdWdiFICxOTGG6wq`j;e1>B##{;2_ccphkQS z|FlNMBB-|?8ecdw8=IO$X*HEb?Xcbt8$7xSGS2`DXVJQyawt+r)SgG%;c<8ZwU|c! z#YS4o-ft|NO9}KtR$}b)=~{U%ZA~*`Sg^f6w-|2fKgs12D3 zr^a$jk;@Ug#y&A;3JO|QdG%^@nsHP@Dp;nv9z#1KUgttjK-|7GScx+1a@u#WwzIQ4TJT3jD&kVx z@tkEq*~>r1jlR_iF%b(b0Z0H%^y5@3n%E5QtIf8Z$@bv+P}i`c2f3Q+Jzq)yQX$j|hae$Yxv z$;q)>&D``CkE0$vIC{(RNoG(#C(?%9@cW%^JtBV*;PY%3BP`_#l+gX012oAnV1|n-KB8Wp#+Lwb zN%wc80}m;w+2=6~&&JoL@tJ!=X4EwT`eot(PSu`JQ2+l1LKY&udL=>zToJ#8=~N|6Tm8)@_u1_CmbjZMGQ7MD@Ndfe7|Mpp2^IGkW~< z?&uTEH;XJUp|z+wF0VAI-Ym5`HChCO)q*tZ>{^in~|^YM|2$q5zd7G<;D~0oF5DuE2;Xv5$-t@Rf;8pG5#$fA9W`{L;48d+pNQ6hY&9_5lOX8)zE!$;> z0|vI)K=mpfL`ME|8PLIz9dZ)rsUzO7g(oVUMRndgm&`zWb*jg7Fi%JH^_Hj$~W2n&Mu zM`8K`Ns}h@0ycG-MLQha+_)?+_F1Lu2(S~ki_@VXx@bXc#)0a_wJYE0W#GiZf&xO= z$`WfP&5PNQQSoP})ecJSWp#=D6Ikm*jMO;UR*YH`vpcG9g6L(V+iR0#QC3pFO}`o< z{=G}llKT19_~xFO5>pi()Y`RE;a+Z#uW4wNtouv5!qVNwUW5my;;bOW%Hdx;=VwJe za+~B^`4q=zi`|H;$%wZR)UzLUAKmOV7>qAd?zrPxAC6-eR%ta&)k4aP5PP~k{?I+@ ztGRS^DcjGv5wHKPk1U&q1L-RPqE3#Q23zwV0#cJQblsXAf#FA$eNd>M1&2O~QW*4pBeN)#1c+G5bNu{P|HO>RXro2<=TLFww5U|^ zEJ{=rCD|2@7Q!>W>&p)e*SV#=c9V(LCZfS8?4JuFdA6t>02>}OZnS9tqu zt+8(R(L#o4)n-Fa`3JxI9sNs*Al@vY8zi0gZ3Zq>$4K9tu6TR zg1NgP`=akZ-?Rk}0MsGn=|0R-l~wLPImB?(kCUL3eH`58KdIxsT}|7xu&aFnWIZNm zQb{}jiI&xP;0yd=%jsBs5;zb^W~vW68MKPp+uA8uS)b`yn@fp!X6Js{7t>E_i1ung zeci+CkY06w40-F^49EjPXxz_<1!iP@KqGjoax(c zZ&<_K9Ij{>k3DoXt1XMY&Z~Qm%>Tb{6iTMsaz*!t9CzCCtDUfU;Ui)vZ+s|EjbxyN zzkPBrisBd?4qV!~`+dy-!LWw!S%$wC@s3Y{@w(yCccwQ_P@7*rIT3tQUZJdao4o3T zJ6odm*7u|>`|0o9>tPKnREmd(gv4t%4S;C`#BsQ6&0?}U_tDWt6@W}MPsO3{j1nlx z_i`AyGsNoVgCI@@1sUh8V}<2RtrX}Q(hClxP`2D%g`MpC_(^zD&S?rC`# zb%wsX+~afowEVofb9@P{doOrhck^dig{EES>YBzTkmLUVII&IfQhVNQS1KmQUCyr3 zKeJ7cu)Y=(lLmae1@D^#&$~%%``xPXUKLfbprF?{5*7k3fk6RKgQ$qtN~x0}DO@Ue zoC0HfGVrkzs^!sj`(F7KXc#O#A>(n z`av!6#U)d_cFbFE&()Y=60Wl9cS=Y8NvIPvbQxGg;;)5CQFTVUsKlWwy>YqPO;go@ z*0AxdZGkN$S(j1=#gTpYDzoQ$1B4f;sG((cEcVv(VJpQAHr?%xqJqTKN#5IsS8 zJoo0@KNAy$-ywe+8Q#RwY&SVQjuzyz@gH?Osp#I{(b+_Lu>U_8W4q`<`}XP%)|ywO{uYn`XjR)&yOZ1T{b| zL-0HEMLz54w{GCY+$9OH>n!xw)4bk$mlO38Nkk~fqV!n)pPJcf=bV0pAW2xA|9yo& z|9Tbts7gYq6p>qL&U>9<(q;ZO%R24H)X>@#J+0AU#?c6r2?~ZG6(zVHmDl0Pu+7EXqbpTD9y?Ad9)QCLPU6I&VaB%G?6p-j44frt3>5)ed~JB?b& zdgY1dj3@_1ne5MYdkSvgMfDIHn2g~{L)u{m;a%jvY#+!t6ouo}rSl!{zx<_pmGEAR zwxGD)+?wQ7rTn|kBCIh1hQLJfT`=F{x{%7gcP7~Xd=5u8xJL4naQcQF62QM{SXq>y zk}`^_l@=Y@)5BAW)^tfq;@uygMa;^Yy8QM2P5gUpH>v6wa|2yv^4lww@7gP0$`{4) z9bZaX7XJRVLaF2mGaMw-p0z4^CghLgi2skSw~mXl-@ZTvhLRpZx(B37S~_P2X;4ra z6zN8~C8UO7NJ$AP1u5we1cneKq@=r~LHa(t=l7oTo^$X0%a5PWF!Ma$+luz{~F&3qn17wb3OS}MNWDh`TWn4(`&i6OD0auroFcWblEFm zO)hRYtlVXmjyC%dF87&54pS%rD!j>n57ljV1VtUrUpP{>; z3>sJNy9Q7G`Ml}MZFoH|b3cb!sG7Ne5h`-`FSZSD{__htbz}yvyh)1;DaYS$C;DF_ zD~Sb6%_A%iyDD{3CX6(A0nM1cwstPpgfP?Z*hsNnE3&^A*1tCRfB%m@B!~<_k69%$ z%z!sKIx1}VvDi!uKU$gQ@AKflKYlw}oVTOJS@As2A-D~2RjEl=7z{JPMDD+_arp6R z?B8?u&-eXn(11U61;qr}OFT)g>LKMo1sz%C!Q}2wDjB~1&pZCLg8y&HU?}E1XEg&^ zeaX5WX1D}^mqVQS9qA`ep1>hsv|1JIKgaHWz9IO#JTR8u+h?9RU;(|MHlkEbU)fYFZh+U=&av##mrO0`k39q#6$>l4qkt{2zNwSpp4h2k`f_Ip@pH zH(gV;PfCH_qQKVuuGn_tHR&x~kxcaOL1-ggm%$@v!;skhP_Lu=Q1yKRgZD$S*eJ5CD$}l;&#=x_0Om6FnL+V}z>$7+WyoHy{MIk$6xgaZLl49&Rc~UgHX%CEu@B3v|ba!|-4(|s3;uAef!@p*Y z;~D6(G1d+*klexgqve0b#0(E54xDGne?XpJeka~pV9zZqRI#rp|V^g#3k zJ3u1odNOI)5_fu%!4P`2t%uP$oq9snfcd}`$KM(@d!T4UBHBNk+PZfy_s zD{Qckp2JjrQx@D6N`I{-I0&O<`cK?atcmFkXAj}2idV$9==(Gu2U<({f-8?y z%%w$d*N@pgp0KhEUrSiQf1hzYoS5tw_4z%9^&0YRiMl}9*LG9}4K6X&jU89mU~Q`} z+&pf*xpJCx?jTxe$7Mv_@^xcB5obNSHpa$B6FbhP|Fu4IW=Qc`=B7T9l}`L)#4r@) z$OJHl8Nz@sSF7YLc4)nIYeWZ}{+^k}>tRpeY=+9PLYNhqn2X;w|4^YtE0Rb<04kW< z22r7suMt%0`~plL=P~`)DIo>Ad^C`K2;S-XuV2Vf2Y#YbeWAKHfEa`C0LG=BCZvB$ zpQaZ3O?bA#KR#yhcV+I%3g*2i5wk!upD;p1~T{k54u6F0r z7?4G9&G_~(NAv(nr0H7M(vOB9!c*WH1^v$>0uuua&rD9uTUu5Gg~JG_TS=uudiiY4 z1Zkb^YjS>6j1;u=L?&upSCxI4^-1T>)Q~?PfT{SPRkGgcwu_QX#A@?@q>`chJ=p`* zVS85Iv?pGFoeVozc5{M(AXZ%D$`EiE_>(G6dlN z_(tk@R9E66MX9!|?C}!=bL>g`s)2l+9z{YWU{*Z+`R)PPtGlO{bZW1~{LkIJ0pp65ym*;mZ=)AU`c|bMYjvL24va}r z%Jw!N^l~2net;XN(~?_dd4u2h1JC-{qpL*&E0DL)@bAW5nVsqR_RtqMSEnTG(=~qw zLw{dle0URa&BkUm@OLUfojQoHPKQX(YawuZ>)GMf^7lth-7X*OKYzRLIwX(#b#_hz zkeA&pd9vexS@|2_a2=uuAZ)O>qn&9nN^8o3h&$PF%9>Cr+i}i~Ic~^nBmc?_|MrhU z`#&GZX{s<08io&?msZMT4BzsVD%){7MxVQ>jh?EJP;9waGYJ66YdxUud}rSP=(k*f zW2Ft!HmhF9ufBY9eJXo47SK;~_wn z(7SaGlzVw_8T~3U08Nqie$yGiWk~`-1lO_f6~aGTcJ~6s^0mCl_o>nRn1 z+m8(KHq8IO?|NVlu&K)VaMqpRbZt8EgEHLTJ^glHzlMEdP#cEf3>G5U2=S~QpE804E^Hi^qe?;)jJ(nosFL|bS3bLFYVBLQDNQ}P`>4orghI(9!^ja-JvOOI_RwgxW?;gyVbz6KH+OvXJNBEBNPG_+d^F=;Fjf| z9(Z!uocYg?<~G%k`2w7UF5kZ-L|V&5AgiaCu%Q(7fW+S8T`g@6-IXD{xI zC2~Hqn)~6~_0yA?f?B!7ise?KDH{h9vY(KIgSMMbvnne*%@b#~=H{jm_Ck{^(R9J2 z^xxY~@{ovJpGd`I80HN!DgbF~z|^=~kxsZS_9Twsk@m~}b9{zM)&>{Ghc8v@kKXpJ zM0VWZ6~oB;^5-+ckEv)UlXYh^Bk#&SNe>kVR2psqIy4T;JqeX&?U-z=?{pIeC|&bh0xsqg|?6W^)F`bPj&ALcYq7*-2W7Co#_QWThIx)_e!i@}z$(|1 zXz_>IBR)qS6eLQe4D*uvRG8(s7)RoOM78I_sg)JD=GnYjK6491sK_VHB3lr^7B!Jl%1*5_0;?5l|oEDBrjj2!o!(ib_hjcKU#$>eC4)fn5M_QvGF+3=nHzii)Ag=fJM` zc?~)Y0GMnCLy9Ce#~1=@nCn-a`#K_*0K}?a8RIDc>#QB!ZXYyP zsGP5}dEl$nHlBU;wKzqpbhfWG$p+c_7 zrzRruGJtDAJrPm~3zu+ICJ|3ygvjBczr0R?gDubOvr7Z-lksid^1wd}xI5zLZ)P-X z{XhX!ij9;&wHDCM670Z{Z9IhSqD2;cl2lM0pDHlqCQj<0N9DvR&FO0xK796vXaNZj z3+*PA9i3kLeWQ5Vmj8{@6(|>9a9ma#7M7elHXr{yIBmV52XF4K40HT=4fyewo;&k_ zDIuJik9LI3A4L=Jep?PDkwF0V$SWm)CqQ8aKpODTBn+|btA9Kh4a`FyuFI**jt4t2 zAQ+unP+StwvdaNbIq z;<9Tm?L%kS7~W_wf(q{0B*tfza-MwwE~3@rC=hD_<`t(Zp*3TmOQcOjQA~*-)JX9sGrIZUT5it~H45_xTXE%~z#JWEd)78d%=PPQm^M z5Zh0rd|3d)iH(u-vv((%Y7uX5dCNH*ts0lI*%&W#UIZ?7CtsawY?r)S{`@UE-R@Iy z=X$E3W%XU8LnopeAcdP4IL!LnRiL>iPyaDC?@mY1$;{Czk z5t-l$uGX~P>^KFM+E%&iEn*d{7M1jS-kJv*nSgVSh&3;gF9$ zWhvg!_dbi!#ClXvQXQIM)7`qII3IeRQnKLqpB4(m{l35JRj-fB1B)B>8E^h{8#zSV zeGr+b_-ba{zGY$2YCFyrxLD(3C7l;00Ai;f+kG3g z_+Z=qnwpy7(x?2nBMD~LykCCl>~QGNq_AU#6H+6^^!v9CFCIPwEj4d?3S@e(bG{2M znQj*@Z=sFJJLeyBz1{Xrmog+#!#5YLH@f&5j9-A<&-Mz!10x<*b5nyb8osg-F!!Fr zHR0#0zE5jPx#eU-+w$0Ma8UX*26_h@5mcyHV^@P^? z;YsFw3e*TN@SL+0`*XMWE8jf`>sSc^*84=J6pkOY7v(2GxJRvM$*oUB{5hwVil=hs zjvFH%;`N?;pM}$RL34~^{8rcx{-W2j%(rPR;2?ei4nVx z42jRLWS5u9Un+>nvcfJOVe06a2JCZgqce%{^Tm6II($-sixhE({|aQ_Ww+A6w+{=5 zY#8?e3X>kbLJ7`D?Gg}de9C8d_~X+Y5F64C5M*111NjGE{G~bF^uf;A!zJpFQ}h|H^#<^pynk78%r;E7z;ObWG%-BIn};|J_f-wsWMMU+ZXId#dp@f%s(w(J*V8s}A!!$I2u+&k5$rLq5x# zxGz1aG7jbiI_^@5jCB%+!z^c{0zv^S zaie+B9CW4O#@>v;>t%Wo%QBv<#$*V`n6_ zln^?Y9L~rD&f43#*M#l@qf?hWyYz!vJ9DKYRWe8U#*6;4a#g=q^6;+sof9QFLw#bsKb@r9!?@D&;s$ zU+;4Fu*OSOPW+(!NomiTdOzl7%k-vXnU!s_=vtj6F_55I+k5+Sx2Hb7HMWo3+) zz4nq=&k02ZSrr1%pYj;cm-fQ-F^S1xR`3bFru4C1(rP2X5PXwWU3{P(1uZw(c3lnR zBVsQrE^b-=GXMKosCtDTX{g!du!*kFF+!18drj`rq+ubP7A40+r@8ki8eC|SIr~L3 ze%u7p6|kikp1Op{dJF7HEND~x;VXD*9}WoAOH+P-mGX4@FRafDuNwOn!L9w)Ru*TW z6cpx~Z2bM87fsH_JW{!GzhforUR(+pYq;7C##PPXhVahuj}DOnR!VHgqRT>i?XqPF zJr0O?=-GBdHEGUWnVmc~U9EZ?GIZ#>myWB{jBk`2gp(7(_b_dZ)i~~@FrAAy8;5<42 z`PSRv?GOw7Ie*t%PF?BkC&Nf7l^7}YXFfE^PkJ@ga`_heXjSGfrYjPUYtFtQ`P=O9EhsJ68#S zU2FQ9)>4E(&{MKHxb<_{`kkN2`c;F#5Vu&tYwGpwh!fe#xx#ZpgP*_uH;HAFXUd*5 zMAAq$JWg)iTz~noxmLc-$+1WFiT*Ka?&`OI_wLN=l{Yt1tiC(Vs&Rf+c94|2Xw@#= zhJ3)|@{!set-)%I))byIUte!uuH;*+k{pPnmliL|y6~It6Byl~j_^-Kg#@9fZwa{H zZRdrb6VLkItM^|_aMr?_&e0ktZpRot+L-H|_5IC8B8QAV{s3KU+Qg7xkKUci@nj zk~)UW0gCyAcUVZHqq?2Y!Ch&C!2NHOo6>3f5C%?(4SgqnlR&<*j&50i^|YCkZh7ir zQj@OXkm2yNFgu#9J*=dQ5W)nI#}yqCm(#=s0Mf-+Cu#8NLlDYPqnXF@93r z>J|u3>5Xr{y2U(JNmx}Gyz`OYs#PCT`~fs2e6_cUN!g6~42u2uxCMZ;TmhR2+o|$^ z<5D9(yMro$3pb$Gjj$x3y&(Dc4mc)lvXSjy=IFmmnqB<6K=xN^yeZqh zkZ9RboREcV5C^~0nTptUew2g!jWIN}oA&bxjq8QSgC28LW6rsLBRsGW=ON`a#JA(! zuIcr;b^ZKhG;`>?1b21?2^hg`;n4kDVM7=PKD|%B+_4*Q`p83}NZzdjGTq{-hcG3d9!H1yc)@A=s#wV!W=>_-x5I9L_}#}O(61SgQq>rF zPQI8jEg5rc+VA2@I0cFb=RCYJvVg~y5Fiyu^2tAYG@Bk3$*d+tP ztlsj#t1b4bk#P3zE;$zGgJm?l_TVh{qdGi20AMhmORIuU+ptLb$3~_u>q9*Mw;t#& zgjqZHdl`RSV<7Rd#eDtK@+?CS{w`tmd(_iwx5n%hB&A$4*b^u=A}~sl%6< zC-fD!keN5w(y}Wi;kjeI^4JSITU%7jd#h<6wI~D40+QLxlsPq#`*5;z{6qf*?_YH; z3N~su;1>{#($dng7N(^T53S>LWWqML`V*)7GQf$a7a1(<$hu?7Vh2V=a%&vUZ?dy=)nC< zcu{{v5mg9L}-%^9T<_Bha ze3FeC4}$y_V##rIb?5sP1TqFzWRYvd61t4i-AyXp^-;0_N90?9xF%{UXMMK5!Un90 zO}ryRy2n|ze#Zq{u3aRH>z+qx|#D@2S{SC^uD!2F%L(4_7*yq++~h#W#4q(Ghcg7QT2uIo>3UndCP?) zPmMj2Ze5kpCU7o3be+Gk?CaGzhOt!%63C-KJ^&gu_lG={Fe$GzO`RRvCAqrLt3Tt< z8{H>{nS6hAqw=Q=J8Jn;TxjgzKf>H#Hu<1uiU5(gkD`G69zC}xWkt)~w7Z^e>jr+> zEN$wXVuR|~@EC)21-#_|8np2;Q5>xj_=QcRB>Pu*lJ9U>HBQdC`rj*H6dF#op%SjOg8DA5v7VGr8#WYy#QyScLCxtET9Tz3%1q5BGQ8 z^y}eb5GkH&LJXuNAfEN%bJLwjxLhE6d;!Q6stNmi(O-<%>X=;W0OJ^26u+u(DB-n< z)1Exbw?`rS8!@a=2B|47GVvzleh8(N1x0gj#@0GFHG%yV*wM$@DckE>?LasD;OJzF z5%S+QO(FW5I%j5ljHJ#-$wZglVF;LI zUqJ7}h|cpWQXM1{%YsPevXyevV|*%~9~uv!@b3}VvNs>Bwi#7>=H>NWk8H%$1{Bt9 zL&GvocE&3wSKp!YVI&I2WW+S2>eC43iNyXKBdTHKjC3`MeB-w`FZ$1J!xkT4Dn&Wk z!rJFl{X>P9JvTXDn)~n&&sl>*A4VH<=`o&llil6#`k#IIFN9@)87ND;_1w;~97Rix zI^P@&-a=kN4iwQ-I53&6pp?Tl2@EAP+dbWc5XNFI)%V(1XgC51;Y8ED6yo&Y=x~So zDJO{0dvg7Pa8O>3GPO>5D^gcZy>*>uu-_e7o`vk*TAHVQVo~M^7J!h@}Qj9)8IQ!tyc137HyaRU0*#DHH z9d2uq(;EIZ#7z?TP?}YelEIb8;$gbN<8-{DT7Cz?a0n(?@LssEg{WjA+x=os^^gQ+ znpjSZVq)7OK(d>_Cv#VG>IL|1ZWhP3Z>~L_$Afu%-yMD5-g_h&4_Y5x-#r^FWegfp zqGyugubcM++PQ7G0xHE)e*ua*r6t1#-L0KCMs|#!0aY@d+Xj=s!xjJ?mNtXywL}`P zp4FzmQw-9HpZydoeKC-0wg2Cc7Qj!qtr@-$H~hpR9|TMR7$M({p*(E7)iunNW1r2+ z$hiYOk4MJa6e%gv!J@jU@RU(O_sCr!2um7>rV+VXMr_oa{Zz>OP913o z_Sp7HG7OFNI)l&h#wYLB$-Ev^BP0j(*?UC&iyZxli1)%7WxnQ|%oID<56Q-@hy;Nh zu|w4Stow+%8xhq{36AZr|Fhl&Kn-_pi?6}3Z4Jeo6dlR;oP_dgcrk-^0RNAFC!axu4cG7D1&N2L+Q9`2o!PBZ3o}(~aPdigM(*im zKK=?*|0!xEeE-dq=MxJg65&M$l@pT2P!%buQP=JfkRpB15m}me9-e=BJh4!@KgHb> ztZKwTpk>Mde#3QQKWWo#yb`|Ugpxj;!cx~wM-Dzcts<}iSpll(O2Pl#S-^Y`?c=$( z(z|zC+Vj?uVP*x{zXeeXztW0x7e4qLdxsxsyKclD8+w=(&LuKdLC?Gag@L0X51Os* zORQ3olJNBpyjSHPCGcn-H00*W4{|26auy%Itp1LD$bxV;QvY4IqE~DJ^v8Bov=u@k z>)qD+u3KkKfg+iOl=Uoat?oV_IJJ!Sf7adq0jqL9Sj@l(3B->nUXY7Frmc!ED^mA8yi!_W{C#N@`FDi3~r~kYh(;n%->S)pi{#>sv={b z5hD|ry>iXdNc(i30nKE8;L#%gs3vXmMqDZUZrmW3_)`?Ua-~^VT45=amYk@`z9WR5e;unRn15* zTEzA22g-50GO>>ea$^|_VeAU72@pn;r>G}kG_`q5W2n3*=rWVu1nY+S@DY313w*eT zUT9_gT1cEdl@@}b)^eYUD-wElbIgpFEwQJkB=iEEm^he{IM`(JyY9wt*+Xd!@Caf7 zO4?b!0Dl-AW8;rw?kOZUr(?!lc1!=}FaGnnU(w#O&}ivCCKJmAEq4R@?&<;smVBVL z4CfP+Q5Eu#%Px!ZRASm1NOw!`Eiv|`ML_bXH9fW;)9Az?Od$AZ@tR{i7D4r6+llDW zrk?J~XE>X`P(eyC3Nu1wOR&PM7U;!@HmV#eFb&~u{Mh1$P}-kUS#)n73F7d<;}E!L zpUU!W-xcjVPvCB?e;)22P)0A$@u?&#`@cDp|JhJAw@_nR>o@GuoZ!#m2luLMJU5B) z5Ky3Q@-i=1XYnH-F{7CyTh2=mh%L-fXL0`xWvQ(FmFI0JsbEBD`U@b=9^{R9!d)da6`W7=-+XrGO&8MLzh7iqRp^uViJIqQ~w6 z+87_eWKeFy^(;KZ<8z=901Z(~Wu*>fQ!IFjImG{!qxmfHfJY-&N6G4AFiGIK#w#-G zFY?U4IT46Bv&Th=Y4E0dU&&NyM1@B?+8;N=<=7L6xag_hSXuF?z`Cfmp*nD(urt<1 z{BF^Tnbcrm)*V@u#TVe%?j)tM@={gFZ4H$(pZr6b1SNlklR3LE9$7Cy@7P&tb>8m{ z_xWC)&7J2-#da&4yUp~B16o38NBLw8XmkF0En})+1!Vjb)?C2FM+Tr@U@_2-k@5hj zo^Fz~j(pHexvf8bcr*OWV4WN&tR^P{KAYN4OuS!62kb|iLOncc01|TLt$K>h+#585zH~uM?G%r@8VD*S0$|t)APB7D)^MSjgO+TvHlA5b z5t6#Kxq0L?rzWq$v_KW{!0s+z;d{;~CdR|zMh|RJo*%EE1*~boU<4tATAn@xqGU)K z?Ser3i1eM=0K6ZV#@^LPev!u@%_bv_Glwg870uEsH2*eEgv(1}eNBjJz!q{XJzien zyg_81GH^Qup4UJL89wL!mIf|q;EsN6wb&V@1Mpb=*Y7e0gl-OYYxos&6ZUoei=VHxQCt~X%eV?O=I{|u;X9WXKRNj0G?bj7hp2mz&=J?X<=Z;>CkE_M3A+_@!S zU5WgRPl(6t6NJ!m;+28BsZy>t*sjCWHwa(GYyL_txDe}YhgCnI@C~?!zQ)gFIU}N- z=3S91^D^={THOS_qCcYO$(5ue zGv%j5O~(wCb5%pD--T5Q$4V_uIXqk6qXEZ}Iun*g;UW;fQWx(ubHYYpm`GZEPgbl0 zLBen=8@X7x40o6ODJa^b;#@D4{a zntW;-Zi>{tW5y_}O47;)s&V^qWE@MF`A3&8L{&8F-A6mxESN@$tOzsBDL;rbsBLpr zdOPR7Fudc^!a(}!dP=$K&f$B$Rc6j^Uv>ACKVf>ztW>`Yr+;`h`#cd%@^_1x#LFxF$*yr>y#U3bMxuy_&8)#~?Qf2ONW z2f}>iJC%J!E(_QL-6D#;KptC?Z|SzXwz}vqo$0-L>LlO?7>eA=ux_PW<--ZADlv%L zuF;}XuUH4VK7(BL+!)F_KK%y`&N;kIbPm_re1?EfO-_`eNM(!~WJQJ2m3*j~)pTJ$ zX?7)&o1Bh>Kvou+%2?nB3Dj<29MpTuHZb)v#X&*FlrG2P%I~}xBSrj)@|hg`d*A!P zsAa6D;ZmppMZ(RG9~}@lULl`0wb_y={Dt|jU5Wegz6Dmpy1kHVRga|CYVgbID`l|vk=KC95~FB_)P!d8Lc5?F1L;Q_ z&iRo$I6@tGa@luk9S;>);+D`%#Qw?_EO(u<|ER|QN`R`|ABDUaoDoe4!1|t`7=PX9 zCsvB1OP*|4WsPMBt#xAr^e@~u2TC@7 zQMQ-awacTafP>$|La&hLh>b5+^7OXcg9N-(j550g+=~6zglWv~k0XdWAUw0;j}_eMP<}| zLm-|U^(h$pI1L1LHeg=}AsOp&j}eIuNsA5whf^4AHy^IUBmq-OUXXcn1SUL zm4F+b7sE`df~wl{eU)ouvmLZQWYK3m8FBfeF)fQ^8s*0?QM^h66VFZY2&Mz{?8Aa zj(#xdR_0WUv7csp1om(_ zSH&McZ7Malv>p-Zql~Kru$Y^H1`+T?(-R{X) z_1#$cv_))BJ|;DCTSSPWU0IZ)^pAomkbail>}(Qosa4np_oMSn5j>Bzrw~cd0J<`jnRTWnT zxWgn$C0fU6JMunYQKk*h8|J%&J%T#6Kgf`6@dixUo9(QzgZOMLO<|A%-b5_G#gJYJ|2QZrgUvyKoP#!2dkufl}O@rX1x zE=aE!-WfLP3E5DsjQHJSmD8a9LmJ8<2}W6;V0`|JhX)l84ThKz=H~`^LH1RSS0s-j z2reLc$oh&0-jNu1B8`S(Xjwd|kUCbPO=u&e0N+I*5KLv|obRk8M;I=T>?&@d$A&?V z9WJB01W)iFd=l)V-6tIN;BI+)0~P&Rd8y6&U=P(O{>=y9ZBT06nRi8_`Z*wwCB4JA zg*)xAUO^mJk%7;7#Bc|djRKrCJUn$qJsljkHc{xON{1GuhcDJ;1x#9=>M=BWWMp{G zI=KE2A$fJNjg>iKUprZN094p}0Ybq}DfiSv!Nc}M1Rbu}R_APK-Ij&iS}>Z%k0m4ge&{H)4UhO30L}5^9XOkl|3?51aa$qOjbF-qLOE7yL>cW~Cc0Y;>5vFIz?xAm*jhezHsMui6 z?I1!-9|>gZwt6a27cfys(#x_P8U*Um*pBF!;ugz8!V`(6;!5y!^;3N&=hvZx>?o>E zqWsIEw;%B#SI#T<7q^L?&&$6jQ)27ULxyMY@5uJ3I1Y(NKqN+Bag<>UJu1kwO@EqN z_B5PpQkPfQAQSSi7j$llVaTC3o;zkuC`^dfx>a0yHCLIv_(KIA*Fl~ofwo_(6j$bqX}oELwh|CIL1gDwL!s-@s};&pUhW5R zjqG7_B(|b}3g9O~M`A}mrV4AFmRvIlc?W1eO_?y}#a}j4o8ut!CZljYYJ=cj1 zz)~oP3<~_RZ{$VZ=M^$Xw7sOp-we5BxUp1Fj_<=S)Dx_ePXVUU?e}%1=7vri@PC%h*)RD=SR9V7|LOASSNNNsqpB#67&v- zDQ$SM-p40#X|MM1CwB``=hH$(5bu}~$;_mtK3&o^HTc5l&m2(k)nJCo6UEXWo)cM5 zVoHh_G~TK!le-K&6nkj6NH!cB7uNY;v?Q-6-ip3}%aVyfB7%bAMGw}P^@Lp5HX~Gd zB8w;DndoMLzmjB5u8;5*Q6hB3%cVQHr?0XPA}vq-l7!TV=>sd3Ds+ce=-zo)!yTRy zjP{6zGeT|UM_7v@>W|_pL}0&BC6l%(f@(rst3}Vdi&yB1OTnmDp&+X|;y8!*h;sD!N||S6S0> zO^&0>B$$}xQ5rXn;W57)pX+A>SMSx)*yH72 zTUiB(%xpHn$fKpKT|I{Fkze(0E2FxaNr9J3j6S;;mb=FBo$uY;Qg1u&2mw|X5&%(P z1*mQ(U0+?;F@G9-Ycoq3+xh8lXfF6uG$2Jae(e}-VHJ0D7kzmq;@Z<5fqwbUi5)1t z^5l;%PF`!X#73~X-XGs6%orMq^aCWFluyg(M^FF+mcZ3AAsF=O>no0xC}vI%MI6L9 zq>yy*9TgBuCb2R`iQH$^#y@};kQbY5OFh-KjUV=ayXRs`x)!I&YMzPHKp+43&DmI_x*GZyzvy`qyuEaK4z9op;8Co)ps(_sED6)v? z-S7AlObb!l*nXg{C7vw~J>CplW@|^+cgDaQ9D`$i*;05fC+jYMQ8i}H4mfPa3#W!D z-HL)zigiEq-g4QgIGvTx7sOskiPf|pZYWRrZzcbQSE;jT_3!ds3wS)pU$N;!oRmk` zm#c?7S4!xN^O^;GCU3jKNc^r_LXCa|+`ZqMJbU`@ss0@dO!bUq)*}}blN+iI+6S;7 zcoNy?_&;QOHqf~&GcE%(sW;M1HK-VO2;G>!@%2~YM5A=szyK5BJ}sgzn%Oem`}6@= z@82rD-+Ck=N-AP_@D>Iss{6yHt>P^&V8!I>g}?(X;Dy9I!6l2e>ohZx!|0?eQLg9c z5dvFt7U_uv3FMuwcu_+R<-*yR@uAaiP&zSp8p(V3+1j*lLy@s{`4QF-L7bh+Mo6O9 z?w;p6+Un>NKyQd<#a@bq!EbU+B~_VlCQXH-o2USMtt>R;t=_Q;Gt!lg^}OHZgFH{6 z+_OqvS5);2m=3}P->3U$OTv&MP48BnGrLRinU<3xmi^23pIrOJn$^U3!bTVoF==01ncd ziqqg>aUIhi|0?ijwX%ywaRnL8uZu4|rDV?sh^tG@Lc@B3g#QIBO14&hF%}%jwO<6`h!S4zSU45q!p8HB zJSy6W)Fq9DXIT(VU=>@jCKbsGzeE{<5^z6AMxEniERZ!}C~@|*HJrbhfVM9XLnV=k zD22!K>9!+8dyX?hcfe%%wp_}zNb#XlQ0hQBwutyDOnt!5>tb1(wWda-!nd9jiKuz@ zg?mtvDb`R;bJ95ui*rcaIXXCXxvH~8*EmCbzdzIk@-W@d?o|Wqq*3KFccpa(f-j>ZKUMJ|0>Bf=L0m8SkYDZ5Wzxzc%sCr}G`6 zN^(~ZEnBYI1A71UiB8+I0{HRxb*=@$|K&I{K=Iz{Qp4vKX9dEl{)BiHsoJa1Hjy?U zWn#aT2Q%1;;>=Co|9i&*YTzrfS6TZuH?_})FqPl?)w1lC>=tIeQw}PrCN#QKmUEQv z(rn2(Y0eNn0d0(xW^1t=6c=lT4!M*x^>0zmxvlnVV@A9D&UGdM(s7G~pnN~f3pL-c zO%KCCL?o*qwvFnCxGbHoZ@D%I<|7MbdjivhG$@p ziYmN=&rNilkRBztj7m-b{S%)3Qw%7ytiA&_yn^>-n-K{=3Rch^Cb}B-%n{wzi^xPV zVV@1z0cV$-45?dJ$Bi^nW9+kQQ_owZc%xm{gC9@naW_xgdKL-e_8{JCQ*NL25-e^w zF}{Z8n13jkV-n@UO~m^~Wb(J{ z?qmJZ3PEwr=w(~ax*{?Kkr_qFgEjC#3#m>S4Hj|`gpKzh84zDY%Cq~zC{DyEW9QWP z#1F;bPjtU!<{w8e25GP*V zO})B$O*MGEXSru{-STj7o1k@fL(unQ%}<>~j?76$yT25}w}qs2K0N0eqt0N^9pV*? z9u0BVg2+eq#(j!GR`6tx#iWuVWCa@hDAfSIr_3s?C;caGdN)y9E5b0KzTFkgmZDJU zVD3mJ1I(k`z~maHpkDiLDO!Z1y#_`4us_pSj!xMLoxF;K!uQNXrbVQdbz!fdg9LKV zO~5(fcaK5|RpPo%vC5n8WTp@--IBO6$x*X41moFy%_K}dL>S9(t&SV)M9igHD}mI6 z$%0>K5v?ZVHwb@+v!;29ZGZz(qq{j!-y+kv%UyXp(Bg(h3meb!ILskh0X_i zxs9Xb+=tVo5~U!_AM!KcEJE}k2D-LRix)l!gV=7^rzg;O2L0H$w{PJ|o@@*K9pkD= zw)&+i&Gyj|BmtLAr?iY+2?EP?;*PUbffN<{P>UZ44cm`kTHlGfGn-d`nKfyzDqeFy z=oFdQYy|GrOh?YuT7cRtGz|K%qa`)?mE(Y+H8sgiiJ{S8^X|Cc;OP@;}Mk z9Y_~>?n%`g3P@2!rmoE9M85uANNpg;bflkesVH^@rqj2S*D_$YZkMa|$>yc`)@$Z- z<>Bu)Lu;*1Lz^vI{qa^0$7Mb~9AtR@38U^M&>Dh&6gI$ky@z|HJyA|1Srz}Y_V4o8 zkUkkl04-v&hH#AHgTILSwcnxv+cQkNj8Bqc#xIRBN+HmXX>)^5j^|$D;_$KG|A>-s z3kX>_zW3r+T~!6gFAcyp@73AmA^%}?LXKiH77n470+;M(%Uv*HqUuDl#h^?sU+sh z@_$4p@_Dt{RPG^3=-m1%(+LBn^_RG(s8OqFo<2I~sWK2|R{Nrp0O!;wk(jNQ@qYQDIX>vKf`ZZjwRirPQdF4npR8^krb6783z z2V)MGtS@3L=MDVL(&pR!KDEYO780^9O{lI(L=MNSQ>|fuc)LSDG>x4I^TFZQ&n#zN z@_@=0qcO?caq(xB-ZPXe)kM0S@Z?pfNstVePdim)NQrFlNF0R)_C#cBMCfKw>HXYV ziQKLVnDt)cEgAkhlx?8Hyu5zz)~rY@p)}x9xBI|v4!5P_?TaC!N6yX4zTbep)gxO# zUC%^B>ks`S=Xp6l(*vOGOcf`=3J`dId*&E-3qEh6eSy5@0BGn%-skLkHFQjTJ{SP_ zb9x*AGhcF;4LApjrF8TCKTN%4LmbhzwcB_I?(PuWgS)%CySux)y9EjEE)4_^?vg-| zU;%Lce-{e74rhW=J%TzIclx^f_w<3lTDDV0ok*|tc8OLw`tDJ+;E z$B1aYKZDanhDC^zGQGTn+A?}OBv`+6bxI)~9Mb)}!DszteG^^{q4A&TfQ()vbVb{=uo~=-X|AC$ZpGq+*0Rxg~2Qcfe(t!V;D3Oi} z`Pvn1wMzCI5Do4EY1}21j`N;G0_AP5k55DADzvG+ibv@$@M8D__KWueR@!?w-8Qha9QHQ<-;Q1*bN3ky1GgnHBH`1!=k=W@+I99#4rn}* zBv|=22I1R~{O<@en5T)V_QmN^)go9dMH*!^ePo(01R)gKd}1J{$&Z#wQszU?3O=zX`l7I1+J$HUeAd+|7?w%fgd#) zKs`A6kepojgEf^@PR`riqt@QPEGqcP5n=qDNB~%69W?g7oO=eId%7DN`D+8RBmj}- znUe3hDg#v8ii7-~2@qj7?~L{3>I3)yY>KMJK0xfYVf8I70MhY+zZCL$HGm4OX7)zN zh;X41V^v?>Wut+?`PMVAz0d`0^BONAb3sw<8hn~b|M$+%N25W4Z04I)9#6;*PcZs< zc~S;`Ua8>VVkw8ay64sJ(a%!FN2gcUrz{P6o1rEhOqPxh#gtF24KolYRu`~T5+iNx z@GkphMua7JP#SJ-k>?2qYy%9-Xt%Q=4rTdrD2ES%BNjaMQAd-@Z*hwP6;PHGfj93* zv+CX{-euUU#|SnVhK;9|TZn+|KVMw<`HS{`c>mp=>_G1F5u2`@Z5wcDbkxWx2f_w? z8+L?a+}NeO9O~_~L=)apxT>-#a3jH<$^CD#j~2p$oO4g^=!TWs@ln<(%g}`Q-Pgt7 zk}9TQ|tn!ic#Wa%^fn;AJ;gm*PmY69bZ9sSk zXM9RbvBUlnP3kF2Ik-gq5dxb!WBkD+w>Iq`rOc1ySb5R!Y>S{nC1daLL%(s`8b;=Q z{cF+_C)FMS%6CMIeb>6D>#Ts+_>vydFJ66uxW7DWtbBNo29P0E1wNASA72w#2t9tP zu$g=hXJX|9sA5}va5NAdgUEc9JtBe37hP2XP<>pu%e^RomjJ68PYv>aFaSpY1uz}R z5kH;h>qk;`(A0)`XlZDSzZdb~PK_>|UH~N|>g&ZV5WAlQDo7pBjEn{;Tl)I$^AdDr z@3zhA3BaS;r2kE`w)OuWfdDibM@Tk$+6*%?ZY4_o&l{y7vA0cogeln&E8jhs1^*?5 zYs+D;P!16K{2i@Gg)lC*j!P~@KK}GCTu&$PVb33|$nBW;dS_7x@)Pf2l?Sda%uc9j=&BQ5@nrsn47+6##SD0 zqa%~P(K0a<&iL=;d!wtD?<;6_QwW$)xx|}N3UesQHryDeEMwxSZnT80J7e9vS(UI^ zzO&>^3DKn1Ps+4^|9(WP7DWzasYZczR<&o*{LL;jsk+DyajEbXC#%%ESwI#)^1uUM z3OY6U43zUFdMFHO#O_RJynVzWWQaGS1FhsKg##$70bXur?#-tq(mH1U|TxHRTl ze}95wI8bIvJ<$W4Bb+B-m*mFfVTry7?&!oTN6$)PhJXHQavNjiNtF;-M&?0FChb?a z0dqyLdl3N6YSYvaK_>BIEH$lkEr@gN|y$7tLge5}hXeeKo3YMJ(w$|QB!X`7B=Kd`We=+`38UH2 z6BKQk$bgK0h+2=}@i=BF!H=2wk2u}e1qz2!vYI3P&Z&)82rdP9-nZg7=bhe`7ePv| zCs%f+w_;CIflp99RonyY?5l*C$+ZwgAAV02;>ns3GS5HRhd;+8$y~6r zD{U8v-?AKsI`G_Hbiz?a&5OLz3a49u@M7;GQRz!t+mddL3eOkZdqAhY3)It8{4Crr zS%A_<26^$fR{(E>bDSMFLkiR%>LhQlCEqLT&9|#|`^CBRS~@zkQ(X(P^m`jTouYLe zq}vw&7l*xJ=)FJ6xs!?A2iz}E5~l=b7uPG4NZz?a*Xzk~`cp8IK>(ZKG0}pvx*VBA zP@ifpmrl}eQLS8Fg&@c%=%o!^Ag=_CLUK%!z~QGlTHJB*hx_x7y>~zb)bV|~7j6mb zJ=>c2;h8`HDCX@&QzRyPEa^z)UOT|ezVfwGJpR-t2n-N)bq5Chi#q@`qTw09t7l1( z1hfvaP%!axD}9D<0@NfEfNLbL1z|=1jdA1ug`2UH-Ycc82x7(L^qzn-57@gl@7=CV z0NdTxdo&$e6>=7*4W;Jk3x_>MT)iYoSwIoS8uOZJY)Er*3(K zkrt&_!z<;FsBhAxbUG8w-0JtZ79tp_YU;(w4+eS%%zPtHCsO2xBP1o_R<%=$F-qz+ zFSCs#k4YXO?g_3ZwZR?SsTm$x>gv`6#7aV%oI4FN>1+*JGI!=wS2VrSRvX5~1e6}M zGBUZDloELUYlVVsiqu%+f_(8gqX{c}R4Fn9nd#dwI|@xAWix$f~xQs;i= zJz1su^D7XZF?uI_*OgH1NndMeY1zG;n5pgBlpw>9e^M%_RaFv<-7#`#TMVx*mJ1`1 zAz5{!N2FAE1Iqbh00u`dJKZa2)uuv5&G1kraY03$#rf3r@vveNh|ks>wGDg@Qh-cV z)e!nsKkKx=AQimH2N0sufKInb=Rk*t$eCvq^Yb03566FtL!%aeV;tpuY*L~hIgkH- zZndc;Yj^q5PXh6JKPp7mIorC0>%G2|4SQT-bq1B#D?7f_)cOn;a-3-`NE*J*hU5lTt(GtqB8)c1cR1MV5V3 z6Rm_eGj{|lAr>Os3&m0!2q{fBi%gOizY_&FL5C&62e#VJVON`+WX-PfSd> z|1K~_N=)+MUt*Z-u8s1^{u-`eKy)gXO6l%aj2>g1YgSc#R77dTk9^~3Jied#px%~i zMTjU5)a7zQZswc?xoG&^_$f0Ul)3HmcP;V$W~dUS7ZmG#6y)6SsqqcDppQi;4KQ?4D@>dF2cW`tx--&ve63ne^J5v8wM1% z>&yOrcY4H8k>tDq%Vd>Y$8_RibrTlg+lj*X=_-`cN^auc`4)h?Qh}4D zY3d1BbB_ZN=+n5B&NzzxbI>Y!sjZ72>`U(qXTOyT@V&>BMP4Xc35I}jN9w;$UR z`wtyAs+4s{_JY1RjMNW-dLE^aPF0VS6GYQ_Y38B4qiL=+%sxk&;mVHrducJN@S@(3qTc%MP!cE4 z#hYo>gcuDuBMPCg*uob+I!Q~z(w~aX@jMOJtngABDb?1WB}hFg&27OXvf$#`lXeO$ z+LR+s37dS3YW=i(2CdMh;$l@9Wg;ki%?$t60?p`oMo&b6&r@P9Z$Np$9-BAx5P zixPug$NMsVB&`vo7GWI}t07dlyaENakDg6}+Mf**Cq;p8kMmYP)e(-s2-}6zSAYZ> z{=I)c#@tVB8>n5TAuxA0R+VB8GfsD9oPYfvL`idA&{rWG%b7e{CBX-CCW1Fdpo=Zk zW2F0h?`X~R?q*X6Y`=eQ{WaS38SB}1xI*Q-!$PUdtLAK;ShcSjhv1!~=*Mwggmoy0 zRStojc=l_atMj*8T%NB|g2&Gxai;>ns>5ChUbv5A-ep< zIdz!Po{l~@qtS)D6|j*K0Hvd4^E_GpefO~N)6U|5vy35Uk-{of#>~2TDP*JuAX8!H zhXDn|Swx-Gf%RppdGals_yJ_qRaRPhWMcB5#~=Ti0r0ilO>#yUUZcv+Z$1s}Pr&>t z{`a5!IAM|w)-s&o8RVPfOEvfo*kotQCgH-Wc3b|z0>YBgLS99Pkc<$q9Mo|sZafuB zq`|%DA0`VaG;y=?_?+uF-IkMLTFJUjkpJRBIqW*=WeT|=qTK)VAEAk~` z4z~F?#q?`VN*nFK)UC8oDouDE$r1U(hn2|_QzAw(;`E}W2F4PFjY8`5ilOHpmJ~IE zBP3QtP@@nF%DJLX_OiKy99+bd7&)-9sHX=N;wh4;pYubYi#>4;Ol!lL;hlcda=*xs zDM1~Jl9Z52AKFVD|EPk%rja7_*+v~CEWuKTX9%$hCGJ&085iHBa6ymD*m0g^7Vu@y zN4B~TH0w?s^wyl?_!-_?-J^D$D?D&!6YZv>g{K0wgy(W%RCzB|NZsi6B;k^91}n4TTZ`js?{Re*g;qq{jmU zUtj79vh-$nmcId$WRKpk7+{_>n8dM@VSKRO)$R|-0&I=WfEpl@r5e0YHA8*l_m4jR z26EpE`Z8+RLevJYK+L|{_j8#GpehZZlCJV4q=ck7eFuGU;p;U97y_=w9v|^dAWZ3o zYz>@0zk@^XS{Y^Z5`bnkyySkpQ{;4eW+bp={%cY8k%ubN#wj%fOj?CMYvyv5q7}2A zP6_$ycL)4Iw7TL3`eML@%E>=13Hto^0Xd zEV0HzA(a@4b}J;3U_l)*%7`x0-62sTiS6&4ww#WMBv6VyXqu!NO`EFBA0|g3P!NJ7 zR#w}LV2rNUij)&C0@;MPYX(KRabON>juBJg%uTz;khHKh;QVPHhR>bdY934R9m z5!RFq@q7|b`i<5F&PFo%Ys?sbOz?;4(jC%A;p$XWq%iHcUq#5=$|7%bwATB8xg2F4Ny)-0*=ha4#Yku*cvS zXtt~5$!E~E@L>|KqtAX$+2F9j$o%l-@4I$QZ0^U0QHG)OBBU}A7Pu!xle;7mXSP6&9mLAXYpun-%M(w7dAah7DY^Fr0}Gw$g}rZL+>t^;qe=_hNNqO^q0~*Gfw%mJ7d!*^r_>kPb#0TphYE?PK_>YHZhFujE_p3aCV58#vs3ZX)~XXlBwbHDlhsxrkQTG z53O;BBir5iY4HiFH++bqxT=XJc_n1a@z6eBsv1&|H1TNejDqs)!LPBT)FRE6mGwla zE<3N~;Qfzf_8-sZT@a`uLE}xLe2IVn!h-k#mv8|!SD;EN?f`pB=) z-1|N;$IkXW0^Jq2xNpW2$z)=o?fITWlykpLf1z0r9+QX0xZv7Bi{pm>TgV{&;HN3u zO3sv#9D9OMomNo9mS?sAx8S0oJjn>Bj)tl`UfoezEo_@{m+swxE~WbiixkptDfnQj zKSc(2A9dyel<>_4oeA3w!AWVN32>i<+Q(~(l6`~wFt?$hx>3`9eWpPLMQ^&$P%Lsf zK0NUx3pLhBIW~?dQ4t2^eHrPzgr*yd_$JbU6&UgXF4e6u_x+)s4MC%C?=7kkl4^GjSmhZQd zbjC{Pa95g|x8FyaaR`^MQ#c~8GyEF(bOO7MHAz3?eCs2&_XjSiifsroN&gTHKdL*O zl$fIxs%04$mYS%grVj8&5xPoWXcA%XNwi)~zdoHa16H(Yy9l~J(=dWv1C2lnX)ik6 z*k8{;tu5a+S8#6RlfWb#lm`8wz#5$F+K-1Hf4&1Zocye3;3Qzf$J~2wYS_K*t^j@C zGki{5{pTtQ1iR5LW!z(*bZc~Y9c{S!U|=c|K2!5fvux{HMcWL^L-^8L2#;j=)Y;Ve zU$wAuG#0Fra+juMWQoED3EuohZ^-6GIp9Scp_1>~plCvRB$+g0vMfII5%Z;R)F#z> z#b~0)R4(IyX0f6qD#vzHY>_VV1 zk2R0%xC&jfA@SFoZ*A) zTV}-Z(bWr(kB_dTU@lgccn8Wv$Zoj8cylD%VSXOjal^lShFT-djhrQ=znLO<_=leh zaKn6^ef~(TT;q`2Aqv01SH_6x&b_RjV~(PQ2s>>mQ%6yj$+_jSdYD3)W>im7k`uXn zxN(ezYmTzXtE!i`A&(-VvCS}b-Ysj0WAuhhvx4RIyig5N?@Ii1%x#*(9I)57DY?7z zg)Y7c=P&3g_+H+&_d1C=JwGyYTsQ}zY7W*0WFpg*mBV1jKtidwVsx8p`^%OY<20EY z1`vZ1GRWQ7PjN1`9{!9JH~X+qd)=r&tIew|JIG17tJk(kska`YN|RS~Dkri@Muvco z=MhFYjH{NMtiYiztAskoW#AiM+k0e;=Y=;$@N-%)`2d&G9_pQvW?quOxtmsTvnF*2 zP+sX8}+?gPO2+(7cr$pz$5lg(fQ-m+i!t4VwokF#jLPj5qmfl zfd<*_b!RfEusvpK3!kNbD;DtUgl@Fwd=)}vU{d~*plUrJJU+t+UKWiRd*@Sou8!vr z!~bnMt`7nAnE{MW#`lr-!G3n`{NB@+X~F%f4d~p z>d)svZ)&tZfg~y6=AgbotI?Le8e2X-GbP2#m(myA)-V5e{aKJO{zrebK$LaU9Y-n* z={l3g!;9Y+eI56BbabRhTt?yT?jUywj}w?b$-Y#&Oyj(b5DHHK%ce$)>Leg4G~Ob_ zz{Os z2_=A2`L$zGcLB!}xyU%)8`ZIuDBAzWe#LH}wL$%o5Y?pAejy=$1U12&Kg{Q-qD!Ra zqn2}u%cGMJ*D+4JVn^OWk)U}sbe+4tdAW_3KhzJE;CB1gjkgvrVvwi0#Z%B7_;e*T zTs;+u5<--wNDd=esgyQ4lm_rUt7BqfiaeuY?W&<6d^f^`hL%9XES1SJgoH><2GNFp zR^=SO?YVh-o;g|hy>2fmeb(G%qR8e2++-hTPV(Fed^YaZHxlvjG@h!+C~hsLi1ivr z&T{`XpK^Ck@i=V@@w5H@Vh4~INc4^-UBb36DG z%-t_k#a5&Aa7XNnUN|oVCx825nq+5)#a6$=X`nZs+JvJAZU?UPb&Kin&Ju=nMy0Ax zzZGcLf`$Y%ImAh8`c(-}L6}d%PI+piaM{)QpEqyljq!ZTKLu0TxUi(9YPph*#Xo+3 z8LdK|g%tjDs0LZBCbL-a3TX}7Pb+M>pm1t22mF@tz)7D~^?*Lmp1jFQ7j6yO1QkwNoxfk4+}r_g}RG~k~;Q*yZ2 z8UV(ZQ62?%O9KFq-pc6h@z?q$u?IhJR0KP3ixLRVJE_Ou#8s9~b8VPVd z^+DAsTj>zBUqGXcrn-&uvm4i;#$Y5?3&Zs0B47# zU2Yq<$*Cz5*fMpgwtKot($2xDMcpp9r@3;v{AWUwLzKqKP|-x6MnnQW=NNeD-xQUD zrdIFrLLI$>yH8aDk*y^X4nAjwRWI4Mg~ZWf-cJP95_yD zd{|PiU-5&9_4MfIu&oq>9ZG~ZId4jI^*R$sRBd*mG*>Q;@N2Nf))thVP9dS!7F;DL zK-?7j%=RmZ)A@1RUlw7xW%KKq_8{bkdP~BbU{uRt1i@`od(S27t7|`T#!6f@Oa30- zmen;CNt|SBF8(^3C?tGDOD_rZN>|{QSH7)h!b;azQOsmvxjCd+?43vyux~yQ4cr`w zPgcVq#E+rsGF^1#yX`PL1z6GOtpttE&!Q{vtj~BX=)s-YB;5(^&mCu@*;F**{dQO7 zu)#OajlKH~d{6&?i107IW|q_0hQ23OVd?^Kz}CyQ#=zknATilxUKxtPKuWqg$HvWa zMs5WJHNe@?%VHoMVK9>n;*8JsxzU_8XYOT%*_~PCCTg#@7X>b&-l;HiKV$%?Wd2$y zjF_L^?EETpE7@n9J6IYB1YZ2w3O20$v@K~ulp%|tMd8EIz56IpA(PLuN(X&8WgsgD zI5;>uy93cCiPxkah$XqIE+8$wU%7)YVfwXHjlaSTEJIb64GZsfXy{JR?+KSS2jnn1 z8Q8jIam9tu2rJow@fgjGhfnzflLh`Ip0Ip#g~3&g46e8LtKn$fwO{(;y5_VWqZ)-> zO?AG~8Lb_p`jQ#hy0@ziW9_uy*>?M9?UW9Rv~FO*Apw$@pta25;V6CDuBN$3Pm7-M zsJGh46AfdvuhTigVnfG%xQ=n@H&efyqDyV1M6TFEx+Wv0Su<@;qpyt-!lqjxc|UHU z8Ay=s>lqrON(~nE>?Y)bs;P|YdJ|>_HVeuUDRI%i86-WFNYcyeJNy*xCT>k~VPZtl zkmgg>EJamKV(-Hck#Tye!px^RrpAnY>aZW!ZKD~BKB%ok{mHKV+&iNDX7-Q|#ev7% zI4eJW2(3u8{$z75WQ~0??*#p2Tk#qCYbK5;2``*Gkxp2QS$n1K*To^T-d5MC;UFR* z(5MIR2jk%}<1&-x%t@otnN{3T52Uy}Lb`p`-IH$AC`Y-P;qbHcQC7QVUSEEluP|Xq z!WU}dmr3bc6+9sEz5WrK?du@zbs<{O5AFwe151t<(@)hlrIT*>?7}S zAFItqNqs}I3%{_U0uWuq$i(>1 zJMsOAgl&cv#X1S`zY_#GSg|G~utBEr38f6aswgNZ^d$?k(Kbw+PD2huFUUmbU_<1% z@XmekBrL>BQ#El=eaWE6a!=!zsjwHf1yAdD)H!hJgW)rns2fJZ^V=s@jn+nW)OJ*P z3T%`&IPDb1*Iet@H)hmza=SH@a1qgAf}^DDgINpt|9~o{1V5A8-dRSiHFLB$43YZG zYko=Z7KUo&Xlv8UA#99Kal`9e@pMR#Y}&+a;oF#5&R!;P9Sa>i$m0M5|A*9d(Hm;& zEmksuOxJJ+i#j=m)!&7@dog$~4iE_vM^@@DP!|)iMA@2wGjY8374VW6xKY(@x3&$* zY+gbTJCJ%As-DTy80QixA9hN=TuzWo6<*FM(sa#&tNDGMiwO-p9QK+mEJC-t5aD<-Yd`WzF8Oinh|pbsipS-5sr(pfQ1U1-m$bu0oV zS92pz_%}JfxfS~5N!>T~yJa$$r#r^YX7)ah{Pmm7L))(fVk@!Fqo?gFAy3TBeJ?Lg zianTkSibXn_yn)lvCzOV(0;yHBHzLb?v|H%muR5hYpq` z^4jKiBqU^WIT>b^0uB{}EH_1E4a0BlHdg!r!-jvJuo8Lx;*QFWPQjTxULW29%_tra zYadcBWb8uH`&McOd0hg>pf%B949CcS9zxUav`s5eWBVT{4Rmq?#6o|wPzhgLrHOhD zW{tO80n%TALcCn* z|FFglm#I=j@Spw|Y@a!LQa7TfQ6($_Vf@%YiYmL6y~O~Rj>cZB+KkuRGHt**DTx%T z*U4|w{%N(Yt!;fnx1ceWj89v~Cm}n@^a&ox?ILf&d%F#rugWzcLoe?1Gr!H-^BrJe z@eLVXrLWZ}Xp?J!>_NBSw15siw)GjWPdObAhx*fx8FB_XI`GnU6}cf)S~zS4DOS-? z8$XU?a6x$N^-GeuA__}mU|@8hdRXn^pwTNw7ub`3g2Jx+lRZ~b4!=e-;sM7j+xz7n zXOf`(qq8fhBd!ccdXtf=A1xw-us%rh>63>Ph2Ev-;V%+15)Z+6+|A#JgNhIw8`Nb< zFo{mu7L;{daVRY5PJgIMo_?Q~7u^_xY5jQfmxinRO(dr3M)d8L9T#9tOrY!q#Gl?6qfO_n=Urm{!9l%?e)ljSF|azbVp zZ;!PG|JL{HV6S4;mg` z`d)9CgAQ)f2mGu8Ac7s#a8r-zQ6fpezb?g;K;~XI#~4cd^8yVI558Bpq;MApiF{`V zwSVK;XPm*${zDsn=MDg$@vh?Brw_RP@#+N#J4UNUmTJ>Z_IM4&A8XO?f5d|F%R~7nryu z78-R`9h{Li`X&MT6{Sgn5p>lMpt#6Lxgecx}mDOYVwzm|v!1>LyGl9tlEUou*b?A&f)#@lO z??POeJ`*b6e4ehV5eP2(_^GVQ{yfjfG0jyoa&-GOWG~UIzm*S?UGZbk>Ke`BTCKda zKz5jJ^-UwC$0PPQJyz-_6b zdJBX;k@i~b#Mc7WpKUR4!5RXmXe)ox`AZ<_`#gUOa+cN(1zsNW)ydTA^S7Ag+HVF3 znsaTsrUj@g+CslnzXi9O9L%Cu*3=v?@DqZ!PW=Nm8X?|Zf#=A5yk(N9%bn-^G!6Kz zO=~+lJ{o6#$0MIHcfFLeAa!9j!czwqJb-oq|Lta3x@a3b%5reBzx2gG62dG0Zxlp$ z=S^?sO@J0PGXOst(VLY%K5`F=PN;&MV!i(c7g_qKMK7=%-Q&n_1`xXr|4uVuHkbWo zC!u*OA$h3`_=EBFLSv-?xtA&o`WPI;NkA91tbIA4bltvUNkFm~ zx%&GtFCm#nQavnS zImrAw(`*7-i)$wmq&0d=eNWk9rlr*CzmjT3@}y~GZp`KTrK8f9m%gi$wb2uMD$!~-|b)g!H*ZQ((A)!O0A(w+=LTR3D%S^`Z{By$zQ7Qg+mZTWH0nmM1g zPxHU(SLSU!m!~~($(5BX%3-u6D9SjG^I`qWXBeJ-AHX0F#8v2);tMXn-jA5`8Jmha z^xL&$2Nb(+aMb+tw9PSDL-^4B+PUsz}vLzd0^==VCklm~5%i>d&F+@5DkyONkU#AhJYc?i3&EC}d3?4~h)tx*U;&lfj2hZA>2?Y+ zmW?Rqnp9%?{ja)J*NMa*ojl?EMnQNMG1}a#YAdH6ygn>3HPR||uvV?1LsY=Yhpv-Lxs&H}{oM(KpvQJ-=ZSY<>9_r%_UqOkif#x8 zfQ;^urX9{de12bO8FjoR^5ex5TIF3R0#hS>LwB>BM`OD&;a(J=hx}1R`^YVK@Bw2 zv3@9worc5P2>Ct8@?Wz6WyqNbei1`aJabxi@I8Xu}4lhckonJh8( zGI-Tm>iUNd!D;rQnU%9YzC`NWBo}d(gXM`+AaKm%Rf4yE@8NYl-Kak4yQL%$?3&EQ zFUP8^x%g-FG}2hY#mVGgvb2dJ4uSu$a++MDhJ=UkveE4zK~`b+3H(5&v1yI|S?TbjCJPkl!~^@8g}5&wXe? zpw;q^|v!|Vpz!RMTZH)X!+D(8USGWqt7O zWP?_W5y-;uzDt3(@LbcQI1yXnXzrsyS!FbjyH=D_?L&Rb3aVuNdUdS@NV*h)KFEQCMo@dtF&#so_{{5Oe#vQZ z00n1drN&`tB2h}LuXzHabyag8GqK&KfF~D$hDxn(FqR%8Ss|B}x~a?!HMx%!^oWR| zymY0}n{)!BUAnc{;?D%#w1@8?^HWMo7+?u3asOu{-5E_&xl|{0mck!ege(;pLZuJ!-W1_%#0h>1e zKrnPPgR8xwMXD~ZV&X+&0@qpXBfF#Z_p^>e`=>{rUn>rG-KDKZUxm+v488KFbA@Id zyG}`7Msm`!WPoO7h#XVrP?a$l{IT`?gMaoz-`kT=(CQBHMSOP;){Ma2ZzSw#x7bw| zFG~t}1#JVt3&fI->sk;_%K{L|xgTQ%0VBf*xF}fvaubR`mca1X4<7pbHrfOdVqe~$ z`_IFtf;#1aESUS~9<6Re3@HN>nr`TOg7Aa@fQ`c^rSe*U{q57nV7F37!z(e)x5UQo z5bBT%9bE4_274EpklytE%+EL!SqQkJ6zgE>y)?Co_*dRDoY5?5p%H)J7LzN83<7bTdQaOPlk zIhb24*iOR6(b9OBhv=heM})$~WxzJ3CZk==lPjpUDSqU|RAZ(?RSp2|U8gCoDKXlS z+;Tj=u^<_Y`$~G0?w-|G_PPPh&zuLoRj2&TQ-VPks5MO3rPUnzl7$v2<}GU%_)nu9 z@SHb$JmAfA%a8^INPC!7n|ZInZkgK^DC)5mFMW?{1JPqwNPZV}b~lN%_1E9Bepf`@ z@i;5Vv2;&A1zFeBst@!`x=B(?`gv$u5I&Z&4-_M7nz2=JBFs(m2s3y5?dR1!3l`}g z5RO=FAyp|s2KDzVQW%rHP&)SsAh3b3Aefli1gF2 z(|L3HnMI1dyWsN$#Z2!qP%J#s)~ny%R_aRw#Vr9_uisVvy#OecU{R2tA1JByozHjO zNMg+~qRp=O!NU=I7ry+#>1z}Kb_n_Q@5RIQmJ{aWOu<_X?vuvB-RqiF<&s+nK9@0P zGpLz-5c}og=C3Rq4u@rB6I^cetp_V6$QG;?mb0G8LXG~deNGl)Ctwt}lVf_~-4Nsl zW4{1bPLrJsG^Q+*NXR+0J}}_o^(pZlQod843|t2MS)enxw7^gteQ$c_y(E<{@M}cx z00!si;awY41&^=+cvD_X)sMxite zecy&=!?qjf|8$`UhHl!A@@3i55I<^2$j!pfj)+SU}VL9GcWxs2LR?=}q? z_+6kVrm-`K23a9dTFM6PC9WoKU0*agO^!>En6UU%Y6r6W%W4Y+`oZ>trfU_pA?x~^ z)(z8kt?Q%X^Re}VIK5Hy}d+LS?To6A^AnJ0}35aWRUSqC>oVdBilWa$}wh9g9Z>N8e0?I`;nfoj)$ zgcCKsA1Xgf*l&O68MWh-3)w`e^V_Y(RKbxs-{$@E{1;1c`o|31E@F|I1qFim7i<5v z4LN40w7fB`P)$wkabCLK-ntaIq`4-z_OtpN(jy}kWbJ+YL++&EPN}WO?QSJ-9*eGM zS`!|+XLnI)Z9a<7xPqAN`#3{XT4CPL{!T3s&-O7WzUwrRVzRsr9R3XMa)hI6ympxQ z5kQ6I!g|LGvH~$caTZ?&dsf3ve9%rD5KT3^kqv$X4Nabk1vA>Z>~?6RO8-g z(g`kCg-A=4K!gCHv!uDV@>Kg`j3qu%S~^I2lCr|+q$ldeK@(wVSB*~Ht_8t$9X&oV zuFyz2NS$Xf8Q7xmUjSEr-tpcbAt0`IQX6k&J`|0Xzb`;^!sG_U+OlMhRc~+Q`HrceTz1A^rF0jhcW{OGW;_v4$>vWiBa; zwKt-_S(B{Qoy*7K`7PABsoveM+bBWSBu~quyvOh;u#wQ-Ry*_eK&RIY>2HtzLBAge zm4Kl7-9=5mk;E8LPtV{~2i=k7jq~m_%x~e`XbFFQ=wJPLeoE7axRDPyH|qip<&1ot zBEqZMY2Yv9?;ZM>UmfF)^p!HH3O^aiya)c=bFE20Oz)OLo64AzZzvf z2^Q4nv_Mem8AO*ZgYT2v1^AH-67OL@6qWH@T@p3jtW4r3b0-Pf69fI0VnKF^Di@RD zYU1L}?e)~6=jE$#fa#wYtq+e{`iP!W9 z07uT1)d~hCXLcMCO4zR}iVAY4F~dJj%COc}M9fMJ>6lkm64|Qhhd-(Mt?jmT=^yB* z+D};RYppd!Z5`%<5w6p@T#Ec|heFfW-+u0Ry6;hF>Ma63&S|$mQ zG{uylG@&?X)$m_KGcTJecwWa8V8SaS<;{aW9sLf8IZC%v>NkW@wrqm5&VGw`MUG>2 zHpk%a>SgE`T^IqmY7p8$ESa#OYdgbUil6d=xZ|Kx8!srC?`SVlkve1upw^N^fE`4} z6+zXK)FHrYl-DVTsNDOdXQadO zqFJjwKYqL8Zzh5~yP;#WLV)qU6t?;`QvuWe_On88Pl?O-&2aZF?d$Wxp5Os`sEO?;kIWc~E_`;#+`5VDJi=+dt(v{uO1S7QxL6Y*X=tvUD`I%eb z@BpPC3V*8>zeF2Rm5LS=8_f@o{DUDJPLXEGbuhlUU z;)TItN#2?H34*sEEtWNC$ZxlIy--W-m_U$oYFxv3K6EYH8>l7TgaE&UK3`UhN$IU3Y@6NRvzZ^esC zt#n4>o}^{yii_cwrrKG}TvgH0{mYAtXnN@z6P`qTd4IbY={n2R&nMkBz)j$Oa20J+ z^FW)Xs(v*kqiJNhL&~K?yZ<)uZ=NpHMG>OvS z5@L}cU}MrcmT9Fv4U#XN=T3tEA~AcTMD5sMGyxY6n~t~uYgk81U6Y%RW~)8aB0@A% zPcaH%EJM4y@8d<9k=Xf{kc8Gqm+nAixG2=HR8|E?$!gJyC`(*!Se6kC=+e--{;WRz zge{91C$^xoO7r?X?%2C$xd!myLwl8(_QJOV(m;q^XAE5lb%b+h%5kSXu%DO$hDqNh zjb8s0aBcpjNaQvpBAqqzYk%=eAt7a6i~K&44tKGfFS61j|EdYlGk%@TZ$E%CK(%e} zX5RdBsg0K&G|<2-?{V$Sor}}Yd3p<9mku9f4tEkMUUY7#Ujq97A5&);Rb{kx?Y&76 z>5`W2E@=d$rMo4hkq)U%gLJomboZvaLqNK_yF0$ean5AVF9!Dx166V(4Xve8Mmp-9XszH`i*`YgR?0}?+9(I;>>K^$K(fHzG_=` z-Gkla1r)5zrH2^qj0m|*q7%@Fjs1)1trguvL6e0Ev+wFKi#&C#(uzAGvmfM~-zx7V z(lWf;6kIb8TkhbW34uONaS ztmx7BSuA(4WlO}{F!W7s}d{G!x;qAcQuDU*dqWe3#DFV34~ zF7y6n;nZBiL$CZk28{Y5tHdkpS~n3z?aG`s*~+dFmv2Y7v3GMGzxIQ`g6M959d7}s z$nDj)pvsyQe!U-KP8EdR*1!EJB4iloP?6$zPGoq=|6lpUjRkY9we!*cc0h!bUvu=f zxza7vTsO50uFG^rbYQ?mEz27}J-A(`3GRn-d;Zvai+*=WA0#$#`1u586}ZYO5m3_4f*~Jpx?F0<|)c-vs>$0+}Jr()7*J3F@o)elKfg3LxU1V%s6#3 zZhb-OCN^8quw(U`1WTu?woic(-ws>{-v{o7BW2jox;M08Md=4WYf;nyo8uGjxKcIYelo9RZGM(E}fbqjZ_oG z4Iq%D8&~)C4(I#CP~MKd5*-cmAXnnZz;n1YCAA5m!|?_4M;K3W5?hSlwC}@CGH-lK zrSTFrOZIpoRTCiS*NRbJETED3j`1Yq$!z9Nb-$Z2W0|vgq_=+BPcz@2*8iU{#HZ0FgQN^jx3j zkU)qxTU*U_|C%Wp;dP8837hpXE}y{tR@_Ywmckt1Vbj?A-F@*;1?L8x^SfWy<`C!! zB>RsfLP!A~ab?pm%-Gv~2W!z5z1r`MBvL(a`YywgID>7y6PFqM+CLQsOVET0LeeQc zg`M0>Uq@*yt(6NGkC*qTay@ zJ3RJvRiFPoeasEj2BioPg>hJ@<>B+2%5+iB3?S8}7l`-v`G39NImoSJ^jwgb$t%^A z>#%l8o=PONNxPt;H}hrEQLzy#=}C6HA>ZUSbsCibx$tH0kLmv^RigXVRM;t_F7REf zUQHN|GM~LyTdr1HrnDy)QeOA~%lbZ`4vQ+;qmX#AfV}@s)l6!EYM`dZ8s%H{g-Hf& z)dZ$*O)t#2GF77O_d4}n97%YgZwr*Y+VhO6?w?@uW|-8jt#gb~L_;Fy2&x#Xq6f(l z9(gg`cM^Hb)pW>2Dm3waItfyZ*QwWb$rZYn8iUdRy zY=6>=bA<=S*up`Hw8-IyDIv{SVxuY1kzlP9k&EyjAO0%Pe+~S`e1Ne#y?wJ!T>_)8asi1z889kJpy~M)(FZSD zBA{+}-tY^tm4T2@L&rl$f^qh3SVF?WB+E!$4NKEtVyU&mSn{~^Y{lwxd&x0yX2%X8 zu%d#-K71PQKjVoP`7Q(6c>uTv7C?AB(PQ)$pkYN+d(EfWyd6fRTBBMMns7>=nw?z) zl4rKac+5_0_p_c4UzR;s|GwcFnki+Q7txu=$x&&8ym_0b4< zTeM}d{hX`a;WKB*<(kP|7DN3dd_PSr!> ziOj(w71Ac(EtqigV>}-an&a>H*x;er+U?J$B{fLq-|7D@fB$vmg#~=V<#T)gZs6?Y z_Vp1L${H`?69alDb%qA@eL2}%{Oc{~>U0@&e~nEbf%Xw;%_O^k)oD+$9&)_D@JNU! zP&BtZ3?t+lPsiFhVDXz6BP-ZO7{a_!Sv0USfjnYVmi@kdFT^TQh_QMuf0We9*mYT^ z1D{bc595P#2lFQUFX;q)*1x`{-xOL`O0U97l_C17P)sbOMzt7~#D!u@2JP07omm;ty{}?Y zOWa_0xX4lehyaL5$1h-yHbUSuJ{K7#b_^KcRoU*$}&x0ICOITW_N*)?@ zs~FW8EH(i^%GwcWgfAWy* zcr6DO7Z`4vkA4za?QnRoEBul+Z>f7%XMX~fua0XqEQKp)=LX|Iwb zv1v=i%XNiMqlfxH?+Q?4VtKpj(@yL-!bZ4S$+`_mfcUt~T?(zAlIqyP`Pg*0Fk8F* zQ=?DQ;M~5Sy{rjttP&rkXuPW(X8{lRQukE0wo-tT*_UBKDDMVdday-4b5ocw(tw8k zWPwYPHJb+!pah0s1o}FVsGkp99~hOct|QM}u6V&{FG7K_IwkB+$**(2+p1gd3T zRhk){l<{1)y6@Duhs4fU8PC;;F&+c%Lf(@fD_@RDCkT|ciT{j6#b#oTC_45(mVCYa z{y2S&RyaQ)nN;dH@6zpf3N#b%gdaK@>`U5JaLeD6Q>-ie$58;aLprnF67-&srkMwr zC?}E6aP850X6K6kq_TeCXEUu){^ym^b=KZmoCs8xrW@*MMoP>u@2Q};^5 zahTSmu-vuYs8)UEwsLQ-W6u0)Odp%tQ33_ZpO`EsjF^Y$v!`)b>XXd=p!1WNe?`U3 z#MQt*&O6^4T2t^j=u%76|hwT$|j8O#NsmF<^=kE zkbhW7dXMLPLkjyfnxvoq&!0aRTdjTCwTM!=W%$Q&v9eaOVH-N>Ilnk9rxuhyM#Q8? zr#P-mmb*RVTe-nY=GT%HaNDIh%@SQ=im;Q7S4*J=E-Wg~EG*^r>iD-5mgozTO)S*2 zcY6`oDavJB)$t_)Y8Q0f{(%yyZf)tRUYX~|7p~<&DhP7 zrlCsu^p7aQ&{p>ZpgdRt$?tlGCgHXye|=d;u^e>E>HK>UAaX4*D= zqUU%$8x`Y-UF=?tVZ$Ucsv~{rM>@kFLac>li$r!rjYivQh&l$>m)`Qmc^EDbcwE() z&XhLF)*NZksHD!m$=%|xGC=fUd3sUFe2DkD${}?g6U|<{0TA@OI?;j5Jd72uvROPU zOwaAJUy;QCkNBJ}lC|_{WHh+3Q9&%ZU4s&YUSmC9?L5@?Z8YnX!{HK(DC-y3QOzwo zN+z^!j3OK){K;BD#ZA*^m^jEwE8YcN?gq*dr}qoale>?BWMSa_>(QbeymUCa%QIk6Yh~qCNwgwKex1P9xuKDy;V+tM!!HsM~jKSg+%;wQ9s z#itA4Na~3f{ff6}3qFe&`L7AFVQRTy)1gELfL;{AlF#^c)@D^I4q)>u!euJrQi-W5 zaH2F?GP2zQbtP}!qhzC7eR<^c$LX|u>MGXkj$*Ve-);P)$!sF_0)-!u?9BS;P6c+V zxZBjG?J5Ubp}zrY0IP+8;Hk#VUG1!18r$^e$M%Ohj^m{ErvxiJSoQb+eE$D@e}>PP z9b%6Fs3lDwoaR{;jxqPj55&Nh-S&jv-XD53-)@StuI=$B_t8J^QRucF3CVkz*0naN zhW8g*qtUP@u5~kjs791{a2eVWJ~*f-m&ifHIs39beQ|?4Yv~%TDe#gOIU{tgtrF+5 zRZQdy#A|T>z~2qbkitfWRO$^Al`Hz*gElXK;P=zUDl>;^Gd;HNG8WLF;1`7VLGW#KYjvP!Z8fJLvS5J?(o)g(kM@@!$5A- zePW;6y&v~YGWI3rOui;2qbbNZC7GW&;6U08VYqR`s+x;Ru|m!zcSvK-g~4p@3mPi) zGAh$(x;HkIHp2o8sn)dUKT$O8mtPoT@^-ULUoNhFi+Oj~_cK1BS7TnC%O76!?Lgeo zc1fQyTf*Piy1t#-2a3aJM!&81i2M=qINHZ(9g`w92#>$bv ze-fr*Wx6VoIGAWE7SI5u`vG-rZK?fzVfQ?|^EGX|I5Czc(cj_-v;M^#xkLBC^$$|5 zVU)`1D!e`4{#ZaM6dDH-D`I$@`)#MV+;Q5sHe`zmu*xHXF z+{W;B>>vz%n$9#sGZTk<6|l9P|N7!f0X}j6?`Avu^v_}IJ$~YrdBc;uW-Eu4$f!lm z(q(kxj9f`-Wo6aedvk5kVdVc856doLI?*xiyTIqmJbq9OsLoDc1D7&Y0a4{zgu00m zL8L24qXNqNeYAdLB?r#rH{^H{KJMPs3RAtkbj5|Kq<-eWfk6R;@D_qa!AuS%>063R zP=h{>_qz0_C%6;kEm%rY17gnjb|$Q#4$7#||G65-Vtkx0b@e{1^e$RM`kOdc^2?PMH&` z<#=QX;ZEY}h2@u+a2kC029-9npel?0BN@Kwhz2I@g;QI`SFPcnAzEsO9KR9c*u*Vk z)HP;Hj*cz4==R&vbu&f$h!2S`)a6*GL|LQgAk#00MQ1Oh$zxAYv8NaA<;tby&so45 z9#^;DH*8)X#XIiGd>JIzvf$4*d&k8)g0Xm)K!tb7Ou7lD&ff?u6sEBlNDwCgQHn1^t5 za^ykJm$vP zmMd2`IjLwMtvxg2>0-5;+xFLGaCAIzNjmg@N_*&<-NfQeU2Ch=F<?cqm%k+nj!ZkWqWtIFEHkkS#d*^oMXp27k&q{HJMx_l;1lu z`^LORgXVZeV|GAd)6jyK(+X||qLl@?jw_``{QQs=6pjl`oEPH&eAmcm^x$QuyvthfC@NDhGO{;_$D6dZe(c#fPFb0>9qWQG|NGE4lsT9 z4(V#%BMYsU!)%nO86aCO5#0fI(z^1)-mI?xXs%We7>%lHXqe3zQF$KftXA(&7AyiA zz>6Q~NAeHQ**hIc;W*Auv#n+`?wiwSf0*{WjddLZJUIs4xJ(4WK(dkBenXreaO#w` z=$gb{!)?6+oxF2Er{&QT+fmbDITT=XYCAh$^YP-c=vxEa&kAt9=)@dANJ<|JT?R_@ zGHQj4t`DYf0H{MFUm}aaiO?vk#3d?fcOsQ9I%KK(#4Pi=Pa*x~VYYn%XveiCy&vcY zV%}{QD*0yX@2ue;mBdT5;!(6zXmA;#bDp zG_{78!OB;`vx5dE;FdDrK$P5|u&^9%IsJ4R^|2bAmnWJckCvbILWt!gvSnxb+z10M&y^sm@f3sZ&AdYUf#5iMiFOHOd-m#W}@=;2)#Cynu+#B z!KOW_0?aR^t%9fUkMn9ciOeKs`_;!LE7cP2>N1rrh^)6S3597r?5tjr}xF&+^+*1I=}UO#x0^)|MCl zNcfgUV=*I2UgeRJ0{?cbundv-38Q&E=+GuyK>x8_4CiQJKN+Gsw$IQ^T{c16{E3|(9jeOSJ*8F3!-`wX8J5fu{neXS1lvE!K0F_){~34K%Kt?&?6d_vTV5AeUv^@@HmyNmQ3u8@ z+DO~4CS=tO3{KNSzY>&=lf5<$2s4WdmR7VsZL=)4xL?lDodBCL;a_(W6xh|}jwp}4 zfHCKo@7%aQl56HAM>6W9<>sGtA`gCV1WovH9w=imxbu4k@S>wpF8v>WJ&%|P8J_~Y zmR+v*8v&Q2{9|qB5#OEqf)Qa2V8}p#nfPn_9+*Xn+Dfhk@H*wQ@bFkRj{-3%pT|-6 zRp|50;uw?wdcIO}Z!{sOC=|zeaCYsiFp0NY_;i5=dYeS|lvCEZmGC(N+nj4XXfTL? ziJLTgjV@HSTbF39Qtg9Is7RllF|v*3Jfl@KM!r$ip|bKJjtNcFER{O5%ktWU5d#in zhSJ4QAj8Q8m%|9D0}}9shKD6}N@HO>76uLW! z&A%VmXnXsxS7;v3CJG|U6J@Hcu`Mrz>8tyMbQ=d!w{3W-ZYT&Qc(;jlg?gaOi4S!P z<0LT$-^*3cOyiD~gw(_ubzzMT&Q2p(wPNk!OQiaQQ zhftJG%}`!ef76G%ZIk#;XG`}pqg35@@xb?iRaHjXmTcq*o2+ashlru31gk?o8Gfrz zQsSC*lk1RIa?amCakvE5PsC!j7%lj(ubga(P(n4dOuq%D*K^8X2$Xw#I5#7JC+N3U zZCv<qvr-7YA9MtJObB;ZlENnDy}POD!`wT#=o*0Q!)bPQf2QX@KWwkYD;UGl{7K$& zQOHC?vu!n6T;$G-8`Wn>TBOCw?HcIpDB~4 zHJZeMJ;@CK0bc)op|BOgh+GwXLl?gAo01hMcI&r<8*g6^B0T!%><8wI(3&V9LRbL| zinOu;3r{mMiTX+?%`fxHgEP6+SuhA~XAJfDG&@9O+l-E)jUzr{z=cU7-!)in=!)tXAZl$mNYY z1WB(zO&pL{K|w(o6~{*X*tkpjFdnSC+~zstxBqreR|Bt7AI$vSxj{p;;qcIfAN{3I_Zk7=mgmDayz%5?agqfsjum3@Z)W)XDX<*0IfeIQg}Q@;(0O9&5#b_coA`S6`UC zI4U*6QQJtL3j0itz6WO+D2Br;)ae^ap5krB50WygPz=L)KtfjDOG`kbug5T&KuJ7+ zR&x4&sSc$*Kf_aGWUUrIYM0~tD($N~UkGBsfG_M{^-msRV2RNAarPl>u*QWC=_8=u z4Cq{oZzMG7Th?)@sq1SoLqCNMrzxcwUAPoY2OaV4l;$^yU)!1!X(;=3CxC-hNsjsa z@jB+uNXP@uCnlZ8HE)X;>N9S-4?Jg(h?Xi9It26Ia_=P1dEvK`vc{$uz*768wu6cOop;R3F`95Xr6mSiWxd`e9c zb3VoKtog{tamnntA3He)5`?MP3ZoV^3kNQQN@}I&3YUnkdK66yY3(qy=KkE(m4M-N zjz;)ix}f@fvhMsqIAP4Y4?7;KkH1hz1l%Z;gQcOANLv;5&|L3U9fN;vy@FrJHRr$! zKN~i0fCKRLJ#Lb|?p1gD1*q+sIssTtSKPx*K8lCE51P$v6sN6iYb#8QIbHYS^bbOhreg*!O4aWbs@f-}1 zZ~f;UoTcDWHTz5^%ReXn`QE9tXFYg+#@H`OuB{YglE|d> z&V7o{5OdeJ4?_u+4z{qem68SPGM&8NB-UiA#LcRclN(GvVwxF}_+5OQTu7S@5#XH4 z&~*~Vqz`}T#^gGetPv=rXV3o}<%pfzwJiL(ppMo!MjV|@%)J)0;oZfKgT+DSY)%)3 zY%M4KMW3X_bW?e=CXS9#LsS&XH94V^Lj+k(AHr^1Yz%ojRpEaFL*yXe{u@T;oFf%0 zgf3~zWmu49ffsMtu!JCOnL|u#E=nB5?^BA=UHn8(|)DoT1k{4so>5%TAkG9tQ)`U!xP2xJO94C895BU#I}HWXBQIL<>*Lw zG_DsUMImO~Fqb56+6=k2kyk48vaOp|hYAsHr)hJ418ExmgB+!4izk1F$Ut0s5!v41 zd|gjleahGSv7dJX93u_KS^lW(s;*>KhFCa?j0Qr<)ta^DF78I8iOWyHE!6NiwT-n#F2dfD!U$XbNex;!=>`mqQo1B{FAxH1_%P0@p3qi?s^oWRP1MY(pR#K#vO~VhE zYE%JP6KN9XUdj7~tIrgMe(pYt!}x}- zAbsOx5P*8>32~Bjvz}3nkAVjw2hnTtn1`)}r3vnM3}p{}Ve2l|qa$?^uSKqqH_}#$(Tzv1dQz0GfBK64&*f^6>kD~6!$Mlknh_lQ%F&K79{zbb7d1aM1 zaJlqo^=#zdsNS~2A&w)dZtCwS@+5L3rFZm)-?$AjsuP1E>8`Ovm}Zn{oMRA4sBF4l zu*QjS3blO`z{y2@#lkSuac4C9nZSU$IsM%vB3MM_98ynwA#MIQUTo$^8a(^Ba}ss5 z0yV|sPnqH84t`#TkP_yb&z2x}x?wg9ca#)geu56Rq%xC+Z$)YABc+l2C zdqj%P)I452C;8*GO~-l{fLJ&di53+Ue$jgR^W7T@Cfdux<1zO}R8Z1u;_go=HUdd0 zw>8Ggo}{pYqj9o59MPXFzYG>q%|plCQRh^eV|{%b2mZYBWd=`P_}R&0FFSaqQLf!k zBxmN>|CGnW=cwX(h6Mi(^tW?1Y!V*^M1I5U)uIp<_Z}n#={=eCBxt{N?r^%Y0P_qg zbc_T>-MZ7RA|8O!QM)^mM1&DPv_eum-{hj_?VtFpTCED*E}}M^X>@xTNEt38abXpy zm0Tr=8_YEtFq`Aq)$+-6-Q$o@biBQywsc+gN`f|TuUmRBy_2s52>f3@Xq9krbMKSX zNP*^%4qzJAtuTD?;-g$KyzcyG55<4?6tRE)O8B-zY&Q8O`{D@J5YGz~4V&!88|p-q zqaYaqSNZcb7a8WBjv-o0z5_>&Z_1BYqQFh#mx!E6*G|Xht$ZK1IMp)CU=dCc*=LPJ zRFQI6sl(_BpMA5Q1OIc$M-CVoFt78@MI-fNei6|T$xhD|oOZ7M5q^F~F|P{>EVrRz zj<*_HYp96DT9Kj-2Po9~=U-n~Q}7LWRxR=I+m|`Lw@DI%x^~Y~F^5SvtW4nNJxYtY zB|$}1&_*#Sj0_#_IUjy?(wa1KcZ{XGc#Losr6Qd#wd1QUOzyg7-c;xFWWFrlq%dS6 zO95kfv*AHvt%(F_dn-BBc><%5!SLGVvtwN-n~;)%Nqz4?VyIs2qh5IZZ! z{P_n@ANLn8;eTrUzp?N`8r*vtxBd;KYb%4t)RkGQ)z(0324}@tfLyyn#0X~$YwUVD zRlg49kg9I-MvrbhW`S047EH^sSzDzn|z-^547A@L&Tm zJ5shdr%~SBxnCY9`%}?Mk3l#{(V;sSAIRj)tw}c+cmHv4j)9_)a`Pkd2N&lGJHNU=P^~2p?G#qvDWhkXmzQ&l zes+4gbG|QDEBVoKGP&_gq-FzSxwbq^(^kM|I1D2}QQ=zR&)&t#O34ZWNeRbHbm_(A zP|t_CJzw8zk4#>*CC{OR6D~fMO?lamOg(w5(HPy^FKfeaFtPNQ3P&f6TXF0*`fgy( z!=wnf+x_lRmal40`2tGDv|7ez38OeIu%nQK4+Bd zVL=aJiToW|HCZIEp!pHZ!bfG*lq)xSldV`&`mTqj_iX@`l$J~}I-@dZf{3<2>XRL( zY?{npgw4OP5J&nX=Gc@hFT@zuj~YS-zkGfbcK1#&PsdE-s*&}$yH}3qSl_r!P$H5P z!j2PogkvkP_*WB&6v7Z;Dc_T~2&>wPTYp}F<0ee_B57@D6c!hX;m~VKvG(B_LD3`{ zFJ&Dc`x0g}?8np+cqd*N}}6S|%K;g;SFXFHRXRd!6c*Y59k~ zisR5-gIVXIg0L`Ycp9&h8kfn;?=Ht#Oj{`bcj>p*glRF>S~602Cw7~TggWZAhjwapq)-rxZxwSNX908f%N?16ia?`=9S_qgX{ZLFR)|D>Ns>Qe&`~{M zF5Gp&I!dW}o^f&bbLu0U>mS+L)0>Zm0HMTDu2fV&Rvma)JXZ+YD=?-uu+kRM-n!bTrn-W+d&5qYo;-LdwBEw6;`E_iQE@2$KQS`a^Y z={AtgVS;)O`#TlTQ+~j4P+0Hq24RFf3;kleHtuYV`f_<|Zd^hs$itkR&fm{K%!)z3 zAR;lT@2!Pp%nMSY7vLLq$Yvl~BzW1LBBj1++okgjeMd5<(UbK<-B4A09K&YBAb@p{ z5*36Q9o^A*itNuq=sx$v<{?T=r>KOg8~yeMGeM*<@jyij{}?IPxwvPDG@i*$(H_!( zpKUGgmFn394+?yN7tscBz=TU5K$erOll0ms8|wqyv8BtL1(nETJ%an!2r2{>)Yh9 zBDoGp!{Myft!#a8w6e!o$ls8s&1%V%XyVb0joL412H$DYz4Kbxe2QS{m9!BlCAhX* z9LJC?H3Hkbn8}}z{wE|eV;VkP8N+R2x|HNAWS&fHMGfk)+jNCi_`9;xTQNEu9vm$3 zr?O>N_z@0r{krUou&1QKugxzwy30azNS-bq*XU1c&AAV8?ds2r6!q(8W4{RO_ zd>`e7Uzqa)6x;B`=e4}z>BaHn@fQEu zDZ}X%C>J{hn5jv_e$+5tHx^#^x+Y6k=gju~V|`OGnL+|5ub5|dV!}3babyTy!e@>o z*1j@%QKtoe(9)*;;hqF9;~de%Evxei<$yVkVLEstYh@9vs;uZ!_Xr_iE9FK!K{ABV zyeOV+k$UzEHrD@r^vt$<&!W45bj1Hj>Vgh6D~3g+X|Mdgg#d@|&=6$EdhY%#o7NhY zsn2qKCiKzaiR(s4A5ZV^3jvMpC0ToWx!g38 zEcy)Ph12~~){bN8vg4on&=%ez0kgWFZzEx~;s`>UxT_R>m1NVcWs04cTKpaZ3F?!G z@Aa?}(Ct+I*qJKhDu0TcI-H#B1?f&r%Y$NX-i)dW#!J3|OhEP_k|!ZkYd<%RaY^H$ z{G|HknXd~KTY;)K^lH2i^TxUIIShWFVMaHj9Q}D~c%nb>@qbdWCIfgSuEpbP=`s@s z%S%Qpckd2yBirXw%RbmX6-{n^_=<|vzuH||v1rx=6-Eyo(}}S)ynl*FQvaHKA2NV3 zZi-VVc;m+_v1>s}YD+O`?5TIwd zqnF#6HGhg0#xTB({j&L|qGkIL1Oc$Rr`A`)E0<;cjc|DGY&4K>A%$_2y%#vey>Y!G zv|}~r_Sf;Hy99~6k>?K|CLgprNr-gl59iws-OO_UzMkIlXMIR6+}5OujyVt6s%>uA-rc8bf&%LR zz_C7WL9vx2CPZ53|Imz>NpfxHvn2S%O{kI*c*05L6W*(!qA}-gf8`eTHbnB0wPpGh zc?r&UJ+_h;Nq))8Jz%&}`c)ML#bMCcGrf~Li~VbJGdbGS)a1%k&Vt#&-cj@hnW&u? zf80gy5=-^wzIr|R>S+FHt=n)nYB?;?b0NT58#OVHPg<*u*#N<-fas#~{)g9n?&UdS za#rW=Zl3-H`W_mTPF6-{D@1~RMMjo)8Fv3!B8_g6gIxOX@UlPsvGeEV3E`MR%)-tC zz2U5$#!i-6e6@OhZE(}P3ib5_;syHCN&!WrF}H;P1IP{wj^5HYPW8n}@+CxdpTog7 z;tPGGmsajIdrrAY^>Q5;$66ebUpYeKau604lQ0!5h6#yp(&LBcq*k0{p{ow_vCn*d zh(as$9;_%7_d&K%SJL_#CHRnB6DPX5N3>_J8McsR7K3U?@HQT8@uTxp05J-um*0 z2ma0`K#^UITKS6+!7`yg{#4AHcdoRy30tE+f0c(6VerXdHqs((=5}Quuqeq5sz*^H zRNNyI+mYL~GOU3Cqo?Z+b;FgUovOqdPogWAT%$~nHeheO&`(WaBLu7?kLAE=2?>O~~ zhjKT8LF0k(FupS|6pN;*4nPVZDf95&28#- z>^o&^s$;$|e3NDE{w9CF5h;}mhW0mRdZMe5NEWfn+~4`7kH@ttCU-82&Jk!T4P609 zSW9i~&u8Svo+-se#D9);ukL!$k8dnOFVheQ1VjcJ5%;D11tm5pS*r+i$&3~T=Ogqt zNTeu<-QAQNpe;~1*eNGUve6091`3MF*@`Z#0^n{Isg zYh~AXYzNP-t$hk_np_-@e-S<>-Vx^dj*qv1*&wK5vOe$-ZWWdE^gvzUcffimeH}8f zspHYXy7Y0#q!Tdx9Na9kZ%i)I10E!oxqYSO%f3tVRj}*gwX1+_ zW55HAx(xj?G_nT&;r;(PVCFs|v7-KVLAjGUJ3WdRZnZCZYW^pzJB6bHNkVvwHZRJ8+hR=MWLaEPhtbFGgeMtAl!`{9I|?F;qb>udgqi zYD4$@(JI`MC#Co-sm!Ml1eXHUU71Zs zEo1Wh$F(Gn8(u6U>AW@lhphET-N9(54#ceI|K!U~hrIBA{+r|G+kV*ec)*ho?hG+I zQhDIo0Q8imsZYOH-^u-xQlu?Y+^3uK5sJ>Ea=^Pv4C&93rG_uADagRym5ssSvfKnT)+a5XB@ zE#<|I@Tn$p*Cl-S@6#A@=VcJqyJzUyg)uONDnm+8qGT z7H^uDcd6GY)s-@8#Od*aLozcRwBJDID+^Powl3+w&)mpAm9qx0`BusfZ9&Id$`-w~ zI8@d*Kf}Ke#8kcIO+oG(kDTGi+skP?lLIGKuH78O1;)~a*;vo4H}bsGX@mQ5`8<`G zhj@r_LjewE1FAzp`1@MGi@-qg7~sirY91}avR^v*t04jamf*&SFGwq4mm9rdC<(Sc zZQ0dNOGG!h--m-HJaEirsy^0{-Fg0^j9F#zVG_<5R?Q-X%m4!5V>u^8XD;gAc}D}5 z;_*kBtlMlW&|sU`jvI`#e{4qrpzkwGJLCkPuO?A|3ILoljK&*PL^-v&ypJd_@c?y0 zIK!ZI8Ss~%w3L^RRw;SV=g0<~nTSYb87Nz6r|M7&q~^~DYHA8i-5BC^7$Dzz(fQW- ze_ErIve{>6i(e?3Dw$0Aw)l0z4Lp#vn9j31Cx-Ug4;W#hm{Eei9n)QZBC|p!;CHc3 zs(s!LNXlL$T6q&@Hn{DYgD2bIg;<C8NA-*l^y7*YV#C3voZ=S?`;Vu&A zQr-A4t-f%`Y3Ls-`t{m9zkY9rX_(z(^ph>r9y;F1BA^wo=XE`O;&r_FR&TaBX?BOG zfS1(9!8*uvGhSY~P|r%v(@>&S@YZESCS5wA&eHo--*z?c%~bLIhXOUo&g*d6$WFz~ zl0UVD{O^_hHg=Zy`Cs}C?W#3w;O})G3u&F)fDgfOAf7(0Q`J}ZXH^()rn66r#uXUf zh)(6vyvh6l&a#Yn&ftk{cJ;`Q@!`HzQJ>Kj*mxl6p9EWcQBfrXBwQt%Dv>WM9*xtx z-ELL@rt;R5*E846oE0E2zs}F2ZYaW2gFLILFLb=yo{VSS1T;GC@^!>pg)0GqU&>dC zzlfOykBw37JE>MjfW}b$4;-Mk0IM1HJOq@IG|IM&CAIgHjR52Q-3em*9*m3|?#sz7 z(#v0$mJ>@1Ek2GJ*K{Ag$;yUV&m=8o2a_CZ#5@A+-4-mv*^K%eQQ$XfE1xu0lmptguV8Tr zq|kjm^1iUpykv75sN>f7-wLX-jF2wqd%!~|SkOo>Xind6>miGje}VN{Y(MjAd#Pr@ zguuVY!61wjtTt3QgQTxMw*3GNXFev;?Yp@@_F`@4=KUb<1~nsCCWj8-^80_%13yMK zfflM$lljMGEeg9!n8U6?dki=1Mc_{@WmG{a3~oD6c`YAjja3JCPK z{djSP<~L5)AxX*x5Pom@`-Mn1P3^mx$MW}q)3aktKEXYA!m z(0O?Um;mRcX);Xm^77#6xft`?WwN5jVVB z+qP}nww=rbjT&3;^m+FF_Mh*#j${7M%zdqUt#h3KnUHVsI)jYEk?6$^)1U64VNpGD zKUZ3N4#6Y>nq(3wd5#E)Y0Mi_2E z*wSfM;L-KGPa+cYnbaWn?RM``e@bX1kzHP4gqL6I6^sp)Y2&PM@y}v??`cIPzVXC0 z$mwozocUl2CaXvAZcglPQqQ0)be4n!t}t4n6L@VY z;8ZoAK!3t)0b;q!yT<)HMNb-|=dV}lIT58_hYrS>RlxJ1#>gWWP?`kc(X~9+y{K!l z7=GQS8u5BqSsPF0zu9^omij<;(Pr&XjQP^cTj)uh)!rT2`qB0-%r~AE<+^#5UQyaD z$SR(Uqoz{crm)~b)bV0m1D>M36VA(cuAt^6FMgRzT6Wa- zde^g~to%Ff!2#h(vL$2>XW#wGQ#dK>O_eOS8;l`LG>)#2Jh?JXe)_=;_upe14}r^N z-ex?N#-fMNNe0etF==uPY8Mb;%a2#^8-W?Os_gQkHvHd2Str`Fqd18e=m(Py@8Dtk z76S3#aYEQw{de+LW9ITH0GxBlhlU0T;?@MmJIu&PUmHS##3>TD&Sk5*DBu>Uk@Yxr zT$d#U2*j;0TssLt*`fl{{uz+Ot&u*As(7V+Ae6w8yo=n6&ati@otw(>6O<-D1QJB< zfC+CjcX!j~{LS?`r7?xpJCO|z^mEpIl+y?T8)o2ff^fgsSa!sOyF&}J$aWRWao@0h znAc}&KR|;NhVx0XY8Zj4q;vWeaF2|phbdLcO-Rwgu$>A(N@A3*ekbxiuSa}fY>BB5 z>qr#Acao1NWZu>pAxL(Un>o#C+GmgDaNmG0=36#;%>gNeh$1l=SlzU6hO50mbPQlw zVayNM8n19dP6KZ{SY`i0FTK+DZfusJ?=)8nG37td16zAvw=cImtiqQ?YR-P15)_Hn z;8u%(JLJs=kX4RT<-Q60fjaAhe5_=O`hxQgwctTKS0YOTrfRz#ZICPIi|gH-ZrNBx zwOSZ!oZO0kWUQztt|OY#n29kj1zAH7<>mm+8))mLiM@SR8a}Eh3UboBXZukjtt94j zkdy*A$@Y^~5_(niYeBft(&hoT(QMir!P?Unn^Ta~#gO-$Soi5Jy`SY&I;*XmFdg&` zD4;^KoJ`NDeY;C^dR33wqY|0MX7H>0Q4q+G3Rr89Gt-4e=PtYZCV7v(Z7X2sc~^Dk zmaOIxYonD{JW7*6I){Dh*;lgwn;CAj-#xL(u1=^h_bWRWN zZv4bey?CP(mL~P(}RFCHu{)cd42#0jN>At2v=@n@UFY7%!0%KB`0jz_heU*iSWs7h{zLbY0^v3 z1HkV2Re33knC0+}Ir=s}?fM_%ZUp`?zh3MW^FqoGG~nUJ$l-m0@_9msVi!S`;@{qy z?4gQvy$&th?=V?Q-W^NdQRJ6D@a^IjlsjqVz~$Y1vMG!fyQ=goqcPMM2sxc&bh$V< zaoUEkVjC?NTk75oVwcP7;zDXXx(ag$oUasJ3^dunaf3D3wJPz^WP>p|r4&29;FRuH zHO}r0=+6@7wHWeyFD}oE8vd%&?hsIHL>w%k>)yUnI1{o~R$qsf3||!%dRHQ%ce@nu zZfbahFmq$F7n+}i2-Ka57*tFw-SN(HU+^PG5{czg=D^yf7cRAAVo=gDH8q~HP0?n= ztjo7civ3f4L)UdEjRBT!mfm&P9UxZxw|IA{WU?|AYviNZucPD>L+CwwV3S<|N1Lz~ zpHQoCXY=Yt3;P}7ZQQ7Xq1byVsF|~Bp(zu>;6mxc&<~1`=Q)&A=Rg|~%@F~Q_m2TH z_K_0cFGMu-j}Xs$VL62eUG{Q2(It)Yh9YXfh?Tq);Nlc=Bg?|noMsr=&j&^@{U&*Q zvFm$!@uYZZi|izi6!?Empj~Oe$Z6}2*Q8^-mD-a2OeT6z$g62C2&_(v&7kY8R^S>F zn<1B|MNd*&5!pDXrDgWh{MJ7T0pY^Gci>$vm-HQruovgrM$z(OhQi|y*X0?8m3`3b%G{#Oh6bTnOs>#7%wf%#_m}5D2g#g)Zd> z_+p1|EMzb;UXk6~$t`25+=c-z55dbD*(}kfuyd zMK3}K-U9%)3w%^RX`(hTlC4g^x2lza@c%sy`w(vdRd2#V%SK6nU^N*qlE67ARR{%? zUL?0Z1&=d}wIl_1GK^SE@SLcVO~6b=M>u9NsxUJQVWl=jsJ&8o4&zg^eunMB85HrU z6|JPFWV}uB5?##D)uzk#T4g4Ibz024OQnp0>7&WYhZ-ywqRu6MM}y*8=0c;de7nDW z?(*(o?#n^DUsQ61ZHNNLjrz_Unas9lfPC`R}SYD5U+A4JXm$RD;qVw?_CWdbLq>Z1A3ZI zCa{0G5adF%bo2Qs7$9c;g2;F!@2DD#17+FueAoXG)1{vg1Cd@707=XyGo8)J5Xe^1 z)e6qcJn3%xgnop1s1eqEJxZ;f^7;kYk`xDn8Ixe+xsxdY&2#Ai)^M_-1kbX@#L3~%I|=imW8}(ZEkd1)vKCmuzA{1sA({#qqCAdA?SO2rDZAz% zu54{mDY}|2UfS5kp^CcKogE^@#&aB0VgSytUXv_31c6QP#2*M z?GGHu;9_>pYL8veq#5@Y`z*s{(e~C+>%UbcMi{(PXSI#S*Qhkds{$wV-gei#BPTm zonTeFF=feEIaL(dm4o!KT8m&4xyVS-BxqsM;@!PSy@hBtjRlgG{(JSP1?dF=O={#O zKStffHh+1iIv+1IyU@6FY?^Bo#bu14rB-i@2U0##f($J*Z z%vyxVJ>=Yi76&g*WEQWYk^U5?Ed_771!IS%z#XB60B=siz@U;c6m(`eP1pC(RaYyL zT?I>?czp)Sm5f>j834Xu)SZxNk7GQ?Y`Fta%ywiGdDw`0(5*@x0Y1h!!wP>6Dd*zg zlA$C)ggoPt%C@gQGN)MxX7QD*k>x0FY6utF^5VtSZ5#b#Vvk){8GkWGX8EBR(YAqf zwKZETX{C-72hOE|e9|BEV8GwepI1!wc$MX?U10or-r}z@5=4vEs~q@xz=+O;id5Qb1FZ zuYhiI9-f(^Ys8EclAw?XwP?TyZDA9`JT@yAI3bwiju0CQY`_v!eur0I9+nYtX6v6M z;<^AKI8D?c^gV3W7pSjvXv9k8atGQNSfS$85|AfW>IPM6 zh7h0PO5k1{x{MOw@y=+IDUII|_R8w+d!c}^^c>@?0^nnYn|0z)Qpuqk$}=mom4(-= zC%C8%3$!xCtw=g;509~cd@5?*!$O(`;^F#sDST#QFtg=_Q(qOr8J_X*7?$adJvxo>fQ8puHFoXw(S1Mi5|In%-0K026M%UsqG@TFh1bS5 zABqX9$`Oc1Fg0g3xt9OVW6*5g!ZaLx>C2|SXLH3ZqPUh^QjZ@hzyL-PnCLY zhQ-@c(iw4{;_rcyPGb{B&y|9hY3$F;Sq5!q-F`V%xHd!HJo6HEq^P!&5;7Lj@#|ob z5Rug&tqsgV(V(m>|Mq2MUPi%ws(~-EA<-ufy1JK2*w?!zHKoCK^2$O!zM2+&U!)LNDL@rgy)aH`BU!7;zEEE9D;&G7}9a!}v28M;)Eh9>mp z<|Yc$5=3nV<~TAewoLg8uv2^d|l-d`^agU$o=KC&?BD;nWz6VdM>-ind%flkgl-9IB3>?QiO zHt4bOs|2IKY1*Ib_tIy{c1i`d(5l}s~W?=ZNnu{Z&w767z9{hSMYj)F>m2k1Z_sgIs!p``;%)*QS!G zT@%mkW=9i8sq^0@-hfsaLib_m*l?qo{sp%tcY<;eYMi4VK|jQ)gBZp`Vus$SaVa=L zWwTutbM`=pFY|@8p})fK?YYp6VL97|4M6< zp9g#>rJQ6Cs0U>*ptA+uZ_D zX3`eX|IRrVg#jbGAmkDLpGxw9qAs}}%K694pWR-ekJsJL0uU|vNav&ajQ=YB28?|G z6S$s2l!%q`ed82%wx4@nS;@5^2YpWIs-CRlckHQ2nJ#7O?VGMYtel+BpA?2<4%N(s z4vv)$QQy0}MWtD8u=0;55Uoh00xat+4a2I7@gl9+wb}WT2wHNTsKHuhtai<+^T zY?t}>xrmV#XgC?IVwY)o@bCWmOObLab`C@B;~eF|Jpnx-bnjh{OIb23wy(F`+^a%* z%&L(BuWTH~x)6Bj=vG!8Yd(X}_MF_}dEU2tv(UPU1cP}I1ef6yKF&*|)` zp0w>I$Y+)mv*F6QKR6%-DT~1t{=X^kqNH#4kd~*XHr%u9(2du+S2H2 z_WAxO<>%)o8Clpo@%DV1$v%@dAEj^d-)H6DCxbNjDENBNkh_ju4us3m)H-#5>*dz~ z46GnbQ}_B-l|Ib7wm$`tbw8FXI8{&=CFG=?K}6AwG2g8YYY@v-FMbj*x3jSU6dlS zV%cp%bc$uVgc^fx701GeEO~2NGIA`ebC2AnXNyKBZlGvAwW$rJd7o^!scnnl%0A0> z@j-SM9=Fq6I)n}eB%cIMr@w4gYdA1lyzft&$z+c0Q{nBq1WI4-{z}7jznxKF!3mybDw*D7#-k)VB)5Mk8Y8aKa(o9Op;;h z3PuI##1{x8ugzGwL1C5V97{Mw@fTLfk9t)BwnS|=Hzei{{qt`Ji%X}DFldDhNMgwV z`G?S>k9V+dU_+l{FO5VTMgafYPgMQuCmIu0DSDbQw7b1HR;qMNgKYNAsSXvhdGpK4 ztZWjk9~@h3PgX5vU8yF7CBupwShgvi@Tu~w)-aw$n^Mt_f1zd`ePJN5ZQ3h*JK#5- zN8fD8ij@`nVAl|fXRN$bnS~;Pwr9-&R1%#Y-%@}=pIByk-e%L99dRTEznZ8HWE_Dx z?hj)D_rEX_9In4)k}Plj_d*6fNP>f$3V04NWvqwd`q;!eEQc=T5y|KY~xjkAJ? zXEE}}&2}dsc$h`=oi_|dfA|{AFjplgBJHRijKMfGKDmk%t7xDFwQeb?*XS$`w656)G0j7f4zka* zF|2B?t4&qLmq$QYW?rF6A9x%=wZx{iFUWcaf??xefyxYIV*J~dj?q^o-EUWOVs&S7 z|C+D?bHf^CRLzLli@+LDRk#R-vLXc|{AfUbrT@@@6Z`<~T8;_h9a@yN!f8h%6WmE` zA6-e=pZuA|syTxc6c;(4t6VBGn3|x?u`gl&5wy?m^YARH|4`{&?>da@tgLz> zbc+!3=CQ~02pARW8JZk>bK5h;W!b7O3;>-zOwcXWH+{W3S-b|(Fo{5^_mi*zjqOn! zt*&P)h-xMBA|O;+eoixcQ70z}yqX*DT5yDiTCzJVcs~yv3{2mMOAmOYhX3vxX zz&-+aq->qmXcX(Zy{%)BWE?dn9rGjUV+ko9E}9pfZq0a%78b2sUVgv}zkWPhMFtse zZ0$Fc`ER)18&v7F&IDx2uDx73QZfc=mI}Z4mHz)Wx1MnHx=m#y0S5Z(h(Tb|Trym7 zmdEYoFeuR?IN%WnuF{t<8%?L#U{W?!A#^TcM7ezu!(4dmb^!946j65C87c619|we~ zIUy7aAA8%ksb6?_%9|;i>_cRzF+>T2^$skv4J58j(3+ZmL6a|620(`hV&OOiy%_lco*Lb9!jQcr8V!Y<9W-w;y9 z6mYl-H{#Iz%!J}#ak)yM$b7ecm({}RC0R8K4;f2mMFOJCREoQdC~9C>y9ds)`=nk6 zN>1!Ne8)(yq#4H@ld@tBt}4%nM%Ji|fF;Tv=D#z6ysl?Eh(M~S(JO(_Oy@FT+Qk3q zf?^=_q`>)RBM09>T&*F~SOJSZso|Atv(k>(0Hn>bCo*&HyJnwK!no`)ie}8byFfF{9|_-mG*p8P+k-6# zl!eL@aSMvLa$DK0i$cAY%2d9rY4+}@lsbqju7cQH*f0dHb1{@BfL3rgEBuAao=Id; z9UUAHWl#lV^)ez9?c1`wDXe0E`tQY|8wi0*)O49V9VAU2gpVu4Ku^yO4B2smItCky znTxn+LOMyT5|^)PBuaHX{Ug5aEVlOewkvVL9WM={-CX0HXqCE`}dsyKe!));F0o#+**Z`_A6)Ubxz)BUpl zz^#MN5UXQa5z?4?L(GUp%y8lo)(QyzN$j1le65@~%=*ur2Holunmi}93N6OAJ%}hG zp`ECUqrCB$Z9PSkOff6PKLhn3g2wL1)&5{BkDrSq3Zzj4tq7Wv^8*azQ$ZUh`tfQ) zBU7qlhWanqxrKb(W3m~i?}SY%-vEmHr?F@X2EOXe1C0{o5UBL}1cTt+?Sy+)fL*85Vwx|z ztFt?AXly(cXhyJp4;~qza24DX1@8opTb?|eOm)D}2=o8^c;~wLNyvu<%?;(UC{f6U zRt*>tdmmYRPZQ3{WPXo|WFrp^xw8u!C}BG20?#%LT_5`GQ6PS$(m|9iC1OZIDW4rX z>33~O|Lny8}T+{Ne&7BqpkKSH2 z_(||@*VXvEl9nYXY00a{urwUbX*Pz^bv=Uj#b>GUO>fxxnReCcE8bxjTJ*3=_8l;r zX(gXKWsudGvv6j=$Y_k5h3lQ2gvD7u>zOZn@$E9T31WB_UA?v7neU)hgrYiVwmRy2 zuWd7nb>Yt<)rgQExbdyS)D-2vd3vSDCoN$z5NTTvF?Gqtw17E|uTnGdCuxSqM#!eGuq zWW^`jj&^PFUklFYKFyBBtRBv>8eD_Uu5sS^68ybQi0QQxOhAom?5I|M`e-lDLFeUcUV&Kz;6ur~^iAJHKr%FDQrZ3Pd5~1Fm;{ zyquwcS>KL(d|~XjC17)h`qXPa_W!ArcL= z#ckLRVoLfYw0(>A*Y6LGvl=VxE*1Lnn%$f*|LyrAHit72nX}zcAC8f4qX6;?pWLp~ zz3abPW!WS^sLnQ&u*T3% z)L6Rw#j-5Qauw(7j=b98S~c2S?R}nh0Q|F>7-{qbNh#$sICG;c_t0!L;mWq5D78!L z$07`Esv1m7eJ^YNJ)C@8(CijgS#xdqgK)2lF5bB?8z3OUl* zMmWSnoTO_rqvaEB?5B^m+Ww}IIMK98ku$_4QXyMy5 z&Q75NowBHJFQ~M|vEVwrSS)8dZ`jm!v!++cRYFt82|nncsGez7n=V_j3-TQQ zcl=3%z@=jM`%{q%O>~$lSi>H(x{?ce39aZ^QBm)L?4>x%iUpwYxgGbueEj`RRT$8! z#unL#Au?*kF8epV3>=$6)=nvC2+9jigxJt1-3$0a zqP@`gE-m2Ilucb?(-$UdXKvpQd3L_u3dA zD_+JDG`1)#SDff_UDzPq9iC9W$*ZusoY<~W=16N~(UWdXqT!PVjBRIFo@_88 zxZR6CK=UWOgV%d31;oiPuJj{j%_=!v7-wyfqZW?s5WyKQMAbSSI(!BO8vLMi3p zq;iwlx9!J1U3|W;K(d$1E#N&RhjP<#Fz~dpsr8*9^RYqeZxcXsmIM&s-TT6N_<)R+ zqT|!=1|W%OR6nse`52<068!s8d~X;TJ% zw*vwSP;rfVzVDFD3ZgAQiyq545xUmMz=bJF57!s9fRO=MO!G#F=5R%*LY>{S_XL`U zKo=VnNUOgEB1==sJ+C{MNljiIWjX*rAldf3nf{xCYQR~SI6-O*>XjAV_YZ|2Uc6_n zyhVr@CO&}e=bC=*n7Yw=ymLnzgBbXQZV`}X>|G(NB0r(LtUloT-TJK}&_5^>-6$fH z_~JWv2@d6D3ekpc2(fj$)#x`YyD@n*pbxhEGWIwJ+g}^oV>8_oxjbT#W{Mu$k1={t z2UTi@?^6AuHki?m>EsTfNdBQR>Uo~s=*UiR`cn_Nsy@57~!Hzi$vfxe?Ywj#KnLHur zA)N6TGPloPF`SQ>>Hna~0mT8pAZ0zI9gjy=?LiqniFpo1BMZ@MiiWnlgQ7(Af#2bc zj^j*35<1BX5!iHvIy~#xua8oWAcq`0o8J?B@2(q3!|&_XG;r)|C>`5$OD+tXqqa6ZX*VmH9V~t#W%LW zJI@gCh`D0o87y8)W>=baQAD1x&$C%r)PTF31#FzA)Cg$YX{y0vw?gr{`xB^9scBwB zdiRq-UU+Th=w_X`US4YeoCu2n!WkHa{kmsx;dl0%Xqb{bDuk z|R`pts(Fi63w8K!Nf7dau`#rVOlRDv~szxF!$`y&bU>?4XdG>)ASaz)W7 z3HlQ#60)TAF{~0VrQ60ym~rS34_}|X9)4!pd%>;>v7!dYlMZqj%|UzYkMEjZ`Wdv- zsne=om`l?$FTNUP$~Qp^@NKm1fsJ9F^D|aP(-3EKE-x?Rb;o(wxoG#TKn#8$wO@Ti z-?$N0D+SIOnmU5{uNVjg{zSJWs;AP+5}B&1Rz69LejB{mioy#a+3oc$eEiv~64klu zVNB+KyiaXR!+ae-IaMMuOJK)heD(+QKFcf+Hf5gog9Q1@kl2HiU8d&}PKQiavpu`& zUVMPuoR$d==L2beklqWM(>5&~nC!j@K_r8f!X|?my&)b&E9moNtAfDROB$*{KJ}}C zAb(^AFSQ%ta9Jj4`56@z232O?&h}h4-`v{t)!fgo2X)X7r0v0b0mdW^)#%aD(h|>@ zfX6*}H+lY*eqpRZD8KC!6|ho(R>qQY%S#H72+LA-qpq%m@nMaUXlvPQ_s%&{RBa~t z+fA-i{Nsm;hD3MEJU?1UfG&O5f;PU}LEP+NjuZ@I9$a|~LJls$vZG2u$VguN+SG*?$ zHez1FZNuy=jsz#<5+yz&w}L}ZuCtma_h)r6h}O}XqROb>sBAo*K%oG#Bzb+103oq# z8Knk&)}}?dTQ)zl66g86vT)LNvIVm!1(pct78(#61-Q1!)g%_ z+R@__%1ol}@~U(V5CO?W@TmR5vLTse$GOHPSqZisr+;K{(NqtDR(ngb+K5b@M#|-` z`Xa2=3{sh9n%>lr(Wgb425caW!V+BMS%k0ci9DGVOxct3ZZ}ClggfWZv18IpYG^3o zm8B(iTXI`3fM1hlO!aPzezVNH5@jl@;ZVH>x$|e1zm7jORCU1-A=^qIasHp^Vtk+AmTEJB%`nc zx3;z@k=I+BOWdm~&YG+jm34Hi7j{-$^`8{fgqxzBeds8d1IgVciU&e$c#_9RR@FHQ z#&u8g$x<~avswrdDqmLj1 z2YGSui?hLm+IKlpy~sX8p4avHd*-nx&^Wjs@L=*+1N_2NcWuI48L3ZWc7mZ;Op9E? zKuGTOVPLlfX??hDn(M|QCZsKfCU1T>lhGKBkqdv>v6BM)rjrAxCv@6u(XnZTC5{1f1o+lBUPPZmQ*pwUp;tma7@^R3@zPW`72LPV{tf019Q{A$m7 z%X0be(hC=E%}ILReO(_BQ9Q3YiqZE3t$ukYv8^0dHykXGTB-}}q= zqp5Vhtd{qYq`4qy_&SSe+=GLIG*7Eg^q*fnOv4@^--yD_^bYWqW@sDB^TFe=-I`v; z%d2);7!*_1)wb|tlK3QugE<+}8gld41LJPsAaZ=9>UevJVS=GOcc}ZEi`M)FxPyqP z+xylk%X>rsWfL@+5d{T)I8K5XQ}DFhJdC=xs&2uI1OR0Xg;H-!ihDVx zFyidoWO_p8Q-DJRAywh3Z!-AC`Ky42X9^>cQV3xi5^D2DITlx>NnO1o0V#l&qO^R% zXxJ+`Su4>cnskCbHJ~J`3LgXG;1?~bh>Hk@+5?F+F2(aTj44JVBD4lAW_=1pSREl$ z9s7!Es1LCSL&SkF7GgRNa6}m$iA?YAJ8p9n4ha}FF136DppBo+WaGfF)QEF3TYkyJ zz#1bNBlU>ROp5f6d`764j|mZKu^JRSWR+Tkb;(%$@$OKMHalA%`fUXC*uK;YlsaRJ zPQr*X1WVu!haql0^I}Y4QCpU0qk#6f=t4g8>>1a&VbrYaKmq+^Z8u}Phntdi;yuaO zxIe2E*_S^0n8d@wWNkgeV0!0!_Y>6s;jjzILdLJSm-0`dBUcIB56dpJv~aGF_D*y>e}2*XCxs$p)Sf|SW6!$K%tyXS%i?zEIFWoiKh`py6_DD~>g@=bIG$Y-<$Z}-^=DjoZ=-=vGzHrf{rXc_{oD^&AE?{n+S9@Uo^L%U3vV`n@km9;EdJ01hI>}UaJ2uz*vrLzOFAMDo zs+nvxnP93YbtnAG-Fd{Vza#dH&>8lD3XQFF84|&6#>Y7scfy`;+`9pw(64TJ> zMMnBLBbPAJe20UUUeW|k$tevH`McuxlLyJ&efv|+FXZb0(evJz8kd|oxUoVaOQ*-R zbLaAQ^;=-9AIs7n$`yLdY3g;G=p&|dH;vI+SAFD$#pe!%-)nPyY=)|Az}1}j<{E2v zz-Ux3G+3@2J)V|F4TAXD;1xmpn?!2C%+mu4*;S)a_AkL_sJ*9)P^+)cjWn0QtVkje zI}xsw*gmTMe6|@L9RH8??^PU=a*k4k)!=o~Ux@lgzquR%4~Vux8k9+#!}&E(x%n)o zoZ1c>fY`!)RFDh2&9Q(UE}BZ-p6U{e?6bY8KAvZr*!8HPsi=`(opl z7_SJwQxht?1xRplYw;$HU6BBbVjJ-~9*zfS!z>?y2ks0pAo~Y+PJUIAqFZ-3jT`QW z#ck*Na9pP0w!Qqwa$B<0mU;+=I>FxOev0ko|7|m>D24<+$Q!gDO6W?Q^Kz^6^qxyN z2npPgFxNobWRCeu|Jc0x24)&Vq{z<`=_em~=LHOIb$S$=1+cY9APy%9fWp4cYrvzh z1yNS@-B}g+9bqH!%|SWx@?OwT8E9Zp!E347SVWgbet$W(Zs#(eZYrrOsGq5~E50C5 zavNcgn{D$Tk7hHY^>zVV&v!Ut!LsO$YN--`p1t4KE1|AR5Og|W21*6`%7Djrb)Kdo z?_JBV#ebV2Ly^w)fPD{f8(7=)ivrJv%{V#)%)ACOeq;SvibQd)F?MRAwiWKHt2<#Fn5s# zCX|R1ZuRq&|GZtUhtfA_y-B6duMeh#)?PEHKG1e5oeSN+?cGT}s|{h8!-v6Qb&I&; z;Us*Li5pid+l5`w>r5ld?c!_&oBfhU?P9e=SUDcAdwI!+OM^K;?2`|hKRN9PM;k?CI$9izYVvS$-TKp+cHS~`zX zhGTEr!#Vp8<-qP5pP2YT{R?psVckJ1;Q(;~Gel3sj=Wt4@I?Y&xG`nf_yx}1qNyB1 zDwNY=N<>f6AbS%D&e4fx+c5bcNLTIK;g>{xQ6GDFjO3?gq(vhT1pTF1Xj5e{x?pK# z#bhFhh8v_uoc38*dHIxt-U%0gnkybl{#F?dc)`2uCqPyxI1MHxB@`!seIXuq6HB0m z15a0lnACc=#r%u+iut$qo-~Np8)X-uJyZ#T9#NW-Yw#IvJLkRE1u?elgZ zlsgoR{Ac9Ab<`)C>}>bjiu#m}WE{QnczrF>DDp*=qc{xvL6n|m41DbiyrCD6?y0Rr z);yk5RjD7+$SDubt-PeCXCawo>%H&Q<7yY(>6jpOf8Y{dnwUD!H}o<*-#79KU}+O3 z4~@vR+xzj3KlA#bjBsgSoYz-30u%U)KH>DGm5*=)>vnQ~mdayF zD>43$DXgc>T&96^su*KNcZ<6pg}CVvUwz2~tX(Y|jLe|vRK!p|8Ycga7BVSH7BS1u zNQ>q#H?Mj32DSl_g@*bVJOp9!S5aJX$!( zAY%G=XHCo93cY=4yn(x3b0Grm@DU9ZB)_>gHVD{~NslGm)##=UH7a$*av7$F_(#3t zD1st61j!*+sI0dr#|L4FqK~$IGJ)@R?uZ5B#v2zX?V`SV2Jl*7O&bIneE|Hr?q@J` zA9tW9drJg2s#sIlV%)+}R_bGaP6I@K?MGO=eR&CEzL*469N%WGO*#gc8)Bti*MU}d zg|GIV@Ag~HX9{b+j{;7E_x{A#o^bbcS7t$pb(k`5yL%H86U20D(b=3&4Odj9<91S5 zTJAwh8i#RzS`QEEE^$-)1^&?txZ&7K`V4+Hm7d_MM86kXMJs*MH;C8;tO>AyRKp^MQ!}L^3uMR88v*!?f2$EHUomLnYhBV zxN?5ly%Eq1J`8E_s2}ABcmqJ3`M!U~DmlrTKvsLDmua+6fM&^-JiiPW$;|YYNyND? zdu!B+BK+8LKS2&>-$BJ(3YDGC68-SWTKErxbaBLXE6wCpV=iZZCt^Fdic@bDB5qKM zgtE4F7ytl>;v5_$@}HW1Fqfoq%6vy+)dfDJr-}a@rww&c`b5n6j1v|uWgMED7*9@C zP#mF;m{Z+KG&a!jWC#=w;*?ldSI`JgRBXqo6@2v0a-9>7K}MS{uBVN`auLi7L7!=Z ztTe&cKevq|l|@?3BjyXQl7?;O_^PfRzsMwyRCSIm(wE9&Go#=2G379yh+R~FRf!s! z6}L0CIF#`_F1>B>bgbETNX47@vD_Le47MP|xz6}Szl+bDWQN-rW%Rq!<<7*g&DC4c zp)esh?L6wF-MDPj-_32)hmy1ts@&;;fp0}(ZDGW*MA^5Ij$3;MDryt~ z^Rc_IK0f|m%~WK;imejS|Nh1o3Z!%XwxXWepwAB&r%YSq3D#ZMFVV{#-VuZOz7~Ko zQDNhF)cy)w#$j@*qTs@_Zn1a!`f)*gpHeA(i8VR3(s+!9z^p`wRcUhp!S9Lj=8tt#^oFB>zf)qdZ4wiJE z%GgqEGX}rF?knF{VoM~` z{J<}Xr-Ima(rv9F0mFt>?aCx})X*WQ>Dk}qKJOFxqt-Xb`%sEF!riE8;a%?_-NiG0 zQ)Q?VL}checDvuU$&q;>0@hN39jdkp^zD77><9)@Q;jM0L6lWca506G*=svX4TM=X z>K|-G$1ldYTWgQ-s$Zp=2q_lxUU!Cn-_PQCx_7{;pL%O?KAQ{Qvy0m`^rQfy#8J-D zzQZGM-3)7OM|O{VLU$h4;}rSM;NRYiv}R z>@kpKzO8<=0RH+ZL~gu^9*7$;c(xaSsG*PyRgZttg`uPU;C`+h`~ZXyZ_KvA!-)G! zsdQ);J?b(D_z?)$?5Ku-`?L6*`D4WcF*I)}V9cPyKpd zBJx6JA#|oeABSJBz^waiQ6)4@1Gmb zmtQ|QJ1fPBg=Ns`&e3t^I<`=)$8~qPyX&Za+9v@P*+w(0VU4)Wt~d%RWVTGu=Ma7m z=j$PZPB#bRA(689vERO-QQT(rxwf~ka{cJ}n2+@{b5+u%TQ!u~yxR35(3Y_mR9iaH zkeG@1S?c1Ghh4}n9^bZArHmihSEL`1$^18Ds{6H(0VB?Wbs=_1{-v?b$BqKvDO*jo} zsQXWZJP(S3ReT)>DwV`KGd;R0!J#=`Fu5~2kU~6_2~h1bpU>TCPa_K0>f*}TKuIU_ zZ;V|4!z$8JE#}NV)cVqazuAt@JfZ&&H9^Y0VBg(xL0k&81Sme5ybS*&;8t8qeTcy# zd^u|kZvV>*xaC)8kl~74lsX_Gbh9a^&n7^Qw3=E!y73_On8883Fq66`1vXLt?_+OH z$0>&o=C_vu@i2Tc;Z-bLL(%Y@T!JK?sILnE?Xf}b)^Upm7hm2%fM5s`pI)Ul4zsA3w z{2!K;gpnW@?((IjxZ$oB@%Nk0K_S%*$eQ=~w?4*yKU|0u+p3Ci0aZ-m(jT0JqxSBF ze6|gn52bADe?R>hUj2wVHM8hJ4#kzr7Gc7?6&SPc00Vw+FqCutlz!zTX(|iWWlO)p zg_r&fZ_TJdvVcIgbd+*VJ@fm=;*zuWA;Tqm8fg|Lh9q5}i5mWByapix;XDLLNi_f| zB<@J*icApb^To(nTvtU}@nFC&L%G5ZC`?ZP^Bczx!`UYeLYI6B`BTJy&cYJh`p6sj zx{P^~6FC)5qI78u-hF=#27hxX(MPHvp#QYVvvJ*hAF%Id(W9gahX z_dsrT7K7ICdtHV{9-oXw#a+lDTFvi(h2wXnI;ZMtjd;AzPeMwEK|6Mv9)a3arMxA^ zqQzff_N+Om6L?kn#edU2&EH5({3(`*OrqNc^t+* z@(>2^J{;Fye;rOd@pu#z7GUARh31sOSgzv4VmI>=zqX6F`b0B&(ZbwGg6&1=$k<039*eA(pzGgnmSAcNYHr#^;DpY}cS1{N%c)vAB|8NhpEUOPAr%=ceMu3&^~|A!5Sg6uX{R z0$)KV0!Z{oRp6S7562NBdn1bg34&otcU9rror(~zuEgJ7n9A`ckKacLUixqb#+-8u zM)u0*p$LHv8U_jJ+cA5%4e6KS_>?4A!;q*BcgJzx8jTmG|Cb;aLAb0!y!-Y$n03|B z7*W&}Rk3osGJYPDA*e;JN^y$$(1|gt$c-7rd!Nn38OQBG?o4tbE?b57J|)2Dm)Q@7 zMJ0|rcsP0$@*PzujM{%6OnkK$<}F%>ua>VxPHqJIk6>Ji>_*6Wr<4l`03LQ=9PfNI z55-Y(jFL_<8f00`y(anlkWKI>hhW`zj~IfFB$le}zLrQPz ziS0tJ?l{GYQ_(EyZuH@2=kJSyMhrwQ#kvCo?qYQXII>G$bnVQ3bKS>S9j2B|i6ygJ zJT~qPoPOL;bm1IC2$FVMIM1-n1=jh+-p9VusZ$(3Kld=~HKGqeX{rOE7;=yXWxC~6 zW9A3b@c4(T5umO_i4CV>l{oK$V{p##gJ|4^(L>!3FRVh>PJI!nt-{UYrlC^e#l9#$ z_;4v^%vptl_UKHm#t`<|e-vJRk~$BUtiy^m6+DO!Vy}^`M-C0oM7oocGK{VS*}i*l zF<$;;9XVx5X&Mts)uym~?mXj=sSFOSsH$Q?8W|bq9!#0X# zBNVQ|4^G*aV)>&{KFwVA*k{eV)2vU8JBxkB$4+LlZ#u%Io*bvBP zT?`n>d0U*LVHrxIahgN+>qQj=Bghq+M*x-ikqdagZryS5@_G2(-xnc~Fa41$8{2Qr zVsgEc!!k|)H%RpY|9Si!lt9Ck^7*W$OutWSj87jcur}SHJe^+6e&3_U9t*#y{SK8*aFvp4RP|?CrI? zq?cRl>q7fIQ6sw{N)MrX`3sB;P*=wM`SZyYc@7T&3vuKTNAsOV067g@{Nn4~@ZrNZ z*i2jhOk8a_?KKl=x-=XG90eQ&GC=_gyewb79Qu9n#TOeT8==KT`;*>D`;)-~0hQvi zlyQ#TcH7O|%L=PFFfHh@QG)dzTYA5#c+S7&DUjY)_Fe|vq!;d!Pd>q?pMFX)zC|c4 zEj6N_cD_?s8{Yc0eCfBGqsn&CMHd-ekKzippr|eTmQ!en5CR*$b?ExlsP4!WK@N%< zZuG>bF==)c)|AAN&kaMhFQ2O&@!mL>DGCU8N%4K56jYwCk10Xj=rPlRV`$#fk>Wsx$U0h0w#JjLB=c}# z7P1b&&RTLYcZ@_UwrVvyO{em*)|Kv zy+$OZQ#$28dD)x$>afgU}&k``SEY7)@oTpzEa>W_f~8Ey%G zYHEHvj1y-ci;{~n&VE`^R*jD*b3GrH&^Yx#^MJU=u6=RRk^AvG&PFc#k`5636suoT zL-2j{{un%920ot0`jbO-eVNkArp(&0Yc~KSyNl@;LCWkKXHIU~G3DEP(bXLMX<*o_ z(|1Fs$v7ac08WGzWl=o${EPIZ{svAA5=rnl3B0tVM@@snh6992CgXopF6SHt90eQ& zTAKoPywg?Vl6_7um;A-mrk^-qq{c$wEI^YUHvL}W-vV+3Om^u)YnxPaA?`A9R7wPF$f^6L^j4;)?e4dZ0-I{nt&0uQ-U1ZW?gAHO33t+@NrtmZ&(h_X z?ri^QDqs1vRX1|vNW=Ab$RUTA@1Uvjw~exUi<|l-PFj)t)agW#JMOZ+TpPvbG?qYS zBCjrz3AX31X))aG_ESKjaoUb@3regahNTrL^d?5*_3@2cXZv&7_L%k?JoeaQ%{ZOu z?@l^VZ@>NaZ7-OM(d-mZTgSwKzM>qp0{Q|K>;p6cLcMsm-7yY#+)Dk16oWMYAoV*+ z#2OU!M7T3Wox74bi@+FxjI}FQV_Er1^rBVa#VbnrUSl`Mmv98D$WivqQ-95cBZgtxQ!~k>MW88|hZhLmUH<*ynEvtSSW^)?%e}t z96c1DJ~EX6kigk&eDcwB{CCDeoJ*_Q^A<0`i{rl_jvFSrKrvg^`JlswVr0Ku2%if&{4)js@%0qZ2tUJCoZnpMZ5I_^Hp(7oi3~a2F1d+$Jv$!68LRU2(nQZvZSOzDD zZ)qKhOWBtK3@3n+XnmI+RKwJ_3xU!sWRu$$?5948xBIGNJa7oJeX{ZKEUL$0pX!LN z-2jjxzMafX?_onb*P0a2CfWNaHVZ=XL$~i6zIomRIY^}Vp?Yn~36kxZ;0Gz)j{^n_ zNNelntz)Jagw0!8m%5{Xqd-TcK;yBf@w2UWy1(wzpKX}NSDnzy;8#;dzZ6znIszJX zl{mK*@0O)u0h0nM1zd`|QedUHDlK>^{gvXvRM>5Cn=AMFxqe$xY#U*RYFiWMs`Yt}4UYFvq#GiMr3Mp?fVSB(JZEjgRN!lmDDDPBvx zw{+0e0_gYLa}Tb#;tE3}OGg{7rOLG}`83`ZXpO_>p_+Z_yCR3rggKQIe~Xa8h6?U! z`8r6$4rX(*Et$BmTc7~J3~su8{I-HzM=q@h;~=v=U~9Ay9a)m2CO4G8!UT=bcsl3^MsR!( z@M8eB_)2ox(N8+wsDG}qIE-3aI*t;!Owecrd;}p0&4%pl8eztFq9mFS=2RIOOe>d;}{bl&`5oG#QLKArUK+nJm9F& z==R!NtRbl8qq52QU(y)Orwj23IUuW;W{P61*^D!4cuz#ClX&NUlPTt%$Ff&q()4BM z=Ua;j)63z@Aq}Xb&zB#@smG5*F6)^^ab>gSAPD)Z8}G+oANUy6{;sT_fE?1Hfc2*6 zIuShZ8@%r>p4ZxOGc=~vza337bIBdXF73;Y#)EZ;n?eqFYwtS3TKCDI3`+x z2Os(r-+N#eyhF~?=@j)w76I5qE&-(kzIEiD<$O$E+iY>2 zhDo;wfhww2GC}%fvV_s-p1bRXyuxAT%#7!R|i2x}r-F z!Cx9l36hi0FIG}!7N^zdnEDM_{!%_#O=rEuElXk$Z&d$d0mPvw$Bvy;0qe-wD^QZ* zQAv^bRTbp^t3@b_??|>k-82pl{%bPIBc3H_4uS-d)xVhryC#)z5)>y493x;#Lqkc^ zu}OLLVLJ2un7j3VWZ1{Ya+vxO;15!-XgrHYQ4CyH6~H~THh(a6a1QNCy{r7@QUw14 zw2Z?NZM{>*0#@0s3C<;9u95TesV+evH`mDl0=9nA)<wo*&=5dYGS`T5M+lt4zm{q7+5ug=0w6v5+wNnp z9k5k8c$MOs3^_0dDON9w)EYFUuvku9Ioja1l(P%DmdelN(>^F5!wh4`jx`{QEKNG+ zD9{lpV8I=YgRxl5Y>stJ9~X76jq{eA#%+m)OTn0QhF@~W-5#=-j6i>0Q)ZCmoWA_&K$Ep_UqrB z_XPQfOocgSNHmr_VYI3%J$+R)mO+tN>i+A`gTF$8dr^)bSp=JqEMzDGT*TsfQN;F& zOTU3^f;~ZU8~Vtp6{J<;B*CT_xdGWdh=uW^Ah?sC8^j*N`!nr2>awF@ELqkSSjq79 zyd>)>;tgg<(3*BK8m6HcAG+_>6GswUeEQ?n^01jfGTxBcI{Gt zk%M}oFi=SA#a~jFCCf>+xlgAoKx*D#LM__^NJFf!VBzKWT4#^nfC5Vm|P&|9Lp?zpL#*ZRe zyMFM|mvP&;_h^HsH$hHzTE^*In1i9acSFCP*%;WnEBf?|pmNztT>a2=^BovYN{w;S zrMQt}y-l05ud@u%S|3L2-wlWF(G^d;JPlVYmcm-+*qIMx3DOi#`vuqzRWD!hdUn*HmUw&5|)wMYQ(sU0tD6wSIn1=8~ z!`0tn34X-&KvhR=koHqAa?Ds|>gJxcdIrZlqaoSjG-q7M$SBZrSsFaRNy%S(5fKvda(I>?9 zg2LMO%3Jl)VU_?*>*OcnK8mkSKWj^MYHwwc__ahoCE6O~W-(qzu~#bk?@vHOTSxJlv=-IV z`|`;rpN!jXyRD)B?+Bgs?bz`^0OW6e^Ba?HdVV{S{>~kj<14wagy{IFGKxKlw*(Ri zh9n6pgpK$lU#E2{jslb>Wf;SO7H3;{b61jFVZC}6pnyh^s%i>o^o8Qs1Q?Ti9zl>M zM72~jfz8C&Q<<)G$CYsY@CCb=1G%E2Fo8oFL=jgM$IgNMdx7$;EDp;>(bY9&tEg_E z0E0U9BA_8oKmi`)GGlqF>Jo?&K+K{Zyik5Nc40bMw5FXT7n;8|i9=635-(C*x~jaw z96s7MR~kWbcI9(^?Ljf-Y?KqwDnQrV0FF3#0N$83AGL`hes2N1^7`il$QYlx2Lse& zIe1uq3?ZPDqRzcz_YUFVcdFnchu73eGchBplw61cVI@+Uz;{m?K~BSL&c`_j1vz%o z;K+mH-lwJT-Xtw8SI1J=l@^-+^nc$*HyW0qpfCY0eeFTaol0&zec2LS7gsq!PKmd3 zFy_2YAdR4Ib})jvU=0pB_COr*`iIn0NuxX2G~N;~z#ndZ8YMFc_sVQI+c%I)Q24tC zp+^o4l~4~SCDd60a%OhQMZcmTW-ldIUXqM4fnt==68Y}^i_j@IpWvOiNu$J?B(AJB zE<-g9uY_3V!n_oEAQ7T&GD=$`$Lpq@7D{~V$tdv?B1=ARg597{>8D5 zni#RRrWR9Xt|AR6CNB0!a&7kL)E(WsWYG$Bl-l2sy=$eVjA>R5u{Y+bMCGQUqM0^-0a8{Qd|cuqxyfBxo%V{D_l=;8&-OVEJQM z#Xj`fI}1=v@YzQ$!m$s$g8dI1ii?gLLLk1HqT>?NCjid+O8Q&hus3(}zNuxEzHx>n zu}$CdU_$mejSne_QuDvwvz-J+68$x07JenMZS_$DMzU)bz$sc^!x~o(;!jrVl*kQ z$#u}6J@CUH{*cxzzsJqS9@O#lfDN+2RXWPF*=#9iH$yFzUt7p$!h{KU>#euU=3F3{ zxK7fYHiWm{daGH?eCIpg;XsM13UgbMwtNZ?LgXkK0oB5>XW3vH$-28z3Un z`KI@a^!rTYGkf-ITzv7xMvq(L^dy4#kAM6F!-fsp;FUzJ1O^M}uM++ArW7%m9s`IPq6 zp;pC(p8lbL0>hF`DJ95$qkW5mfdBmt;=+pg6%qGwi zAZ?-&$)#mr%32dRDZwEGdpeP`F2?wW9d`uAz5Oz+36nO|&00$f(tbaUa!^#c-{Af@ zV9%a3^uohHifu;;;H|EhjpDVGj?=*-%OXy>?3`Tm={*R$WU~$-mMJfQwPguB^vK(k zG9d65s_{6?2u=#1G8}G<8X$0$qKIq`4U^R772x#Kzkv^Lc!pe|g^UxxoT;-3d4jv;+}h-#C~^Qh8_hu1RhmM!rs|Y+d+L(uh~pV5#I%PpXimZhJ3;zJyF*G1T!Ix_3n zkpsRO1Za``r`JA$C*PirtlR?RkfvS8b^73)V=$r<`(beoR+JM1;QZ*LG(d`?|2d(q z)Mq&y1G=((X$&YUHw&vv*WkaCp7q8=0;>W&Aq(IHc*S|Dv0dMm;YCzhsz1kh0e(jx zODp3&^VzRb_|e(lz@oX2VDi@jSgY9W{J7?thcWWi>v3SOLJ(V}W19SVj_DYe_AS@@ zWa^?EQdAx(3H=jKI2=z*cnVRDC%(`+H4d)1{$J?w=PPmSK7AN6EG?G!^s}k>^&g)@ zX*s5tObdMG)T)FTN@WQUxh5it=KoN>xF64@Dq#DB#jY#-hdg-OEn6G~ItL}NgqdoT6!>JFgwboirJ#w)5 z27reY(p6VoWuO22=S#tsE@_myt$+E;UmW;|#1bsZzrC3q63KiLITk7 zzyl9-YMOw72OV^fv%z=kt+zTan1G7V`tp~*?An0z)s=>Q**!rXrQ?H$;8#T8fBTW`JPXj8|?AxQ_zqLY=( z0pI^AhIg>oHF1Dih4+e8jWp0f3NM_eyZ1Xxw-`;I*QfK>#nP_oaY(5mwas|NxCF2G zdEN~*{xAh~iwgk}8I8FWk}i3DL90FTw%Vn|uUkY9wMGrW`ho*F;T}B=B)^b^{NPhb zI!&w=u%iZPo>~rpjrA?J+|q8l?Kao%OHn7@9n3u7^*#b1OTp1R4M~^<>wQVq>3dNj zAn0#@y2nP{dW$w2Bp{)2%LRXQYgGXylCBbJC_8vfw%435+ATjl(vnM4cG#CTv#0<2 z0c(f0%6Nmkj6E!VNbcb#F^-u<4LfW&yk5_{}{XYBJ|`M^#+X*b(=ohkPIyC2z4 ze*Qaq=J}80EqRo+ERiIjq|v^z!)I*`IWhq#mEfVI)W%4<5?hqPcQHH`)2|W&5tCA< zO$vYlsLIx+Z0huhw$(S|)Eawzp2|`ME2F7bsU|z? zD@WRD@@^b&RasgO_dEn&mzX5~oTR6K&wC|py7Am|>^tAu)3%?zmc8@-TlPOcxy7D% zMv{sRV+D>2bZu|52{T69A^UG;)u|Tov|i3!Gzem|G2dl<9Vo$ld-ZJfP{8G!u%8SQ z+Un9oJm!GS?Sktcmr!E80O_Q?_|m8L`NRLmPWr~)w$o?Uv&Ek*vP*w?v;FOnS0w#7 zQqqu%C3PFOodkZ)oF$LwLi=I>k`wj5e9$CEG4HD$BjteRJv;NlYwhG?_OR9E%;m|u zpRvoYzs=r!OYcr~y`0$y^u*SwBp_R`Ng$9MRqTu;4S`96hKM#`za%`XWgm3H>Z@T! zQc{Ks?bL7XZ^xhWNBdO$A|~*B@kfj8xNlu)_x$d=Hjd2%0hQ1Ibme~mTXe6q0ngbn z0r+XDy>GJ7G&^kf>2~cs?+82=U*oOz-m9P3ZeRMYZS$FFHgj^Fz5m7n`{&cIO2QLU z00QVG6*^o)*#VGQq1x>d>0K6l4A@^^AJ|ZE@5^v~B15WOeqyJ$SPv!bROHi|2(4=; zo%n6rZ~y(|b#+RpMV*U{=bwKz6dw$>*!`L@V@4=`<)5yK3r2W+)KNz{@a_+P_=A&( zL)DhR;t)p&s5l~7=lO%$E~?uEALlLx`44qj8TAR%44;>xxd4KIz+eCR*E_&=>`Weg z^wD#uj`^ow)OImeyz2lehl4?Wc0dFLH__~C~g zFxhc4I*B;25;;)#-W9v{asJp{b$l8xh3Bt(lBc^g-0KOg7101EKqwNd^IIyDO7>E6NLfcfSv;qG5k2o3T$c8 zH!URzs$`ih7T8DxfGkDu?-ml`Y+fF6$RVX58_^I4T(^-OH+q#&4yUG>c2afNC8nSG z;MYL<1_=1Z4@X9J22pKIS%W17tl{-`>+LtOa~CYO?_cqRz`$xrH6eZ0V%OXt(D8=* z1+s{a%B!fHC>jDQ1g1@%Ho-3W;bAs5yTGd3COAp7rSd*~sDPV~8vkUsJ@Tn#Y9~ox zaIwIsckIMdZxFar=X{OCDw_npjFu3gfVS38Y_BhV#!lEEtaXG;lL+Lgt(1DU z)QUB16%D~S4#>z@E}Q+@K&ox1w_SIbYJa->WowkwVlKW!8!hcp!(L>wXK!sYC)Nq{ zlA{!XM&m|~wr#eaVNd?<6@gfa%d|_vPIduD)!7c4O|=oSGgw(EZ_|KZ0$>w~$y$qi z&K^7KPVo{)AUHj@cex^DCO6jMKo|@6s@=Fu9k0j~L#!n`@#NKA(NNgk~ zCE3|7z_7Zl*6O6reD?SEu`@2b#a?XjqopjW98k{GR2yVqG~y1o9&JND80AKPi)`)%;N z0Li6x9Iw}yrheH{MedYnsfH({azR&LY3y@Ri zO^9Yr{URwRKKt*xt-U=zX1~4bS^4NurrM>}D9QeF1nyblcPdagjllR=LUxy)(0Ty~pk_w;a{Q2(|cw>c@tVGC$#PsRYUEYEE z<0o+gRbIK2gQrozN7RANJ@;I9j@`psZn?!(@zhgK?Xam1K1{O3O#9&fQ_R2ZIp z_E~425LF;-uc2#n;x+iZntyShe756R3IUwqN+>SGrS`-AN4`|!|14;fAyu(d|G z@4ovw)RK4JdFKvr&ZjRt(#8iLe9+#0`)%h*7M1_qci(+Em1o~CIQsKKT7A97?xwfB z8K%Ae{`)%s61wlc`>wM;$vKjags*(%D^3mC=i$8q!~}qR>Zzw(o+(oT!2kU7&v$uz zS}yR!iG(rF2>SjWpeMWs7&z&qlRDzbgN-(%UUABUg9r3tdfs5^^xmqy_f9&o#JrbP6 zslJIw0yWAhLYtgv)ktzjUD2&^gH(h2cau#vaVCcN-j*uxUh(}$Q-Zly6iUDWIcY%x zE1T02S<+)!InPMQDN0I`kWTfp=;}Xbm6BAHLatOjWjRuyNm8IpU9CD`^Elga&#mop zc^0^b1DEE_oXsIF}@mt_^AEi@AIVMDgZF8dSNF{fK^W5Uq-)#+Av{k+P-|?E_U!?(>bw3_UL03|P2?2(iZ@Q6fH1h%b$175Smc7K7JYZ*H zb++p+Gp#|uVNw!v8F}Q!?&X$SZ)&6d_-|VzKu>N;RK*rsbFB?+{k6whLsFi8D+Syk ziI`NKYXRZ;qV-DHFcHeqKtI@sq2-U`E3icec$g!~IztonIVBCI($#(Q^ zv+Rmn9<5`)IR%}>2|^#t!1X=tf6X*yp2mDQh;4jxLpNc zA@oF7k2H(_(h(?JwB81z6@(Kb2IdBO(yp z(yYU(ZInEk@4Lt5_WusvN)Be^alAsR`{G}7zUH5y^Sdp8Gp2qxx_+cJuhu4s z-aT!`+E3dp|9Hk0ek}6@a;C)dsnmNurlHApQ(xV0zt7m!zxcJlbv6N9DV=}v#dbyv z%`kNSk z9Zm%RNTRUvIRLMbNC9ZXo+98PQgjTo>#n=5lX?r+f(b4L)LB%90Z63hus3+)jW>pq zyK|%}QQ^h$!-@j*v116(84jrJoqhJ%cKG3kyXea=zuY-)@oBJw=xrgg+ljPZSK%m0 z_W@WIhD$EF#2Il%t$Q#-yFBdq;O(HYPysL`Y`yi?{&vR^Cp10)%z6OQ#}yuVUIe5m zeSr4_)FT@j8hmuekum@veLXsEL?;mkA`Yyw9Prnfk(Ejq<}PvqA0K$B$zJp750ZOAs%9)L9A|?b91_M+lsRFB%H%2xM#|k9I8BRhVuOJcG>!ZC%$sWdJ!(n`Glr@gi_%BuSV-DZV z4%qjz0{a{74S8+;;NvCYfmGUsN3Jn-ta!eCAE$m$FPn}RZ}?T4|ItEw{-t;9{STYPw~Wo0KE>9O zhw@32>TQDZjv6~&^Lt6*D<7uNmdNY*Ub2C?)|Rui?p~ri2`3S{{=}rS_lUP{r%sRE zMV%((%%(~bo8vGSAP{$Nf!Eu~^Y=$;>%8|D*jw*?Y%SP^)N`LOuHM$1wVG@&s?DS2 zd`9Z#BPID-T`#qBF|i>h(7tV)?Y8HZw((|b+q}0wuz$ZX-xf5r3eZm4Iy2X>b@fcg z$stWlAnk-bwzLgDBfV=$q1H+uY1~*j`w?iJ$yHgazO~zZemA>mo%PfX*`L&NVx6@9 z)H*p)%IF!(^S7js$BdC3%hUw>=J9*me)AV-^8i}4HfHP?c~O^yur>_a^g4f8Ao1qg zZQ@LkvCbSjX0)v{LAG1ff8aUa`>nRy$gaP*!5W*Ex-b985hHEwbtdUk6G&0=-d56ga8&?(r2xuNWAzNBx?Y*kTC8G};y=(nMXhW|F11?4)zqnd>bsaZ5d5z+ z>a0UF3{e1bh;n-vReO!8YuLT_-D6v9u|=<2g(u&_z~W`~)mL{$x(n~E%xk}BTA5{( zD{XB3p;nFb;>jnU+_8W>_uO-xG+bA_3CCY{*<}uV#BL`v=nwPe&9e(HywK4FJS^te zB+L`MJ0r;l*oIRXfIy^Sk^Dpb7?ofq?MU!(5Br4Jsl@v%YQ^4z>JB^X(9wo4ea->i z03YdNICFs(ao1dPjguh61|q;JM&b)YxV?q#c_+RATsfo12nZC|D)5F-t@6fFw{gro!!EU0UclNy2Gq!%{p`pU%BCR(*5 zLtErAoAI$h{2x7{&henLZb851nlc+2)P8}4HS&NyqJE(OyrrtwBmrRoIH%IpYmxXD zz$O59q=2;%^7;+fn^Zr8PMtvI3LB?Bfuv)tO_Ue!&&*y=;2sWg)ZYa_SMyBOmnjP& zjLB14WX??zzj~&lMvbvvXP{r4)=Nu1V zS0BEQ;aRJnK&wIK14hX~k^~~vzG``=pQPtrZEdofNuPz*NP+#lzksyl88?2cXvR7O zrt0-xEYqxIJn;43fbS-psL;`iuLlAwh_3KgpV-|l$8PXC{~ZSqt$ z1*9RW{yMHi#`|MCV2AmmcwT|jL=o}cU4+WDcLdRg=!&(&sAjt}l#Go;dfx55C;oNi2b-7Y7`s%9<57B^({BWcK0J-O$d%B+|>g(pO{gDYE>gA|FdHURA;fzBTK74qS z(+Quun=9cD(uH^3b(f=zokr?Qxv0qdz$B?yU65vFBDiqj!lL(me(zj}_Iq29 z-17h=bc)fZTtWmuIyOXqA`V0x5C>;9H-x+r#rRmJ;|FmugrlrbV?D|4I^tLEr%WjedtSnolJqqot?Gu`2>K z`V%~qPKaS(D@ff~G&2WbeuVADQU*XxHdnEw9);d>z&{@k_5dI`31{^uf*;pbG^X*4 z0VDvQ0^l)N(|9nEc^31{);6h`N;)bd$y`)r0a+?#|E;E~&ME~oCZ!4+UJp?&KWHZ8 zpaPH%X|r|#C;)2wq))1v0*FY8O@LmtoVnnL1>li-t*Gvhrl%;EbRs)B+wq}&yPI5J{-B`K1X=pBCsuuEkQ}3!oj!zoP>ZQ2kNN|fMK2w zKcAnzPktZ#Hwe1Wq+IGm9^z<^&qKX^dY_*ov|X7>Pg?S~>)ExZ+XWEHNsRgj4tpv! z_B&py-K6*J^KA^%EIfyX?>F=h^0sSzO#cyF=L%nt_RbhM?C!S&nsLf@^UW@Ag2C^XY-cUX7Nq^Odmfa{M6Y5K1xoM z^66{UfQSIDPzt{NltX)<1#sKaE*f&kgLwl0;DmruBw?%cTmgS+AAQAbB<0&pJ!uE^ zg!imR{4@7_rX23WN6PZxFF1uyOB(L^BhQ|6@Wi*5vWVvz+VpY81L{N^d5MRP=bMiQ zRIk>(w9GJ|9g&bWM3vsVN~!ld!>sBn3E9?s{-x*b`L`!ax>P`?27q{#q#j34wQn4{ zwR>0Mk~&>1d$Ctt{TtbTY>@>B3B}07fDEZ>t-7|=N>WtX=5Sa)-u9szA^>veKD$A$ zIWHc;AA3?E22a#Eiv=8B40K??T9pGTK@7U=tP!yBSd1s(IDd}nHj`*}G?7H~@z6mE zhK~k=`>U_MYBOfcAi8My*T4Sd;xVGm;2);5^Ugav01_JEcu$D9V)6cd_=qDNLO4A; zhO~K}q&Bgkr?JXoV< zPr%_#_&NJB`a?fl)~a^yCn90qhtF3venjmZ+8kg!@ncF@%8`X6n?HN(v4`!rqwF$i z!;r~%IQV?Th0nujhTOR%TY`zc<~y4Fr)B49snpY!>f7_!>x-;8U8}{D7Dy;0EL2a5)s&56hoUx6~d@c%o;{eYG zkb!w9<6VEA4f6s&H=s70d+>sB724S}5_B^0pkD-1XS^? z=?@eK+exS1eigD&>NKsgobkDRxrk^C;sLH!M&i1J!gHhMUhHvF;wSK*#f~@LBjYJ{^6CILgJgqf4QW{!jkbuD?cMTex z;1=8^xVyW%yF+kqf+ca zp6swj4$JJ{_us?qDqoi}DNZ)vG#5WVQ$v%6o)!?Me;Rp&J0=@~j(1bW(?Z+20|&+= zdO>{W`7Xv*JoS`&RoS49#Bqv){n06*3~M^Jj{Xs5{#JZ_wMr|L;=$4oGf9(M*W-sE zeN!;(uNX%nfGbE4$maefNt#`KO`^8bint;1hit{&le064 zCwE^l=ugk-u%NfyXuhdUN6D`tZl?{ur6ii* zHR4ZohJiWxdA2s)sGfdutvHIc6H#jmKCpM!gi`MbPG0iVry}7{y3g1o(5mUop}u>b zWB>53TiD%u5I$GfqX$J2<3Eoe%GACP2mW&)w{Rg{X zKFG}a;52qJom4hNvsqsc6Mk%k(wT;l*f*Ra|!0H27|QK|YA^+9ZZ3B0oKm+MnUf z_D-f!tkvRcW4KejB4(QpS-5Z5$GnLgx^G0Y4CQc6=YIdZ)i%L|)%^=i=kaaG2{Wh^ z_ObhfSWS|4S#wKYFQd#3j;h$FrlM3%n zEz)N9xFl?nwkTXJx(2l7g<^$@x(3DH>r2^K4d6W~p6_!R)!)OPTR&a4ckm{!b?t9v zJ60H}3){m?$_9YPlx1g^b(uvTETCCJzhRO6&NE)+&8xD zs{#_39q7`Av49}tjim$W_T(Jjuk9u&IhU6}ZuFRhZ6^!+GpO8i3yFITeY6=#Bp8S8 zi;vwGUV$vrfG{Yf{uNmvbcCFddBjb^O-HU}^h+{WvU4I1(ucW7p|E3y`~{cK_45jRtB@?w>G-J4 znLk~FcAOV>4@5*digt@-w#+IsxPcpoAy${<{vX#vce+vpNgK&?)DIp_hg99Zij-Zz zyPWW-r*tupROj)}oc2dp87wrxMDpvFr5v}gYWS)uM;h-Ysz>Fz;e;0m7>p__y zjCCRp1?+v^cF-Pv3{Pld_-}K&RwP1zuAUuA>^WMd{M;V$xHsM9X1(A6(LlQ9G#<_# z&~%RN;53<>;%2*oEkn5Oszq1`20ukI6<&>!$2j}NP-i*E-;|>Qq*oxZ2wCawsT!%@ z9y(*~e5>oE!_VaUGkKg&A)nN%W*`PqpkAO&(*kRWj)Y6YS!aONbbkAolE7^cv-?kH znh|>f3rtD(qoS1L4#^jYw_$(Zsu$g_6T8ZM-<2yddF0qk#K;4A&FHq+Xfc^!5>iSu z|JZIbRd`7`*<^YLNeWu1A*i6&hTx&>ZgaQorkI#$Oay*}L-OrzX?}-Nq`JIbs@dWU zyW`Wtx$m!9Tl1eX!f+#R_EDz`PJe1Q744sWv@tv%!T%xEoJNav2Tklx6c`MM2l{u8 zUhehBS|#Clok0`fax|^D<3CD@eu4~*9ug4FWkcO8A@Sz(z}NTa_ajB$`ikoIaetZ_ zgS(BzH+u)>YaCK0xRkC6QZ6Z^?S~z@1HMVGmcZq`o}2qzGDRhyU=tRtjf{G zTzhIp8ka>5RoQHy(tE2dRP6hW%Ykjv2qvlaj@rK!+BR>4m#Bn?ml_wE=H2_J=x*t} zlawZSSASN1+|pvR3i$J_U|omY0P$f3(E-gyRz_C`7L=TvgV|)q-HYHi#EE>>-%A#@ zC4?1xuerprUlrk>VYm$SQZD&T+@HfCpw#$-s zG(j%iT+BABH;bRHRIG8qA4rZ-V;~yu=%(WcFC zE>}0vu~$7$s?OR^sv97_y1hI*{*r=#00D?X;2dl1`_T1sW5v@f6ZAHwknh(?N7?*-$TJQy0|R`hem@?Ph=(l zl|6{Gpu@Ih-PH~_n98SeVBiwwd@JfJ@KbB1r`Yg23JFqtke6aSgi`j~%65#U{&A5) zs^UO}?X^NIv4aa}C>_aAjZUE2JY|}7f)Br2d!E?miA%W3{bwLC^j+|_*gM$L!wu0w zl$pAh%8lj_CmCB`5{MT8yu3iT7*tghFyme`?Vf1r;rh7tX|e5v2lSqwV?^C9voSvM zQ&!gAs1gXXIOe6=(bOn?%|brU(B|p1+ZPA zdTz2VR=B#aPzUU`xKj;rH9YW4Bg8eieRMQaI2LFApO^uC{mk zkIlg~0}fKSFMnHln*Lc5PVwK!<@{PC%2vR|__yhB9mM4mzB`5l54(AZ=_5&h5NXY{ z7o=c^B8`(9ibIJ+hR!{1S~fVDsx#WX8DO*dBnUwY6-3ZEz5^v5o*6|C(GBsYQEB-7 zl#bCa!wXqSX`0cX=q#Kx*+up=j#PzwJ`o#5#Lx|sJ~8yv5@1Z5LV~=9;ybvraY1a& zavlh6@P)U_^b$}k;RhcKkAx@Av&jL8J&IYcJi#H;9hF+n1*Sm1cL5Lh!n_{2<%d8D z_FYOsL@7BFEfVRGPjD8_96r@wF6_HEqg!M=-t`j8Y7ySoE#z&ll?cDLG~#@;xRc1^ z=kZgGxhJH%%hG&>1sP|kE;Tm}B3F!}Dy(}fr``iV$z(wz`$8|<=tNFIDl^d*V*lQj zt*pxnxC_D_$gl-o6&<<7?%O1ZIEy^yXXgg>I0=X1p}Fm-Yot`xrMF{pif|IMr8V9Z z6DNq4SF$mY*8El}4{PJ_|3eH-9_Te7dd%{&Kn7s_6?N!UVS&qGE=s}MWXRW)@&5)HU_+K1kih*a@8V$YL+8w`W z6nZaK%_P7dpmtKz)1A;PY>Yg;xI%dAm&R0Z8Me27;d9TI@-~RA*vPT0H(zZ18MT$w z?OYEbJ(p9y6J6?;<3)AHx#Je4RRx6GBawoY2>1;sEN$LVgK`m7i-eN)&eiX>eH-n% zrhd>Ak%z6-@m`J79?YBc{g4P$gK%Hku(9%JE9Fllb z#1PVSq$}V9nY^4fpzrH5c$s&6e^ub=uz-L>QRL90klNEa~E!!Z>@!%Br~hdEMe&?GE;@v8-1uo(R+YPV---D<9vg~cx?CQs;rXH6eQN~du-gy|HTaPYNlRBT- z6PYRzd`H%FrqkJEDhL_SEoBA5VKxI~2ZJPB;ffYca8N2RL_?HR=^Fi>Yo(DpIRz>R zD1J4S&yO=6@HZWM#SUopJgK)}o^H;nsE2yMI8p!kpd7|sTkc58k88X!t+O95%ZNX7 zw_iT~T)IBQ~2=@%fs0J@YdP zFq-%HJ4CH2&G3o^Br^gdC>Tv{h%F@22y(R1vh-EDf;}ZSB&khpvG(IHM2brmLCtXX zQwpjL!daHOj3VTk^0_S_;UR^&oIohFN8`T)`L6C`f~7tgIM0d?p9_FK2tmh3`i1&s zZ2Kir0Vv`V43ePBMysLcK-_t4TLH+xLq|yZHs4V%#3bvtvLs?tO+-M8z|s6CT|WTc1EAJVjchI)5cx(FaB=x3(`m|~JW)`<74da1veo!D z9AWg@{{Xhv{c%5qkA~MB8J+XDy(r(?!!GLB!k0t@gw6YOxNa1{*mI1&3206;>Q}l&re;58)q@N!I(>K0(B+z#SPbMHQW3)?X9t> zqdsI>;FO1TT@&!|sda^FO^zojkm=V~=&5DW+=)UbFL6CHD$Eu&y3cz6-e2!7bsY$RvD?5XRp5>} zy48G}5Z1xyEG!@+B0ZXS6zGH?nP@c!+Rar){lQ|uazDWb@j1wtczR0s@Zit?#EW8@ z7O0Jri$#h9fQno(K0~M!?ZT~{D-l-D;0E;d^Gjiq;fIYgHj^Umj>KHpTPUS=YdzPA zhcL+aNR6|GOY}z$wIVH6!c$am+LwN!RrD!Ju7w0Ip2Fy z*l&A@C4FGeGodSwh#Q7RJ>oa zVSFNDLT3|~O0@+BJdkxyXAcA$Z5Fu^WHi31_QoX7vcWGzhx-uty}GrejXC%;9_ zy2)i*UuPsId zk(Oey3!Y2h(=buD7V~}ohc;YjgvbiCnEYfkL4=35pl)HJ5@L7yN+ZdDenQbVUI=RP zLJlNAHB<>ox8km4Ha1c}jQyPX%`69(ky+E#V;@9P8#AN72G#lyJpTyisQD;G(#)}> z&MVoNAtd#5d6UP-3y3qguIq5l#vv8fI!@pp^vGQ-+10A-DinvN(OY_dyLfL$L<`v; zXvQ08l<^RR0OOL3dZ8+Fp|}S9PG(8U<4+Qe8iEL3LYI;vEKK>q#11;_LJkZC9LcU(Z6d*uuZs=)Ha#Nk`{ZG@3R1s%pl-=!f_y- z_W$7bv%OztA3y>}B_@@#mDIwV8xT@{UV{gnc zS9=bF!9;+73=qD4QUHDzBJyi6NiU} zJ6dz;VAbZ5xHutC+hZjNLYmbSNbcunWEFunCk%g4; z-88YLe?JDH3QqI*sgcL#pGJ)Dx=7I8yg#kqPDV5(i)^*CJ?gP!B9IkB)o z&ifSKMI&T3SzOJyySc2k{<1`0dAM)P{f0&4GMI>u3u(luHpPM8*{ zW42t7_~v?_v@&VaH}ul7B1Vpw1|aF8cu*V9cFcAhoR6f0eec@UP4x6Y69epB^M@PD zj6%WF!Izt7dlY|B2WA^8TGs}U$RSj`l>YvAa{snu|9MQc+!(!)w)K!}Y#RI`(eRw3 zYixTJm;CV|?7*~_9-8K=TF#!6bY1(l1jy5SBfV$J)l6nY!uiMM^$MCER%dX(Ohk1~ z7~Kad1~LC=zJ!nPh&c6BasMR~N76Y}Af4aC5#h_x#3}mgm+yoAeSbg-oSq(`E=r?g zFSC!X=WRmv3W0H6uwI$$c0u~@kxn)@s3ls(+PQ_jZ(1t7rt}O=Hp7lJ0YrXpZ(Ua- zeRd{o$>_fM4uyI-Q#0k7_|UQX(8`aMMWM7IX%i1p_j zt=-)2V$Q{ZhY>J+Z;HR5Vo7}1H~;*4Y+v_YUMJ|i`koUQ9v6ZxISuothhO96aL!u|UJQ0kK1f5>&rhi-H7-6v4^(BUJ2!K=K!| zeLF29pK-D1aX}~vN>J1Bq6nE@1Fe)qFw+~=Xe>f=uq1+ zAAq<2N*rJ!cuqiV)+l#IBZ9n6uSRSkEoTF|(8G)|mgO%*E)eTA-Lu_yO+ByjD5>N1 zk&ILcs6t{o+VV!Cyj&p#4?c8$Xe}(?%RU4rE~IsPzq_Y@xj+?F%{p9V`MQu_KK$N5G-!yIjYq&Z9ZWSrmIl6Uyir7aOW%H_*6F=~Bp$-S zpk(}{PyhdwAVWi8Mo3lQ1+k=R=JzizWj8fao{qIR@TwY>i6v1s$TBdlpZrZ-_$%Tx z166ISrYFRWQ96DA3mS$K{8K4T`?o1cgc2iZYIkJqUz$h^4pUB3TiYsR z0ORF*y`4|#!5@N5oFc$W059niQ%(1{g5bWIZhPa9@rO23M-5GVOWfB>yyyOIJ`2e* z<@jkw(&8WZQCmkqG)q`^8ICpDdaMYe7xZo@(J;6`1NETZeEFZkz9<95&}IlARzqf< zFr!nx*d{aL#tVh;}Z3%uGeJQ6&wjqB=s?TR&+bd^OSjolmFj*BfkV5c)VW5~h?A)|fVN zil4+6%UDWZMcgd&zO1PatR6?EJrYz+7AG3D-~Osh3Ijjt$=eU^&b994dA7k)oRB%s zeTL*Rky^GQra2F%XROih)~4?3%)p&};f34^+)6$G)9wwU+;VgIaFrxF1dLTi6fZgE zZhhSf{B6>Z(i~K>n}U4u|1GQ#>Jq@g4=#VttZ^s85|egJ5=xnbUVasZ$*25=Akx~X zyok1?>5HrsDj_>7l4u+Zcc!##Kojpg<4Rt?AcR*mFKJ!IfZn$MF*Ohx4HC$DMF;2S z^?cTHwxs*L2_nv{%}gg+q}&0u07s!ckAwia!D`h9U609U4VwmkcYde*b_wQ;2avR^ z8QXT8k6)~%wzqOH7?52mU$negX9&}-rs`>tA&xcnj+vPkq*mF3Mr;|fjILt~5 z;U-ZD9{Q-Dd2CrLoc%h~Jv=U}HwI^g({+o)=g07KZASAy9yHr4H?YcNW&JIafV2Zj zNN9=6DXkwFA}kU=A%HnjcfxC!nQOm8a05oLVlUD>${>dsq@VwP6%z6-{R5l{U^m??5rlN9e z{I^6=?@;Dqu1i|wr-u*Bq3~4E)>vqU4EXF&_ez? zH?dx7LT%Pv|69rn(w?ciV%bvXJ$U}a)fkE%nF*Omo`g?_G#IfY!3zt6m1SbaAO6n^ zpj@KSiN-%3nw5^0X4F3g6tKWVg~0}~eKpe~v~2ubnns5!?F$;MJQn3Y`JNJDwMQW? z^Xg0zeUf}wrsYjtQL!j7Wohvd(w(QmU;?y_LnQX_W;(gsc&2?Wy6&?HbNLW9dkI$| zFf-fXDblj#3>~)mf0P^l*RNECaZAH%c)%{?3yS+5R|dtlkH& zXaU%5QuYkYMs(N!pFK9=c*{G?_rs`)P``lsG7DjL!NH|+8rC+kdnOg#$esrPk_H8F@0sKv+bG7!kBi z3c01oWTI=1;1@?fL;5nhr2QSUIu+-5=?&i~WiUUcj#WQpmB#TO2C$f=Ew;OkuDN=A zDl9uJKis3~Xm6t!JrrtEE=lKjIdO5b`FvwI60+Q)rGi46{X$Xxr^IaXWh6j64z^!K zeF{3`!1b)M+@QaKBPlfLkFnY>9@E@gf}{kPb?>QjAWgi>{H6`hlTQ-p4;*(tArI>R z&LxbSxs#_?grgu>s{$uCX41O31xLzJ+`2xK?L|w%*kRzA1x4xv`hzG4U>HCVg42?U zXwHoI!O}mfP|<_F5K1sL^m+|~nb<%Ogk(&ZPIYgo-&R)`>}Sb^sf zT&t8meFWUObGek~IJTSE4@;8wp43C*%u?la|ADPzi~K z-;D;Bat^@>mN&QWQ5#}>oGU`zP^4hVx-GI<`E$#*h>fVgfq0T^MF^taOH_23lzCz+ zaUE1g&%DXaXE>ebIg+l(P6Wotp7CumHZfZS?MPox2yqznPirMR1Cl?2rlv&gF<+y& zXM`XPzUlh|?!EyO!oQeq1kh7B1_=)Q4ny-wzc;ByY}a1PYvBZmVk^CUtm<_DS-`($ zAB7L?!C`&k75`z)(Oww+#?Ex-151d@Yp=4CYQOTZ5ZPZ{o~(TK8r zc5i2w+uP6A;|R7Y+PCl`O4L-2GX055G7w1!NnPm&ywoKs>5=HULCB(3Koutm+^I>@fcE{knv=1L?TiJP8hXTo8tWab*s2lf=Q56q3Vtf(r!l{& z({KK~ww5F*q*j;L_XSrib&~y*Pvay-ZB=Xf4&6VRSVc9uH&2Um1z3Ij?w z;*}r+j@#FRpWh(li0%+?!H|RcX`%Pdb;uatdRjN~H_afCWd~Ho;|D^DcfVB!=Kj9+ zxOkJX&nvZ*MouOmSawwA&;YqRp*ttgvfTO*CddmYrLH zTnSd+w->Vy4}D%EL~eRiK4xDZq=_X3k>qY4J{M0TL~cPzO?eCO#QdkAR-hrgXkp3` zH@Pq3^-ag%4?eTMwI173TUieJU;hC#;NX1s!Css+&djRJ^ezlO>Qd}Bsal1vn%?`> zTV?W)jqC}v=Gk5UYY5^KOf&-Nw==HB($mZe}#Z7 zUp%1RUpL=vo&Nlaa|%C>pO5|^0X)P;08CRngzoL2`#N`Lxt+)Sp2G&v7hHMFJ$QCp zp7JzLE1Zl4^{ZGXqXttDr+w0DK$KO*cqmE1H;jJ7pVErI#+&4gCf|hSmqEDU@VB-s zd^Nu2*WU-p9dgs^kU--=gIV0wO6~e2aNOej7N9V&?Gc4-$wu6@q_YK*L+vX&6V++t{URm{G!=!neu8r6Tf z1u&?^mI7?cLEXt!xe8jzl`^G%jDLv6Jl_S5?-&51u_Q2hXxES|2 z(x_1ckz$Oz)44rZiFPM|s(&c#+%@tk!}WUHLar>XSD+qQQ3z*GFL7bF{7U-5dxTaJ zxW>~ui-DH04Mr&N=fsPP8KR3AEtWk7UySfN_n);BKPi9|=dzfh87QVRNXDb#%GR{& zWEV;bCZlyhS?IXJt2Zt>Y=Y=DoLfof-(6_=$U{-a^5OOR*!m1?T@$w+6?hs(j@EG2 zyrvO(-hCD?f)#7d)K=Lf}a6ZKHaMG%c%KX6nUc8(#7LOOm9{zQeQSK!67psNW(I);~F znc}ezI^jNZC<7-G5U-3U2;5pVPGBHM9F;59+4YdXimkt2%C56Q{J^rTYO2kV%6qlW zb3ICaHcnU5$hF~KV0stGc2E#qG>;5gCa#vOt_-Pu)p-enf0r0SBb=eO))PA3bk%;L9ZKvU&V1NH zhrvEMQl&s%*7yV!QCG=1nOALVQS_ z<-h!4O#mQhqyP^jCuggzg+7l_s;Yv$qc1((MktCOU}%znmxcOk79_T4V4}t`bQ3_R zaF@8;WT+sN0k)op728=T8dmH%k5aoVdG;4U1}3hRVz~(kv+SS=l7A;B^Y7$n+IUPY z)klZ516@<=|8{I{SoOT!$#X(d-ud4Gz!r#E8$B6Y zK#G`>MiuRYg#)dlil(*6=hWJiO}qNG3oC~&Ft0iq+IlK+^kb}*utXTzOwN$MJ_Nj;nhVic3gq@!%#!`XgU%q^V~3mdLqZJ| z9LYh?QK+YNRIcBomktWCFn)^hF&rE$&ovD(b-O+7flWoY+OiTRjlBbfpt?pqqZXNT zo+BGv=+cBFAUSi~a-9fiM z7EoYh5lIcjZ$PD>b;2rO>T6;yj`465*d&#(@+~L(dpdD4Ah3WD3K)g)D}|Eu{0qvr zukF!bk0`KQplS)EnBu8Q=}4*Z^-x_<#>cU-1r8C|13PJW)`g`$*f)s4kY^7d`lY;( z3xUcHBCU4LB_Vo@#CRAp6j1rVZhCe!3Eu7Y*(id66&Ls+>~Q5fTJQGbmVvt*Cz23vf$-D{Pi@8Lt|HbF|c;A@_A*MoA(+rmgoO%40##WOLx=h}OsS=!bK zcJ!(BdO!P<=efu4VA+NcQ^FoS3IOs z8fiz&1(9V5Wfy1Ge3H)Z=YLs!0~{A_7KyJrteeJWN9T2^29OwcbV^HhFC`jeRyV{1 z=6IB5to>}8HiD2C!W`;zi+%toYSW9q?I>$R(?&FfANaeiiVB^3g_wMK&~A5ZzEvp|VXbddiUW_n@6VfS;ndj{4c{gmoxRfn zS58Y0)q`MeIeh*(ZkNatW0Qf=Dm_=_XG_qnK) zMXZ>_Oj#IYS{v;&;CG!5jXF~@mQGo2)fiIMXl09Mz7A&GzeX}sB^d5&^%Ig-vr953wvQr+j1%?ZYb;7x-Q$_wSH^y_GZdC)*= zMB+?J``><+oR@bF>m3uk+~OKkKx+?C$7h~=5meJO*#-WHadac^<=Uuz$=9cRgEbND z<-?4Cv}*AVe%U(3{#-)LC~H^O&I^gSv`9reeuUXbTH~OQaur=&@cG-Cx9c;JZ{2J` zTm=7WG|wMAX{l%j<30VwZHWD2v$4So=en~hwf-0>9*T{=@)ujLR(f=iYkw#;dzkt) zN;=y#%%*>pt$i1O%|pexPZSVtQHwp*hCqU^+P^EaT=fM{uS20VfbTVLKBrS(z2YN# zo-!@3{$d05)k2<=Q#mzHyP|3Yr^{E7i}Pe%Z%@tV>|$4BZOY_7sr!w+=`E$}=bpkh zqc%}RSoi`)egf;*hpCuSsk3}QdMN+3r+)Hli|yi`fMGEKBO2SxUFF6WfAIDtDWX)l zr&&{OVRn#vO`kH(UHX8fa2hs7*cgiiwd0wU)0L&r77d653XtS1g&Lu1MPlM|0e!M* zs9a4R>B!*f1ZY4zL>@n45y!cS=AyaJWF-jo@BzdFx+h{j6V!OXKY9=y;Z?BJzdml1 z1kip9DyDF8Yx1lDkHBW02>jtVAtQBem73fFfYn`a&LmM(C$}h|@ z_dHsXR%m5T245w9W%`Nr3QE9Tx3o0Fl@CLcX7M%*!>QF^JIWNiGXnUpVS)-7SG1fZ zqxyh>9_7P89=3vCiJj*2(KZCJN+yLM{y)Jh$_sr&j|5v?ycz1=g~xJPrA~n49S%Mk zNI=a4fDFz69*__I@{|Z=F;*iIW-Xx-U#6DPRHEZzbz zCnFhwjEK8D;#f3Rxod50D4}uKWxu9!fqQ%f!)h8yEL9b2`b{K;*j89jUf1 z*#pr%{VfrC)ea8`H@h$EXeVrhS<;yJ0ET1*S|?B`9@9FsTseJppMCq=^5b^{67ko~ zY}`(1>o{iD-&)V$ywJbf9mMqT=N zU=CF<@-rSLkjctGxkODWqO=>j2&bv=EE_jjCcj_#v(CYaUkLYy$B zjd#rn#wVrYRY#wh3XIDkX~Br>J*!In+mUIV>0-Oa;NvAa9tz2UjB}L;7yEA*Qjt*g6B?T+LBM>MWn@0Q_S9W@O1D zd+6P}+X#@fIR3eB&#!IG*1WQDJglJcHJ{|3zA;k4%%y+B=g;To!=wXP;#zjedgVxW z>F9P5k;2sZ=QlWslkT6-a#6>HRwl=7w z)BJ7Caf;^vZ!RLo>slI7_QRj!e+{wsRpi%32#d9;u#w#OKNWC`+z0|0wfMfCe081T zF<%qM)j#cJ8_o$O_Fe3Deh7{adMUQ;KGI3HRNY*DNCyQd3vIg~5sdI0Dxw?-&x)l6 zK~?GlbbiQYm~m{>t;Q)JDkTgS%m_+K2KGD;BZC|MHiPESGeW0)jG6H)`0YhQWMkAw zh17EAp@DIJgPdeX_~s8(&AJR5D}16E>l(V?}E z2)#jE6et!-nig?69xAj+i;DY5{2v{nN~~JO7a7!3>rm`*N#}&?XcN9S`(P2NPpaW8 z=R-vYd@Su|`S}aQHz~qtQgSiNX|7Cv-HTQ4N4^jy!qd1vD+1}=pSJTF{bR8%9Q%yD znrHCuFJG5|v7UMGjyP}%97EJ%DEuTVh$4+$`mRY3Y*59?JZ~EqO5B--j88U@9n|+6DGp9fa4_!Mih<|Rkl;R3@=?YJQ4RtrzG|Sfd!6&d zFr4MVl(%xWY){i^m5*K&9?RU4u5X|qOf34_>xJvFCG~v){KU7c_F)vhy{($t>op9o zj99(a)9VSy;0Cae#dh8BXn}m3VUoeMACcNBU{f!BJZyY4jw=W-njMRZ!_uh<5pt-T zPq$IGd8U7BS^s;;2Jo1d?`gKKrpZ!UUMQQlS=M)T08oIfZJ|jsiX{HtMvR%1ef^|JY)^5>B}J!Uo%g=+ zd*t+;@jV--%FoLiF&m+ewYk~#=VY2!0f$^_zPJD{Uq{cEd_NBVR%j;v zUf;BDA-7o?&M2ErU#6u}vgER!CG**yE7A}^;*0fzdP80yuZKyufCP6zKci!VoRr5V z^y^K-6a0QdJVhHnFLH$@P}Zo4*(dFQyuGt19GL30+00k(DKJ+X3$+0{MO|-G&}%mn z2dm<^UK4-UoSG}m=$EMCVT}s0fHBlWc%!_NP%-Vpf?U?ToF`!2rrAOhnH%VhGgzz; z^*-5i&MzE#$RSQgP&m?Rx|D0Zi$8av_h4yvioj7?PX@K;;;6c_(8MrCS*EN2Vw#+s z`{FYSddeTt>i}Sb!Zjw_*HUG+jWRuNNMLCozgJ8ts{I%B?d)##soyamjVuIf^>I`` zxn5Csjj^$(6nn5i_(!ST=4o9(7DhS(6R9RDoEfR zZVbN;nLo@>;^Gimp3F8V4JJ0r_FDrxrleyuZbqKJCM8nQHsA#X-n4hbtdB=X+IhgF zn;Z3oAaOSwUiWwFf{)j>_}_$_7cneJ>s4*@EK7(qBDw4FPsW70?RX+hGeil-gex?I z*%(u6!^da6ec?7NX8ymU2CRv!w`d?8875&KxrquBG`93L_nL8hz+6z10+w=Lv?J5u zUV?E#sJM2px@G?8j@&LOl`!zt@a2$4UH+jy$^)?~`v9rrHbHV?u^g>y4>gGQxH`+h z{IE+0d#>B}EvwOg)RmvEM|n|p&8{5M&Dz}Ep%TPA7C$%NWsdw@=C@|^m-n>m`iAZ; z83}+^mnzb&>aM!WzDc9wl-&rW+b-Im~ zlx9#$Wg5!Doz1>kOgh-C@Y<%o)JiwHFR$sd1Zmm!65bmi;yZO7>95z)q{hMOdaqk> zk>m-U#iJ=p){hwI+AuMdx5%tcTkT_(st(TU6w1J2NQ)=`kYXeg*HqOtVc`8k;lHx_ zuJM~UIf@?G@JT(NDM_%5t7SJg*Rk-)@B-YAEpMF}E}LId-oB)hV)1KMB!0`U!C=a5 z9a`5#^uwrt4-y9YAj@Lg!w*Gbh$B~rob?^eBQR2$KtNmjgn~xj%=3zx3TYK+LLF)4 z51pvTBXf}o-tVwSKgz?3{%D#nvzv3QUUiT3$!2G_-05?hoJ83!L5Iu8x@vmsuz=dy z_E-QVeg*}UL7^JozT6M3G$^^@`;%Bvv^t1+)D%z5k<}D9g;w~4$@ekx^(w~K+3Yr0 zB9VFr^v>Ojm))?d$lcex{*7?WC1$f3_kF8= z3tqvEPZ4_~gMeQ_8l*I1Uh-#R$10ozmgahVmfGHg%+%1A1StY?jabm>SXl7|gF(Z# zC013}@n?MxhrN=ENfkeLGGkEixTsmtEtlNBI}wNJ%cp;t2RrI$G%ag7uiL%P ztV1nGmxD6Tu!(hjdQCtXJWj=vsVoD^MJT>Ci3~>!RgR^i-%o%=G2G1j5Z}Iep6T@Gja8ZQ6amjJ|1JlcAH4_?t+`--A>{u-82-_E)q#>BMi317POo-1MSu5|`f zwi6Yabvk1!ZlJKE2)|LURmgg`6Gn>_P zcKj2Qc3Lh8bH%F=RVPU1n9|UBItP;mGqq4bfkDeYV}?V&gYRk0Nk{23$FX}~g9?c= zrdowHFCfd|sakat`+W=Rq6MsqdH4_xQiOTUP7f=gRjCP#&i~>fCP0b1tSVFJq$ukp zfy(Mml1r56pLkIJlD7xAH2o!4s(<~X+SQ0n<*~8Sy@KXj1}*+#|0B9LnHGx6Bnc(a zCFqqa;V2rSGAkb-=iJ2Jk^Pk0wH-nTmLRm<^9${^11FUWVrHpF!Z_TS_ZJ@@y!$+U z%3w2(X7g25t`n%(i3X>i8b)e?W5pu=+Vt8yW`VP*yhJtoN{ zJPO$RVhud?G7qSWt(%=J`J#33gw<;O9S6E*k*wO?!mv5eQB0oDjHSp8khP=K@r^ZU zE(8H&rLt9MN=Q^HMeLTt`teJQ^&f)`WUe~|&`-#U^bJ z$xv$sg^QATPQoG-AlQ5Oe{ipPzA-59zCnW*%)o)Sl~ZCF1@LnEGhXWD?NF{yFBHPs zyrPg11kUobm|3P!gt@`dwb?!uN-lf|llr$~7tMs3fR@9imanBz)o1~ycT43wUP;l< z#xBgYFHk9_ub98p5_UfkR7m%Cu+)U?9JwhBdP-z^)pI0THDB#=c$}N`dchHLYo94t zN4NdLtuv?aeob@xX0vdJsi8mb*3|J7;+etiz(F|c*Jwq3b}80meiuJ(qZ=uo(F}jH zt)$ibJ;;vUZJZsbK7>DSzE^~iEL$HCmivY_r9@P_%I@IzZs5d8ayLg{|)~%UwHznhlmh`(mtGr-X z!Ab$Sg45rYqr%pLoPrW7rpfvD#Sx;?*R3YrGeF0;v=V$4mAOs<%B}gbNcKX4BHHX` zOzaYA3h}#TGE7VPV{lv54qN5Jht$=ja?i!6g#b;sR=9GUH2t7Vc%0BhD}cBTGpfom z^O%HuHbX-C3hBovgCNjcVlX2hAK<}YPiIY7sWK<6&!5a#rYViYO`~hqL_WL{R%gxg zy$z#y%K!e@tikxc>f4?c0x#LTG%3-X41eZuF^;vuqLzC62}q~B(Pt14?n7^Qd=ds`1ow;++6?YUG?BIM!vM)?r_*!; zvaeU(hQ0q!f)?T*PpE4bz3=rI)jXo{@fEtA(z^sT)f9PICUjBVQXMJ^qrFIehnTzx<{Fb`eJC!y;4sXTtz?m~#0w-^8p-j(pqa$A&n~#D8Rjnh z2=&+*@?oEQOs;5qlw<$0AbaM{(kqMf44iwBme9FSit><}%*#QtxG_s z&9FiOT$XD8)w`TQphSeXdGY_Vvy{uA22neA&{3y!-!V>wDLr%u&=vA4(2ka&&>e91 zNKQx~g8EhvGr4y;ef7YaFC18+L;B_N;23Tls(iJ! zTrMGp6Du(bC6*gCcG}eV3rUrsUNa-iBUVO7BzGZFif!yWwGwTbhU8NN>1fJ1e~M&R zEJ2iV7Hr}EeE1qr$;q<~qrlWM^QB?T<|~qVyC`*oVul!Os{{#0k9+h2ce_+rY@+6D z<9!^La7QX3guMgWq!9xtwy|DsX^{0nktQ#w-t?@qH(P z?NnUwIhGt>7dq(R>hCv*$IM<|l%V-(e`A?th~R7??kWrq3Peji?{m#{-!vP&BL1!a z%!Xh{Mg-Of7-dYMIt9s-`*1aLjvGGCzZ(d#?S+pN>*uM|8K`<PG^VTnE8(+=zYg(EqIxC$jk4 z^6mf2V|F|mE^^+^qh(IrM-knzswTITQho@HFxW$lO+wy3= ztC~6#1CK!1=HRE6?bZiA*!Y{y>2qE^Pu-@h!c*xtPpP)5BdJdUhzgeRt?E+YL$K1b z_tD9)0;+Qwf43D$P8i)rxU;VQ@!{Z1F^mK%tnHn)4_$LI9DRnLf7ZDk3o*zeX+Zhug!uV%r|b6zG+Cc5 zXPi^o()3C41BF_jr6bc}TPYG9;&{%i0qh03ZoVe=5#@z1C8I}(fcZUl=((JEPhmyA zij)kjfz#Qf41k1n0bNRqrO+9FFQ_vrOkC9f;|_QNJf3E+A%n3W|oYWf$Xs z;`+a}TYB3pk6#Q8#M9}9x@(+#t1roGW5qir{c=*(aonzFRwwzAJ@#SA)b*OAV>da& zStyK8u{kY+_p?MRa^CrkTKEy^{OZ% zrIBr0@B60trc@i@TZH$0-3nNeI@7%Ev^HKg1--cB$v+gtj8p6L@Hu()hVP zBC^$?a-DWg=yjtyvj5OF^ZBE{_qE(OHA)#Z;;2-Y?+)A9gDd=4n8)1ti>k7m!TOKR zJJ&50iK=QH?JAlWDs8k%ep|H!SJ4O0v24TJoSBX1m~6e~%z;r&MeUNqM~7!EV)>#j z@eTP+XWy)^PS4W$UDmX+K3VJx7RlTJ8917Z!GZUvYr>T&jJd_}L zryD8zy)CZ8{kC8bMAa?v? z08pYIsFl1HSDdc`p#|3dht!OM;9O9v^L9)H9lQ2R>c$ z1A1C33!8;Pgd;@@CitDWG6b@(o-V%HqSO3kBB-g)}m}*$IvGl~*M2 zfedhqJ0&6xAm$|53C&QEGQ?O3kNTaT|AKW9xD9}hHFpXmlT4&269hM5@8vM&#m2VQ zOWEC_wVOjzA-U0na&MF6A(5B$OKOR%Od#8H@T?XV~`AibpQe6r-XwPGRsea>4(z|f0E8I67MFB!*KqhO|9p(;vBfEV1S+vgVZsg*?NblQh-o-@Q|8i#_M=uH0>%2kuG|O(z6v8(V>=7B1PfCv90`i?kjt zMaoVds>|JfuV4RqzadN?F-5*7Y&^8vq&S4rxfZ%geS<(V=vbx86_KjjbZzP%(%6mc z*EEIj!+ULjBoux)`dAqLP4sfZW$yw?cQK!yvDSiwmwX``Au*$r@hjb@;oJ&Wqc|^}lky zkam?Nh?ZF>uXy1O*3sePFQ9u^G9&hc2+xFnwszXacvBvVvp-Nw`SWU}r=a}A*4H8J zEMrKo4UjmJu?i< zJKJ!U8Y)F2!^k!8KvW)?%V%L_ArGdNvD4G>SHX=Jmn7JpPXPg)NOf#C`yE=79T#hk zT@RjH$SFsc;-a>IFeaT$6e_d55WHj&KzS?P zR%zP2MDch#MJUuz@(j1vMl7h01M8t@&3&IBz$jTR|6Bku0xH+QilHrt;k&qzW z#BEX+jrr-L6q&F((I-QOP!`HFDe4?$2}9aSY1aFK`--|b1vzcSvbl+}*lU${H?6)Y zWW*?Z)?L!5Jufgms+gekfL2L<585-CJ8OQzLiqrf(a2and_jwn35|X-*0iC)-+qi8 zPJs;*2v(E-1fM&S0TEq;RDfZ=S4CFAE$9h+o%Blm0%^Mc#*@iRMQ7(bu@VR<9kTfB zS@(X>Ia#P!5u-KwY0TsM?&US(Z0{#2#)(g+Cm1cO1ccz+!6%HzXAH0i)Ns`XvtWpGyx)x) zlu@Z?bmgfZ5eO16jI*wrSg=n0^L0;k_PmYA_zZ2Lk*!~wP|&B{!cd+6zi}=pxk(__ zT5ZbW=HuKC*G~Mb{jZWpu1VSW6FQW(6#TXgm#(Rh1(g~LG5^EiJG5Y;Y2JcJX{eGw zHo);m8akBIfSWxDf#3*xIB{3}nEU|e^m*BrSE25tWrXyfh&UwlS*?%sB#PJiG2FAP zs1+=+sk_NPlH%xCvA!P~pDKnfxXmx4mfGn0<{XB8?hmcBiISA)C@!0QqxqSQpiyS? ztQrp(W=G68#&fDQEW#D#u+W&~Q!sj}`9)zjLAkLdYCFZ$0C2+PWT8m6S6ycTtS-7Lj>$wUklcVNx(l6uar4Mh{|QbQ900 z^?;o)?;$X&-UAE+KMP?ubSIc2Hc}V$F%Jw&aR$WmvglHJTVBBY4{L;vf~FbHXr~UYg?dS1U^?(i&bCp zjq@=>lVUuTtONbTPgL&y-EGPJ9jVf;>`qUN;fNk0eh)CjF=17dd5K*0dKX=U zZuPD{EBzoew3s%zG#BMuev$00tJT4usrvrCq0#Pa@$7H;>#p>sm6VXQyrB0KC3+8S zza;e=ShB~F=fpp9oe#nl{*b%=czl1k@ZIVU3qxFi#1gvfUSB*&4ukL-v8B_kvjeAU z|01M#Z?fl#jCz2&{_=awrm6;MH161KY7@VZi2N;jQ#%Q{DAoQ6{`{%^`SR_^Wt-{U za6Uy1hOBvvI&JUhfWXX*h(AuWcy|{{=xo1wBRBPzkvPc$_zM+y>C2iqha}EMfohuf z$X?M(s3(el@NhtwX!FkUNdE?Dgw;PBvIT`jbNKg5ne-MIJ$4O^g#h`q%=^^|qL%Z6 zU8opZ^h$p3mIYE3M!@vrwzMr+qpNG-xZ+bpqp>*o&XHv9BGBMm5v%9edRvnWj^rP*}}e|CJJpOSzF2Rl1B%k$i#DBGu12hwME zuI_2Du^j^GD#ZvgR`v8I@_94>>USQ3V}NFCvA??pzCDZDQXrUnnVFd_F*LpQHE!5w zz04nV^00xcKYu@Uf{H@~`!a0}MzWz<(ursG}a4>wld@>);UU8N7g%l%0DevTVL z$|$i2Iq&4_iTGQ$W)<~U(te41yWMSYY`F2%0{>L7l#DyeSY;2eQ~T5qRNLyO6rCaP-&yjkkzYiIeB?9E2~mD>9jolZ+08cdHiGfh={im%vuZM< z=SE0fy#+gNpKwft1Ylq>U=4i!8kkAZ&Z~^7F2x6@D{<3cYM&*B-X=<3zkR_u-?}kdufa`?fkj0g1GqvQ?U|ZA8tF_0$T2ise(URm2K6oFW_tN^cO08mbA> zk4r%Um8xnq7+LDSKYMX4D8bJsevoq69R5tq97!hNq1wX*saw{SVRGWT!;#guEr5h8 z)Dz|sc!os_+O(}F<|OBx?`Axy90}*PBNcyAOteVn8*KIw#KDl%Om@@5jn3C zp)%-$JhU6}1d=MV#A1)o9;Qo~tK>bf(l<>|S|gTo;VE3D)DmbK(7jRol$(A;K-!xJ$M~17-DwI0AF@E{(8uBLC3DZde^%N+bUr%3r&@#n5 z8)GrR)YRVBFmS2f5vU@!pKHrRo)UUPib&4lR}yT@UZ(^NC6|LpFK@ zD+)r{uZ+hJwo1ugwhXp|7A`?d+CeB^S&gxUjgMcg7d#UYpY#@_ zfrKv?bF*?apLwIJ-ySwL_9xQEQe?D@q?0mT_xL&O2MO9vU&)sc#TP9@)%kimDqphP zjVSZcIR4boH(Wz7Y=5o0-tJFSs6WX5yZ;t+fHvGM=gCiMj~JH}IU_>v#CvpwMx!*a zkSUQE>ygv1cn4u)cFHh`gNwSnv2cObMGo2eF<=)A7MWuML{z22d}_3FrFI*k&PlT9 zg&asoWQc_+#X9v0{$JZ+^!^y&0!0u4l|Q9jjf)2Bb#G$m{~${BqelHgs2^p8fpy3CVCOpmqYe=^5#k)ZKPTbCsbY&74{HKF7raf+o)#N^ETLo3wod3dadvI+O*$V2la}jg z8>_PDy93aSLQT9LWYkN$pEa4(zbig7@>N87vDh2KKR#BAqHlQ@OLXlvY3x}CwKm;6 ze%ur4<1uS=SivM#8~{+#uU5yqDl}CO=GmB+3$U*eBRC$~0m?hSj>S(Z8h491o=M|XE5QK*2O+{UtnU2XdKJ8!QiT&he68)$LWN~p~1gC4Zc{Hf}ytB3> zot-}xYm|s|q$Fp^Qby&SvFw5_gPwRTSTpw@j>$V;aAv6-_y6Fmm+LcvmE^ zaaz&hxug}(x0xf{P0>a+kz<~*zIB<3j55p~+PrtP341{{pb>u~)K%KYvJ4Nf|FA(k127LjyyKB)2{ zZwQM##x?#HeO2OXOdGQ*5BXel5DtCJkizW=_qLeZDo2Ri+9r>GE}aq{LJa^O;+g#K z;{3Y*_%T#SsbfY<@SpJ|&F!-lvPXxXJwQ@eNv$^o$pO`$B;E+cJ4H zUu{qKq;pB-a&hv%1X`sOJvF$k86FYmIqA(^NC4ibD8m8qS;ELu$5~GN(o$#ierk=K zGUuv#0O#i!#8bGn?;GD0zq#zgZKw28pYp_3Xdu} z)Bwo6{D|?mPmwbp{@(!4fFQy01hM&Q6A>l``MfKPUV}u2KeqM3Qia8d~p-CV4^{R^Cx=l|!GV zxYSOYeHlwFK7&=7(M~~P${^`rB`R!g12;ayK`1wG4`oR=QMtmZxR&t?l>pj} zqEL$_k{EYLG(V|c?N0d;r|KNQ^#f_1gk^J1uwI!YfBaSZjWW9N9%(mLf#61VVj5`^ z$HJ}>i?AvUYWYZ~PcJl$4M+l)yR~*j&io>PPkbKt!!NW2F zWqMvgQB5O$dXOOp_duPl=WFLEnaBafRrWLbRIZZ|2%Y;K58Z1`g?Fj&c7T_{G0fW(kcHg)QM_$ z#%SDYyW0No{CaFM5S#mV1(pm<1O76#w5qF-M)f_O3xk7XjmDf|2m3(zf z1|?U&v4h{__nFUS3+H}hD$YohJ5R=}bG`rG|IJpNvIyoATacf6(!i!whcUdWMH`E$ zEdDjyG@4h)`*Q~7mPEm%;V%B=uk6yzq!w2wq-CopVq|v_76(Dox_us}sr^=W?sKECYcq0r;vi1Q*u8f9H63{ zwOt;ho>ar2i}U!bERpk;OB=_ss`>&vn-Pb z`W#{C0&5BA<~b1W$w^{y@xDH_u`0`j1i|olX}yTcTjWP@Dpq=Y-C^~&Z4e@r9p+qk zYjpd{T4q_`OM!Hki5qh)&vF8j-%{8D?07#?Xnba1D^xopF&@Mf-k;>tspp-numsh> z-cI!%^OPB^TAsGl^n#VDLmMa$I8=;Mu1=sDGe&YsDsAgwIizFl6IF(e;1T4)Woziw z44&NoDe35JIHUjF-5sPIB0!4eX%d`TeN-d73;VZHjX!W58C0&-gt6jUMF_e*|7m?o zv;yw*1X-)RfYzl9?{|O#BB-X6eAS><3EYExQu`rAjmf!(+dcWhrg3Q-3{L|VK;wF(|^b=Hzi$g9s zsP)778>CB!3Z>70F&*{~a#2E_cpjHb8nyjTS{nS2K48$n2TS-Sj?c3x1&NpV%q9#V z%F{ZJ{~BC&e~eGO5+TaEV$z%FlZoGul}O3yrLM<&UcGh(pZ{B9E>+rd)X1-RV2Y1> zVY2JgMfwX)^MJl^0r>p+fqS7V535U({yAlCAWW-9AA(nZZ{RelQI90Gl3@oI&#WxX zf5|X(pUj94E)WvR8<%}HFU`Ciqht8Y0LKdju&k(~W902aU4`^`L)BFEgYyDPcktqt z_nAo_igpmJTKpn_xvHLyy`C;7-c{f++sS$jq!X4%*r4r_WW5Zlz-Q-1==+tCD1Nsu zCmS8BP+q9?1Ns1QCF#Kq~F!6k!f3Tix7kkxo;E__4 zvmbxHWvuIXSelgM^Wwr^Xo@>6sZvUqn@o(skKChJBUI6L>us`nM-TNg-a z9mlhRs_iwPqh+c+Ydo_M3$emb3fR>#OZ0zhAh1Io9kaM-^p5jzY8HtcND)d8h(pWHV4)w;lIb3yxIm1VX-!KPAz`C zk-jW;7+o%E7N?_v*bV;jBc8Q}``GlgIyaJGZJMoTnVP*nS%m-o8V)E{%wy7he2G8% z)A9A@w&XgEXOE5dBH#q%qLjdb(ePSZuk*23S8it0xaRnwt&s_l+JtE~Ku*b4z$jLC%l1yJ`&_=h&(Ztt>}K@uxK9)i>!7g}7=zzV+)4e_vN`lFb6cZRAGT7$!~7B9 zc|pnjM*3$6YD2nB>qr#OF-=)%>9ZIfiQNUnAyQ|A3(-YdCU?21;jIEA6Ig|2+ud)L z87e!a6w{gn-ye-uAnB~kk!RxfOZbE2_cHC1>^gTzA(5btdpr|N!N=|>!L9F*wup!6 zU^~zGxW=wkovrA-wQ~AUiEq^cpZ?6eEURog(Gjio zW|f$HS2vR0r#?-XeK(eu%YY_Ds*_%F1@^-_gb#;Ea@7K3iU#-j?<)CUr+F8=!)@+& ztq)cf_`@}(48)|df1^w^4Z8IUeAJIR(C|*$Z0Rt`HAqKq^gLxs1H(*W&v+qO*qwE) zunj2}{63D9>O$+Sx|`Fcq6IBE>J(idu?ZYv`xUr?2@Fr%q~0uX0JU(tzR(Cij!0op zUh_$!*IbeA%DCwl)21htq~BmW2G1)!pq{@j`hc9Ep_|KjQKIXBvDqsDw&ZoyNt&R-a)XZh#AVk_)Y-d3S6*j z2$YV0u(=lc!#(rmyHj7L%TXi~Py!nx9X{I!;MoI&l$mIvh`o-~n{e*!n4PtjWz`{7 z@-0{LIoEU4DdcI;{4#9gE>2>ytS$&3{_#Glyoyg}X!T8!F?H&^`?BndX0sV-4G!3d6I$9VtMLKD}!$ ziu?HC{$G)Z<2S|}jg&QbsR=}b#zM!d&}GAHCJj?IqSB_e^DJ|-OxJ21mj$S#NO#W^ zKW2u~y73<2usY@?TLgnjnJ{Lb_-Twi=wHwm+m2N=(l+V(s%d6R6VA=b5?V{$7;O&^ zMN3KiZR!~}WWxf&)j1k8?Tm<=7*V8ongQm21ixXrJ#|F%b*A#vO`38Rf7F&+{S586 z{I}xrHem$1@&b=6-J%rE_GIvB9B3&iHFP{$)^$Ag!@G=L$k+O2d6Lu)P-I{2$uwEy z_kh|@vYEg~$$~Z$q&SP9Z|XQ_ql`I%+ni>SiEnQU$!C-B8+9ii7tHA#RU@kGigJIh z2E;@$=_S`1bmyE=&><@@@GypcEDa5R(33Bnk6b(qio_LxkB4QZcV~u1&rf0_R4`ty`(&(!`%pBILw0*BDkb^*WTqM;9seG2M z4`vk?WfU|%k;%LGpV^dGFF{S)KKO0>OP79~tWVTuR$6F+W3QUIPMf%~BAInP$|@QD zJ;ePg-?y?gNMi_Nz~g_0K(nQs4Yup&Z%4V)Eiosb|iGZcbx9+e7to^brTD3 zEM{#0&Qz!2p42py;#lV@w3;~Hc8OQ~FeJJskti;mhWdHUuIX2-yKc@#nhvyR(%{7s zPx8={dpz(2>Ziq!85(W4S&-&258)KZGSVAcvL~C?&^~WBB#js!JX{*KYzyiXyD z5BC?RlBP+q)~Zy~K=A!(z-3D5LcKWU(StTMRFQX#tOPzYMtOAHZr|-7#g~yZkftAfMM&8 ztk*ra=Xqu@vkVKJTpt!JIj>#UdlIIBA_K7!eJP~MA^U#FDjSA+v=L{zSQT6_(9+WQ z7UQsDkp6>?38pkbPpmsnLU-=n=_=D@P-P1J4f_Z{&)w}j@k9L}KdOgzVC4ui4UUF9 z&N|!swWQ+#fhvl-WuZyF^NhW`4&^)>g&7H)HrybDB!C4~w~;F-FYp4Vr5Vxwz$kc8^E~aOyWVWcu%nNVFG=*{Hr-HQyz9d}(J#KoPV8Eu7 z_dXcp)oJMFMiTSR+;eY|d3uTwc2^9w$!yZGeyVgS7Bib_eIf<_GOS;ekY(|p^04CU+ zH;2pEJtEfljrC>3;>!x zm4PEwdI-o9G4nf7o5@`-ZS$B{RJb^^Nj$9YCwTL49KID?nQ7aQITc?4$VdIv76rLS zM0$LCtDc{`VbGMpa5gOR^M6N448|~h3CB$+VMBqK4Tl0EXP=oa9N+AX2Lxo^_(j(Z zsyi5kjlaJuw}5AuYX=g2Gx2`8Z@8Hf+$e;U2LZ(2lAxYAMVzy|?=_MmuXPp+tk}ir zgd$(neQsyO@nNuZ7CjyhY`qY$uy$ASqXo8w4k*%lTk(H@<|g&DO+tu#e#@qFhLBrP z@qu2Ktr;oHeWH)rnsmY1nwyJ`vx$H)W5~Z$7et64-^Hzb` zq<{q^l|HRT3G7k5fWCs-+JQNO<3Z5Ur^9_AD`;q|MEBU6F!~yho!Oll)l#Iq*I=b@ zrD*T>d%ect$+sQ;g@=2#3UOhW--gpJ;L>pZ$L%83K4Wr0$7~yqD{Z5M>GJUbRLU_tTzZl)J+5m zdmf)wJex>e7H8wFZO8>)m^0-tdLD@%+Vw-MUFpjOg+#Kl6i3)Qhu>XJVBq}_C1jyi zRZ)xUy3|f%s&?&fGh*OYXap1iGLF{KK#jwBBdezV~-z!xw#ijPvn;xAXF$@ zRi~%t(8PcHpj1)IY^XSBsnqwY?K12IH24cxZ=9<@1pq^FM?cT#y1Zu93#&i_tU(dr zNUje3DtS#9TvSNhZROqNZpUSKxWf8^ffrLm{Pb719Zh4L=yzHDY-0hRKr+=e=9Ni- z1JkyXmVpQ(nzUwaa}$~K)(cLTD@k508=SLlL30XZ@C5(NkLgTPz+mENTGOZSp$mY&4HgHv18xzj2X6aejyKYqHbZtTG%g2$Izh zYpymAXzL{o*^nXj%9h%C8gx`vMK)Y!Dwox|aNxh;SWwk-vVC?KIb8Bs-2cFo=QDtS z>N41dCINoaZ3-p7uBhdO`le+gGBD4>vp1**c5SsVi#h3<|HhHO`&MGZ|RfEP#@$UP7f1~1aj=OAlyDpj% zKFkir3t`O8pr5w3z2Aj(@VX)trU5WXadnxiqXhTiUH&QdRXDngjskY1t_@XV;_G8y zkQ>=hPi=!oJmAy5(hq%&H(Tk5mH|F~t0n*%-V(1)JSziH4L!<3Js`ohsxCI@Y;6Q9 zpi}zWh#99n=l);jcI~;A1xqyFupT(C9k%q=>XFm|s$lcQ5#mLo z3voPmM%-kbK6rz+I>pa(CLg;-vs}zyxP9!_xk4(ywL;xRKfJNs6yeN`*ilQ}AZ&L9 zqrtlA)JmM7J~;8Q~gJTKWu2IEuKk> z)rO5rcd@{x&mDb032!ao!!7*%@!VfOUPD1c_D{3=K)^|UJPz;{P)mx>A};?OM0b)F zvIN3ax?K>xFY=AZuYt)TJrqy-Gw zeMprGEnTtx9{y?xHUBRmBnKkUH&i9V5b};Rne+u9r=B=39C@x>GVqkOB&o%iwX|q( z=J@8mU4scLnqx#Y=}1xon)~BjHfF1|9O=5*oL_o9y6-A_=Oy;y-SPdMzCSSedJf`n zG2iJMrVc9eM;zU7C%A8(Cst$qj93KHjndWr7(9vgX-*{UJOG3b`ok$zd-O%#?>|PL zw%9AlRNSx7I1WtU2f52)+oCmXXCl?}{v8_aZBWUJG+`ep4W zXkO}ancH{TG-Pcn3Ok^xoMkKeSU%o+LCpo*r?PK*T-GQW7u4syJEC5DuPf;qb%4c> zqF^=LDEoCx&L9gH#C z3u+I8LxF>h4pR+-)*El|OVJO6`q)eENodVknS?z~ox_v77Op3%rH8u?ltOwE_yDiO zuF=Nt50#J#REW3^l0l$oxxgcN`t2qVm91?RpG>_}yD68@h4SAszz<`Sww#(~%9H;x zrEiHnt)qP&1J8<2oNI{Uk|{q>nrj2%_d0`McN+tMuWoGee?GU=INK+d)$*`1ecWV! zGy|A_{zk5mW^CyqJz4gBj6*}DAn&?4u^P=xb-iPBr&!8~mzS8ofKUnF z;^N-2ImICku~$gzg`sWdUD8?SQ03~|dfK4%+jfAk&kYCB>#k%@1NK@i0|!?H1^*-K zsKkKph62Vk@+stLb3*SA!Hllz{?`qB!iwfW_#LvBUWtY%mX$C+XuKoGlEHyHMVoz0 zA+Y$H!h9f|R_vAc7j);Q=3zLe3tR7(y9V7icy*I#1J&i0qO+P={S(c?0Ya*Bnw{(U zM=+SH0)d%aWHV=SjmH3I6-6j=L?Vnwe>Qwapntb<1WKwZGTo3vWDa$QoLM&Y=L<%} zPbnP=5Cam$_JY<3&6 zo)ePwV8#Ha_aw%{Gl9_EO-nceQC&vye1OhEk^%`JThoo<#VHIDgaL#*AUsRVpCGi( zK-X%?dwuQw9q9d){?z13T|OMgxk*>2P2o%x907>v;qi>~BLwEu=5yopT&&v*f@eH> z5rZcsb^X#%q))GXJESHzLw{-F*;_^m@-O*}1@S@MR2(Gjxy(iNbqhi#!MmwNYTS&a z%)uGl7+cuDZyxbh&p9}Liol?2FgGwm!ZB*h)H9rEpH!Xs8{tD=FNW*u?-c0$-M*HA z1U&+}Y_7ZkDS)`k(y-@W*5@-n{$we3pwC_HTGKhIkQ%7N^Pz_E?L}RbxO=V=8g!7m zR&JZ@z@-bUSLrhyq^1MSAbO!+!%A4sw_d4qlFX(whL(T>H1^^&vRCLXCWhE??-@wS zW~u_4j!k&27sosjUGl2nG^c#tD#SOkR3}p^iVq_hryMCTYplXI%ZHgd+LL%#QguA%i|pOgRHw09!J3J|Mi2 ziJ4@W0^V3Vqri^UDo*E?9UiD8zbxfXX4=XURby;7d>S9@26dGf_(R&@oQr9O=kn(f zwvn*!(H=3tn;7T-e=FszDq(zHUTaJoxGR6vfv94y*r;JQUrk~K~am(eOBsKT!RaJt&@4tO=DCP9^ zj%TnmQ-?nF`=eV?MV=eWkVLLiSSf95YxZ<4sapH%_4gso$w8@N*Q$4yskH}ZuzF0~ z>lwfNtHATQgx`GJe|u~W1SjS3!ASfAtWP?r+?B3R-jGs9-^Y2@+bK<1VA`jp3OFGN z3n)0`JOqpgg9!xpB7j>d&iqQ)z;(FzC6dg~c;@=ndxplfZ><|u8y3WD*1oyS(I zo(rRM#8>OP${{>lUkB-AXd3M9IjbO96(S)V>e8UVBkzeC zOrVXkqShwwgC@-CK&k_K*OK?GbNOLGJ~$^yfl6VZ;$>Q%*E7kfO^vf5GkH!gOx)y4tF*p zb5cjDJWq+TyoYRz;g3OOxVs>ID_lS>eUwX`@Z)@{1dQXCI2^wQM1YICbG$Q?K0UKd z;#4WZJ$ZO8PU>QxMg~{af-1f3HeWzJ#E!!^2KR6bN;Ju=sHZn|Z$|qhcBOH^5+LF0%VSi-f&NHMSlm!L03++KL-$c2qDxll8Lr~OP`4c> zr~0RBlzFBIHtt}*UNhqGUxRaaMQ{$C@L)DlOrWF}PT^FXI1U$n(wN`hTUc+*O-~#F zJgsYU{5KeCEd7r4{qZ!b=+2t%NPGY00gvojD1kyo+>)1tenJxG z@*W8B7nWLK^mgZ#2!Q_6!Rm(ITf*tO_{2o#+EcIB&fkadoInRd4pr&PVA4z}n)p|3 zo!tv|;;yRCWQNc+;pa#HQw==$4omX8Jg~wkGbm_MdkB1PX0h+jWpFKG3C@vT5s?xO zvaVNoLETc18s1fuIYl~g)P-60lGagI$Q46XciYbiiJL{O*n1@7(27(26D-cg@HUWw zKskBAtsqPY6`aV?PpeS&YX|?0w^4_yu}CShD3t)DNK7XuZSv6NzjkbLhGAD@suG*j z=OZ1G+<%W(J8VVGjmDD}g3VFHs#Plxvx|l6hIiANT_4JQncmyzUJ^I;&)VVkDkH`B zqm4qCbHoUi+eP7q+=GR79SJ#U- zqkd7ar*O(2>8%%T|BJNVlAeD%p?TatQ(GFjKsb;G&nta;XM(kLBRnTYwy^q~cmaY8KU1sx=rdklvk z70`?s^7w4Q(lM0?u`r;Zk2qzHOWZ|G^_Ksl1B}xStg?Q~K_AqJ2<7ArR};>4h8rJ6 z9a?>|5M{!76!t;PBCXq|kr{l~0$Hrw|NcsOPdb$LhvaqDlX%5=JaQwG|4RN24hM#px_iKId2w%yp91P0Yq+0Mr%Ia}$F{U-P?_OTGdvLrxZe$0_3hHB zuxh7^P7kzlE7*tGuM$iYS5~Y#@9nRpfg4*}O>v*b7#)EVeLEW#b ztO3KNxQRDvWnw7*H{4ulyn#D$^dRF$RCuVW{^#-Dz7n3r-y+gPv4i|35+vE9|2C@9 z2}n+Y{>F;EQECB(w%ZNI#z-yMdK}2W!{V3Xslf=27K}BSjz^B@tqC&KlxBHa@K=~e z<9#L5UyemzOlk-WYm((e431|61I7SfexxYlBX^toWMSjrXeyTX8%FrkkYv1y1|wu8 zAd%O@Y;qy{Wr>MZUX+ybLDwtT(7ki-RDT5Bj$-?dbWxEQ)0a&n+Ed2_FL~m;49$;enejVWxl1qyp(6YmA}zN03A3Nu z=Nx|+36^|$5MvXPi_zx>=gx9zhy)E`wP7=Vxj8F;tu`@8A`AsKnl=DHrdo3L5&w^- zbMTIXi?;a8#BS0wR%5eqgQl_7*ftw$V%tu`rm=0?wr%^(_uhK{z^pZQ=H7eGJ$vup z;9`U}yDH`Fzry#yR!tfu_KWn7h2+kKByfsps_&Ns;$Qm}u3RHJPo?XWomz56du-57 zoc2;TmAb~QK4;T!$esvBkQ&)?3|BPfr#qvhOZ7Hbf@dA@jx+uMs5aF>o|Q=i{(hFpu}|qu;{+ znhz3>Y(2uz@Eds=IVT;c#UZ@%_8lV3$v>^^L90>KB{W@Yc`$3)s3Pz3n&|oPN+FSa z!;SZGvBbS=d-gJntg}@@)K#fBl+OE*EJ_S7Be5JgnlXWhgf8?2KAxDYr-UX@{C2lD zuyrXVJ{p+f!4u$D)}zM`uOFbaS6#QgFX_zs-LxG?UzK%q&YjuV^mb{f9(CUvpymDC z_T#@7EP8=Dw*Z+RO= zzi2$!2%sjRsja|GuirzY6}=r@Ne;9Ke1d8jt;g z2l^?BjqNhw^&s^m5H((#ln>ok(B*v!Q3p4nqpVtByz z?}EEd_~ES%o3u^&NGol6f}gyF7puomxuTfzy8@cujNGbhzCVVY6Mc$P;+sXow=-%a zU~n_E={0m5!ghy(RV6gsUI{ad{O|3mmnD|Gpl&MwHCc)@j*2l4!ep<9A(BE#Uy2dw z*g!yirDfnA>E*s)REUut%aV%9x*65^${1s_CG8tYq2`}9_ANe-%^@KVsL#9k2}b=s z0IZ2WFUXGG6pniG21dw&NRvr$kMSaI;286#bfC=l>)s#E5aym*W1#bnBO81S71_QC z)}A?O_(H=l9Qm7MmWXy(nHEm}Vq7LCiX z)E>213B0$i)Gf2sYhXjtjIMcqrkxG5Wxq7K_0MP43fmq>)nXL49i3Qc>UreD$R)1` ze$r<|>7T%ThI%7zYl>?ZE)W~WC$&@Q#MIo1TxMHMK=BElCAVmBzLABsibmLw55_#{ z4z0AXy}aWxsXz$BttDnBRuoc>8+cRd`sp(XwM>9y@ZJul$-m^kpA)fGu{xPdiS`H3 z`vad9-=u+2gw!S$O#QDCa2G}{0$k%JD*D^eCw>~QxmiAEKRLGV9ZNp}X3?3SjN9VQ zz53BTP-YX|JCp8Soz2}!S;pT+7S%Q5&<0hWCHZ-rCPKI~x8EZcR932=L-s(|@M97! zW-BRXJ&yq+<~7NOxH%qCIxey#G%}JDakqLob%}@nsgZ~pPP>RPiL-Wte%G;r4;g%RSKfhrM^ll_3 z08gOvwY;D9C`ET64gZ;RHfJKoKN}D$1h%&&UH2bfShY?zlZRV3$w2D7e#Iswu>Cc1 zR?{hVwNN_M0OI;cj!za;7#rB&B(YG!CBttf(x@2z@?U(a-bdz3%8YaEB;rr-UmXQo z)3;}>mznJHS~#M{?5c(mC>nOECWPT%qBqm~>8ysH#z-plVvHrbEq5t~-T_j@SR5Zy zXt6TlJRI)F9q(>MYYro0&TCE!D-}LoqQM^B3_3%Keh%Flscj#SD;|%$(qXo2OY9?t z$u|mP5D*R-jOY*aoMody*xC)@OWvIym9iM{V16!R9GF27=)FG|ojC0tUFxkaFvjTO zo8o4zriO(}6}(_vY2JrTs?CwnXn}?Ye#rIhSMFNMZHu1lw}jm#{irRiW;zbhu=3c^ z(tJdgaTt_jG51lUZ&LZW{S*9?DQ0Ep#Vf`z2kHzE**7H~uU^S=!(WX9&{e7qyC*G1 z{q#^n2Py}3z0>ve@Q5Lfw!+G z#-=Nos&B(KO|RrFd(~uT#K||?Z`rB@h96B^${vTrMd}T#$AX`s`%786mKA5usu|ZV zbqBctrKfL>GJ#_mD1Wi6>$KD|1@)5P%+lbl=z^N&=sjf_b*6;LrKMdErepEPeQ88* zf2I7!A<^_^+?2ED@O7-O`@?6jTSP(zHj%62GyqXP*_@cJQJ#GV)|p+{C$JyvAyJio)55l zl7PwSv;K)S5n_yVu*_C*r5Rzi``u%@Sq>NWSmwda`az>m@x6t~*C`S3P;uVZzn?J2 z2D_1}ZF@11(4okI@9J$@B|%PEGtl<9?W()5{d(htP^tg|5fkQiW{e`3snnB>XN-8B z;qVb=wOO`$vvE^r^4&~peH91>%|m7Y#0!3-wi}|3%EWEt7g5=4P70N{slpeKHbISP zx2N^lE&WS`i}rqNNIaEVC{`D*{C{uLkHMHNBWQTHK|H#U(+&WzHr6|!Ae+W5N&Kn!JH zQ*_@AuJP4A3-O={({&M!&zVI+Nmy~xqgp3~ca=WO46c~B+YoKW{oB=?LB7ARc z6QXJTGk$KKvqcrhW$I z0W7sN2mYbg!q-nJ5Shy_Mep%Y<0K&3HxOOv*Z`y$q&P|bfldhT(UR&;`<8q4FJVpe zzE1LWc~8%Tpg)2W+BG3D-B7z3Yq>M)X}&>~=pvBgFIwZFSA1kBiiaw4*Zk$|H2rM%jOO13)mMrgiH)rWx2rCWefq4CAq(6*Ir zgR${cf%hfu;I#LKsLm_8wV%k-D{c=I$NfF@aMO*Nw#hAUzQ9xtzfDQ^RV0>44?F3Y z!@~wDF3)OovS-kWSS_io1xwSLextfkWwier>oCpE`l9itQUSj@YA$%nv1}O~qltFj zxn^V{$;mH%Wyr_IiEr*8{`zG%)iw*C)=}yUi`h?dhINIfESn~!6`1UJTbq^#sHg^`wk67+5gIU*L7FvUxj(kCl84 zK{D)Sxt4eEI}%O5y+?i-VPFFE2kB8MGG6ex|E^Y8ajyBaKRqNq8FYJQ^9E%9JS%~` z%)E2q8$7T?7msbnL9chP6Ekd={rzdQ#Q9@~c(Jzc2mS}Y*X1oasNkThHUJIrMcFri z;L-P~np_BOC8o?ny@S6`MNJ-ZyVk@Lvgb}KGCMeRi0V16KSUp#UQBp~+yXA!xwur( zhd$o7BdjJ%I7%S9-!CGDeaYI?9Za_G`gsfQK%HQ;BiTh3j(Y+Mf^A$YUc z6fC{AGo}pH+1hr|UhNU{(;Z*M+Jx^d+ByeOmtKgy5Ui*X^!EDmaKXe2sJ2~EK6^^9 zB^WWt<8>_!PCh5?(=9k->Z|eI*A$go6fsx6rAKnlVW27KsS?+F7E#T*mwQ5K*0O}+ z8;AhmVwGCL7MrAshUy5*;pNsE1_52I&h^TG_aMVjOW0OqTPLr*h6ZV>Vg;L=q_p${ z>%Op?i!di^b zsq~kss-qVEm2P2abLoGsx(w*=l4F$Q$THu?KLmq$3Q|Z6mo8)VGF&A-7YYpWhM47f zjh-eQ{+SgDFiN%mE$!ZUM4+(r0C`1?5_rm9AOW(J7!hSac}xNcDt~|~Tf3Qe_PrmQ z&bY3>3lbYO}L+RVG@qOs=;-JftKt*8lklyEr6vZnLoV-b#UVrJACx z_X|lgm4LA_mKUu$Gx(tzhh!=ELaxqKH_K*Z`&ULhiaf9~(W>?{DzVK9D&=r_CpozM z6Tl!sd@?dc?xOmkUgi4qcL^y*y@3U^z6Ov+9Ybu)!=|pT4}KCI>bCSR@=}O*o7Hs0 z127|O2%AlFQO$ldM=B)C^D?T9WhLkcRHKMqU@v3tn`>}_HByBo*sS7=1;u>z-6ZSW z?iH;&CcIjS=8|O&ARYiunxatz;GiHyM{EM&pcGwuhHkdlRrotstMaGlBOTYJM5=jN z_cA{Btlh7odRa$n7efiXZbn9*7F=cP6KNkk`9-L%Bzc_c3A}BYsTl$SD;>Wj2W|e? zHz~MO5Z45{WxJaP{rF@wCB4_<1TbH!+#hvU#$5SI_M%CIp3-9g!7nH<07#yZ>NmcM zof{jj>*y)Lcl#kp9%otmw7j!;ob-j(Ukr9Vnj^04q8%*WOtc%`#W9`55O)lRk@D^} zzLhe!WWB-*{ha(F!Z~jnmQ$)mQwFwTRgI_$Pw$^q6N@3Zz@xX>yll6SECOJ&{~i3< z<>5Dk(fPe|iZVmqhiBq`^+M~V>+sC_#2ZFMcfl$;!fm2Z+FwCRVC1{1uOlqlv4zK3 zK*z`@%5e)S%DMAm0<+wsYyBl@86!yyBSAdK&R<@BIV!$B*XF@Bran69I%yB8rGd2?3r(SmmT1`hJm5(%OHjU%+3l6 zp>5UqPoAYzIBQ#{y6|FiB34X8RWB+%+$Z32pdQY{@$A?%Or*-1nr+dmkz6{*3%Z97 zUYBjS|r6lIz;_+g_^G^;A&aIxM~94VZVeC@^3 z1tl)u$db%!76X&Dom1B!itY_%_W7m^+w@QKeokl=-C$n)n?Y7m{84C;Ft8^8wk zRQ&)JB9jnAaDA^VXbRt~-0yw%9}=mM<~b>4JA2%Ts*ZP-XBfWVCnaKq6~tN@^(Y0W(wgtjqG>HV0+_q03X+-2)y zO5BqZwMndlB_F4cBQyj-uoz5qF!y^uh1a-dX+=nbsd&2WerZ@u*O5flzUHgp<#yv{i(D# z#B;yP%-cKCjQENHXlPjAVctnvR9IdDoLLY`0j_F%zF)b%sHs$wVg~82_5m3k0pW4r z;8>jZ?P`b9$sT9WqggdCk=M+zCN$~xKrD5Sp-!5SVU~Ni^dP+5XvnjbucCZh{$4-c z>7k)>6)|yr<`=!VQWACprDC)iyoz)CAZ>ApreSwA^e(cUHI{MV z42+GCZrhm+y+ZQ0_xH4&1f*xuO_|jEA%Q+ zqyGTlBvNWeC~shCp>_cr0=|Mu;Pyea%1D_QP)GL|H1Y`oI-8P!Cdr|ce=I?u?IWcnqs zV(8X6HVpQQW!(2SO82!;_c+ib_|@P0Wk3>Cc{24E>u=T)V|Fc1?=;LINGw;Tr#<(s z&wDOsM^vH93~s>*N{4c>=gxU;SFiAqT$e2^A0^pz$8l1i8L zZ;X5j+H-_s=Veqboh!lS$_BlHN7i0Ohw-sBPMWypKALv&lR5Z z;QtaNihWSv#B(pz)gO$no!#v5E^0?_SFp>bFDZ+&U>%IA8`YSUM8|M$noYD9)XOB3 zdc4-59p(yAVSgP00yneRG`^hwuhas#wd_91I!p+TH)>bxtisAtwe?c8B%UxPaEz}0 z=CH#swjT?3`41@UZF_?R2s{LQ6YbCS{CGpY;s<`|Gj|eDouXj1 zlnEbkD|a|rx-`Zk)puh^i~$5aXnEfS7hhUmzK#Wx+`=xzdPnK>1)o*vVU&&W#>-fV zw&nMLbkswu2gs9~>xF>soGm6wVuM4~q;RtwW-bct?I}<)c2v z-tUmrjRUKcrz;OjN1Z(cln{mi!r8Z|bf$w7{RJFneKxo-=K!>QI!ov&p^sG=swdDU<owYxld;j!U2~LpG^%NQE+oVFR%m%wl6vs(;F~;9!@uF5y>3a3Yu}`+_ z=AjLmhqwEedAOAuL!I_A+ge8|FU437m*tXMIAu@3>V|`2!pzl8g5UI*c|$920SDdS zV55t;PD_f&JSKcz1el4O)%heV%W_@c?~SNnQKS`N0^(?4#-t%T*@!hhK>3;rMES(m zvXmDcU4z{(SG7zjh>erE=%ADaU|d!ZtG%#V3=Kx9Bu3ZEx24hNmj8wcqeY`cJja5+ zSx>RNgeqXA>Io56P|#sP^@DKOnd;7=nis#mpusMP{0Z$Mj}O`@FOs#WA!R+_T$INt zRDIuq_Sg;$y@#fsUFMEgRX3wCf13;|XD@^!1rMysjt^(M|WZCql*I|9CwoBr8vrT^|Q2Jf|njF6A zcwP}sKC(jLpti=BgqdL%B^MtMGBPd;B*(bIcZ|u-oZN8UC|f1MV;fq}fKc5|aMGEL z2)XEUJ}23wv1rRD)W7*u)}1w6M9o(yjSg4Or2I78M+MX0*nJZNEXz7i9+=w-p;d3!1I1!`zVbkYe^~fL11eGnts3eU^7a-ahXnYF;E&196 z9ow`WVc-QbCVn~=^FHQS<_6x09-9FMT7e4kAU$b4_U9vBbww+&3xUCUd^HO+e)hh8 zxinjpvE5X_>6W^ZDEXzoC|ZNR7)rgpp^m*nEM-iDe6Wh(B__RDJOYo`=6`1(HPCl$ zo9Q^ou`6b|a{$^~d;p{NBz}q6Dm8i+bRSXGvL!B6c-$Mi6E4y4io> z6QU4iWP#W7>7uj#yX>FJ1SYHt3R_9aL zR^6=LY8JTW_230v#<2elL>w1yXal`gRrr@eC|EGfM=EMG+k3MmupC=XrbH%`Idybshf;x_8h}=W;$- zp5uS|&D!z>3~xhHvBhZC(fv{R2QpYBG7!je7^cx>j#lNi?Rew(cD9B8Z}8$bKLY8j z%EH`IHMgTx_imGlwm%a$Y2*=*p~I8tMSezm;A)IvSXB<~e$=d*`R%Wsscmn}k0jlE z@%BiShTJ|2tcAtu<36?KIdv!Nys=bOTQ=-+@SngAA#n8RsSy5TL8tpIZCx0|<_`Ud zp6<-5uORbsCnfSiY|%nmRuYuDhoS#;y~p8m?&%S|)-j9NN(71^mxP+{Q1w|UR1Mrq z+*v?p+kD=qEzx)`ZsRRj-)Hy-V)pfmcC(RCckv8KP>-&bWyGlWa{;I~v9=#)b9Jgf zS*P%sCPA#qzP~uX@fZsV&Vswztj)3&!Ihr*IF-%KSenhAj0$1c8f5RR*q`UlZ(yXX z?_V{%p=SMnN$HfsC2AO(tAbf_t=Oi*wd zWbq}NzK#~Wi!;z&&{RJ+sRK=VY|-boG)rh4>O%y5DZ*W%yK`#^A&A`5dSlczeF|>F z3woN$Bee+R2JeFZ-e5D<3@IHfwNe1I0rP9ja2wUOoF_r%qAY?oZf>Cvr4jMSeyTL@ z3E+4i(yv^2R(Dz)r_qPuYUbyR2H7kv!QP$zY_GJO@=4QQpI7;{l>2WlVyR#r(f>E@ zRD&tKRRH0#9{ZyJN;d}MXtY|zdBHsX=aXyFCm@U`eOc{xoZ^AwH$V+LU@>;{dD&vG zi%XYa(8)v?5Sy&JD2$nA?CgIY%R&zIpCrBJ7%1Y?+6$D(V=5vEh%Cz;(V z*Gz^??ty-}LLZBg7~PURJ<@ecaod%4TPhHxxo1IX6^H&v(r5z=64v7FL`f+^Hjje* z*mkuL9TmyAiWi-JCC6f|dbl<1b(tmQBMSYb-!urHwU()xI#3}^7JQ1@a`Kt5p>tEl2eI@Zg9Vc_LV_a+zekVbUr%<{DJ(|#lQ zQBXaCTLMmCX31{;;H-a8(bo6CKxjjW`1tow?32X=Z0Opdq*rSx`_8NGG0WD_c5{U2 zVM&B+4R&~PMW)mbV=JaPjBj8*;yQS8xTUxplOpM>@w~-i!JiLAp~||uMk&=ZMfAS+ z!p#KDmp32NVk4+#C$gqjrQU&g4?iF$wlt>Q<#srevn6?Ixih($xHIn46RD;EL|>e_ zOTA<=Pt9gJ9#H(~#|J4HD_{GY>cTi=dm6X&i=exR)IFMkgVd8SeI>Vh6@g3LO-g?WpbdJtaxO9H^=etYCM`oti zeX2@#f8%j!ek0Q%L4h*s(E6e=4jC~DMlZi4dC7JiYRxU*Gts2#-z ztaf73ADFdA#>VTabHBq|Fo2<(q!R+M7$wyrHmbu&!Jp{pK_`q2`Mo09ST_pZJKc}) z5k^#iAZ9)i5^;4K8bP!Lj3F+1;}$69zY;p$@yT2SR?e zfH)EO;oMFvg;Av&2YC2tk76eV7)*+ksFdU<81$1kCDccR9N*mes))q0*K0XMatyyc zH7#ZMm(n3TJmv`zSs3UJ8iu)XqEi7-hgxOq^|z&aa3oIMmtX8y{lU5t5~(Qoe>0`k z^irzu6r$@aQ^i)Uk-`TX7O(ZDhZd|vn}%k^9|Yl>Ob$d!8wKT=`VXfI1~S zrDW;p>oIKJ=Yu<#S(!~koIc7(+?r0yIqMN$?Za$$9P-^%Rg=uH8o=~rjYu127f(MI zLQX_LHJM6yMQTu*`*m^M^!S~yqAh36LT`-!h1 z9Yh;cS35RZQH)05=oDv(Sbk-#(|)&t5BsB&o2@AYFYHeT&ai6qlc8>f5Hc7L?OKeFVks=PPI{OsC${C+7(Xe26C*4w<(S&ry=;TrLiDC6kRY)r6 zwGg3u@qQf?Lny{ek4}W}B~>2mg&)O~i@i&=zK;5~etq4o)>Z0&w4bQ$h@Dt9xpBMv)DCoJwu_ zNOd}Pb=vK#3zyQA7%yxcHDK?=Cm(!vlt$!min*dpDjVEJn3aFx)_&u@>yWyhxTL7m zr-<21ZLw2dtuKcLWBRY9OStK-7Vq7=+~#_zciw!p5)Se%cr9gDM5$P2);JDkm>*M9;2IVf*F$N zB@>2EL%*AM_~K4VBSFNQ5g>>} z-<7}eMMxdJxiKieC-q3kEMURceG9wI8l7-N$AGt1- z)$VW9Pdyn?P;oVUWgN^T)(8*>6cFAmuKaDAo#O0te@}l~0@rOR#ZyTasHp(R)Joj| znFJ6F_Onoa=;^0A!3|o_z%=G+1HnZ&l+8^5ZUt~$44VMt?AGFKm6Z`T<84KtmBfL~fhk5cu^z~F;?)ngV^ME^X^7=x z&Gwc6uIQe4`(4|N48?u)xnO?DTpZUoI^qD3NM1_VL8s6tR-+W5|7{tPH2G%}-(HGL z01b*-QQ3#J_-Jx21V%ZcI;MH%fsA?uIeB+0&2_QtjUpeLE zbIJ*=tAu0g=R2s@pfTLJ#y=B=+<;gR5l~Y#ZN|_-_6`oK&DPkGVU=+W)v zmA)}_tQzc3-|5ss1SEm$DD%*lI0Jk?Sj#mk^B6us#N>D|Mu`{1I@j8GSm79{G|h_A z`^5eXo8Fg1De*fN0So3A|`i#UR;m+fqH@k2PG* zS+Y#x+VVzV2zDaNJ#%o;g#){@J}s+5Ea8KY4pqsZMSbcG28SsPq8{RB2fK$Pd0*|z z8mKZK)u(1;bZb5vm-Uaghkk#Ev|(h9=|4Qq_??`(P>Ou{ z-WT~0eCa?+NCZ?Zq(K|FhmgHnu7~N?wz&Z6i&A&OErLC}%bB1*GJ*9$6b`~`J~!zb zi|MxQOAL1KB}!1LBfVjG*g(5cxf_RDE7aCHj%j^*do_<=_#hN>=Yn1Wtg;&XYJW%) zyKd#wNx7{Ukz1p-`%yvteww8-%vljS`FhmmbL(~(-Rac;@q;HQ6aF)B=T^xKz>s2I z7qzf#J0rvCXnB4jF>Nw?IK@M)`|E||jH19Mw6cseCArHBagzCZ4G`Js3Z-cCF#elQEqCoYjQ}+<<^&!}U2oJsp zOs3GqOFyDh!N3=9koZPG<+DweZPI#OZ;BCkOILp-T8J@`d%8yb8RYPY4$sVyMrw$Y)*q*x`kj45%aARzGi>b zMlzc2PBbDh4T+eM@81j&(soGWUao65ybMBq4Yw z@4X%4V@CW(c5M1%X_3Tc>W9JxDO$IvQ{-_Y$XaeAm21oEyR?K>BvfDB3Vn~rSL7|B zOa%OGV`zR(G>j0MO1@c|0E+KdyeqwDG>m&cI~r@W?{13dH^`lbVb$f52T$^%+Zmyx znZ!=y0c5w0i2Bl@NWZ=>F|zZT?bQ<2Z&2NlpR8J(K(-At6JkiRLd9JDTr!Y&F85Z| zOE4JTimy;o_sVNRw&rU4lPuDr`Fs~hv}SSjDEeJ=L=ItYj4pjwTgaC}6d1J14I&;0 zr}LTH@;8bRjl;G(WURuNRS_MfBP)16ZoL_=vGsXb8Q%*2hPf#$yL~*$*ZBDQOOsvA zp&)byK*s*s{?K-@v}Brnb^^D5CRjnC`tNxR!Ci=n{1VWy zjT$zR5@^vAgi@oBC%V*+Z%e;vt<>-wA*||;ns6{`gHFw{_WrW5V4Sn(hO38X8P6Zb zc+D|pls1#VSEEj!o+S#LZ#u2Z=Tw>IBoiyQ1bB>%#q}Fxl|&Hm^+i&&0UBnb-P>Qz zTmExtEkSa5FDCw+U)>Mz2^<3QJ~`t}-ZT#od4#x;Y)hYJQ8+RiM+mP<#OvBYFzo)$ z-B-Ht-UDd8zdKzA>DO0U%Q!U*ZCbB_ocB|UR#c<;bE~~kk0=%bK=S`>xj)YGd|iP+ zx@9NDsYktKkG>wTXoz7Hx9D~P13yk592cxpZw2mV^Yszm*scsVOgCx3$#xFmMg`tC zgbhY%+O6eZ|JE;r+@RoRJj7*mhw)<&#XNT1^skQ@&SFGcbpkT6-$Fij&&d9Kbj^q< z@5q=S?!NXX^2I{>oV|-cJdAmWIpM5x6zI~6wgKJY>a}e?cEX=P7H~v^@@n@r+U_E& z?G?dk$4Sn-Kdcf1U$q*AvY9yoFSoQCVL$BpvWe|?jNvbuf*Q4U zoFaomH$I!_m@|muecd>&hVdx}G{E3mSR@0}C%kO%U(94n-k#4t)I3VKn4K2?Oe4lF z_$lzHzm*{BIp>LOBi64D-)34gn?!5eE8uzHyk< zsn|9qUilsCreFUveK3bt!nzvm-Qj?APsV8LW2CKTPy72_#fqkF+g@(Jz{}Ev*7p|T z8coVLgYtbB2w$N&(f$zn5sKkTPU`{_{#z~tD!*iGvkNDhQu+SXL`^ABx%;NP<@|WH zsO79ay;Mg^wW-lH)?Hm5!V&7I9%1U}UdMeX=OR^yOEPT!t#R5CN{6R9-B|gAmA)jQ zD=>8*x0N`jO1yP4?ojI826)W&d4H-FdaD`E`cC_k+DO%zPP`BM?Y0vN?ROpz6h+@> z7a$${@9>Jd9NzF=h;9bL{&)a-JjQl}*SLfo`u-yZmVD8uoKO;M6r>mv)HrN~vlSFF zZCG=uGK_xtcdkAo7J*#6_ZvBKhQH||R}duVJe4bZk&D6$HORfezoGMSVd<^dbf=;j zHbRT{TMyK&*5fzsflQ8kPhIQvpB9m^D;jPc$nTJgne_&_NG37WFv8KV)i9ovRoAJi zEhfCZbtc^dLzC$C5I4>_wUM!zHNJ7y|@*8_E}iq@(RVC zNPdYCZB*&V-f-02xl6F|DHM6;D+s>&C+!G<+X$Do^`LI}P_3A++@0ylMb>flOVg4+SG)2FHyema79HPfMptLn>n@0vl9KT#Qh#>5iETNzR|GAjwyen2w=e{F@5h+kun%XVF>Wy%AIBZjkFbH2$>1 zrZ%QK(6zKCNo;_Jt&|%b`+c^E-x!X-4(xdS$B?bHr10!oyu>y04-y0#J4AJ6sr!;v z@@~);rJGTxk0PhpYr($ig(DHTV*5jDut=nzUKhe-e;L^MsKvK^4QxajpyuIOAhS18 zerUXTN1GJ$0XRb${q!p)vELs%%kf8xQ2qs6zso}s{2HVa4awBIF!UwzrQ8bpcs{AH zg^**a9mVf^H$R1ms%eGbFYh$kU%2VMAIaIqFy7H1el6yZi2LKwzODSxy6>T?K+ZUm zi`wC+I2Nd5`u>A(`r}Bh;&X#>{M#m+K#cCDd|7_nDmkY7iKJGh63OwUGU(GagrSFS z_Lvj#qtr7pe!y zdS`-awJG~~FIs0rSnC%JkZd>fS61{0bCoH?vv=(52Zt|XYkP*% zo+amFvyBTfgmu~BD!cmihxjQ{?@DjwQH4!UV-k(EJyY-vE%0(G)!-zwgnZrP0c(-p z;^Vjot}!&NlcQFPHqs5{BF&TGo%3!-Bne~<7VX3hcBxN9`SxS=u4(@WqR5jlF=ndR z2l+79t*H<&*0I^W>NPUjuTcZIK!dVQ7oDPJ#Ti9c%;YdFIL&EV7Fhw zKuiZ8qB(iUPNItO+QINoLM^Y?7;GEjwF0_Z4^BwC1H?XBfpqb$Pe%D3W9$p!y3dHt zQzF#G|qI?21MtIY~5v znx?E7d>-}Lq}6&sBS37*4Gl&g#rgoyO&;K6x)vo?XMz&HISf1y+hbiem1mWykY_bk zC%P2EzEJ&Z0Y@K#*s&vlvh8-qAHO6P@?#aLtz84 zLu*Ex?FGVr>8KQ)ZWF{MF98s*o$V#TYyiY0#y!IjZVS0Mg66h2w_mC@8(Ovhb6r8+P0qA-c_zuU zpcp1~Lv9II>pNcem@;>m{w^a}(*|U|;EfqQ5kY-!`;-Gzm(Z2RncLOka6 zc0}v_vgH{>-cXW2{LxE+2?o`T0VRkZvL@%2@+SHn>vV4mZG9{Wf-`LkNHy#X{QXhz zs-MiGY;4+}RDfXu4Rv)x-*3`Q7a=~Iy&{aM9MLs0cZ<>6AKMV(RYOTdd-DJg^AeU1 zAKCB9x1UY+ogDM;SHu8`bmwQt`S)_Pp2A{i#c=08>D*Hn6qboe@keljI)_CdQlB_; zn==&Oda^U4EFVUXvEd&vEsMzvl^wk-aBGR{+7O-i^*PB6!%{sTycu}?&+iv#-yoMA z)^8z``%iQqs-?AAb+Ar~g&}3ArSQYG@}`-2s_YP`jn~?wmpiU808}Rp)G#Yd!Jb{W z`fTd7I69t-Vx5pRlZzZX_rjsig5F-ljwv_|(T3P=yzX;acLyMhzXkujhkPZCB~@rJ zIe<32*p)q*{>~dxmz>6Dzvg@G(dpWwaz+%;PoR#>AJS*AiHY9qnth(6sbxqp;D0-k z<2`Kb$FuxR_6vSytY!et-DOzAcxDrlZZhW;|NM=oIgcGZ$Vjq4Rw5Sp%gi{9^D4ps zgj8>{X^gN3G}}r4N-Fy#v{HclpY}uwRtI8mN_2Qoi+FO4n}@_H9yHTuLmFpEjmLOm z)p>h0jUqYVE5kpf>iWI`&Y5*@?3V!nqIiCL;c_VsgWhB3?W=>uAHf8NqQ-+%x!B(f z1taF6c+VU2w%>YyyYnhsqAjbl#Y&lsIAgdxzs(lHcWs)A1T&?Je}6w3z8G!#QhI+c zdomeq$v=_P_0s-v-15ba6`$cgJ>7V$c9=zvWst)ty^oS#fhxgt@vjrV2^^7Kh%5uq zlpdCE6fy^%T&C2ur7rIjj_~$pz)-F(h@uhF3CS~I>Q(pSea+$CB(vtRhg6Qnh?Dz3 z>?%-bpBR=Gwc){lXfO=j16_Gz?g@im2>`%q2g5W{D{)+Jhbi84?OIj^&1Dhz$(pkk z>twdMM9EvpNOS+Zhzg=x?>kB%%}$Jo?7_3;02;PrDV znoUku{8TCj=svf3#Gy3%hlr0j|9-XrT#d%AA-n}hvjZT$(!}JHx6Hkn_^6K?3>~qr zcYK7{tiGtz3C#3`4n+GbcwhFE&~B2s!BnC%Zv1z?V9jz~F?#TS60*rbAeIk!l4+=+}RJ-G!vzm$Z@h@)uxTeb= z?-$W@xQd(v_{y@y^7$G6x0@+@D)j^j-Dg;XR{&n@SSIF+f8+)!c>#Q z%qcUhYSR|Q#=GWTvB~tk7syL5{ju5tg%{T|^8QXgQz+vo7}o|voBfIR>@)!n?yY-0 z&mw$zL*#Gj?dIjnk(`eO@yp@>Z4TDAocFmL*)dFabR^KvkuR!RTN`Qa4)DY5U<-h~ z&+|;S)!-*W8-{Abj#YLRnY7zjzN-o1vu*DdjnC&^3l&fs`|k8-e6lE96utkG z9jwEt8*;v9LbA8VIQPL~w9l)d4<+oor(6V6+uQw$_aR~T4Zr;eER2rp7L0&2LY=-3 z%7BNh?3qx>poVj)t38NRY1%R+(FR12g7c=ZHt+OlEOlnNY{WGu@DVcUghN7aKFBfL zAZidd4sp54a{POb!qWZgXF&vF{@ux3lSl=%r_tQMu61|IQbLD8bUcEfC6j8ahl!71 z9Sqo1W)hKN;CJsMDc$Q}qstJpxYsg1MCi*{nC`D|#8%Og4%C#z_@iOm2Sj_`c99{3SlWXUbWFfIB{L5HLwvS;`s1ko90uQnueu|6i}mV3tL3!zI=L(-n@}ez{|A%He@FREjv@1Odio>*N$^k#Ry)pX@v&McL2z*p& zJFoY34JeCx2}Rh1;eov;Ma|3q*i=qMQ8yZil%_nhRNLQjI&VpDJY+ z9wya%_oBgd#xc)_34xZ#s3K z?>jVQoOlS6bJqIW1)_#%_1w8`hf=xEnZv!E3AJqFO?huQY@42l?5Q!$&%jy9?C-$Sb-L;S~A>-EjM%f7XQ1 zT9ecJ1anjz%HR+y!PFLUQMcW%$EpoWkhn7|+ekMl`YtF>WxcqCD?i%2Y!}}>Lj_GV zT_zgC|F#pmAka5h`$J7E#PNqfYGRe_QMZ)2XXd10wZM1wk$%|)pn2Z!ltc%2Iw(;v zbg`e4QMKexGHce>`A#^Qut{u0z#l25#66|4|Doxe|LT7KKYp@pd)cixNW|A6z$IoG+aC+?5O!)9rgv%2WPmZVWf^C;?Sz3LI;@(I@N!h zV)!4n@eFnWxb6F1p~v@0YKqR6X0wP5@LDawj;(vxONT`0@Q)$;MSe&(uzR4iJrT0` zAbRAh|yq*p;?M`#=E}i!J8+=MKupy$wo!x`ECzOL9$?_8v$NbOx_dy z+P1-lMTR32Uq6E}LKgZ|G*%9D-d4`JdcUwY+A}irKWfvtt{jzDS`}w|#{Yd;g*ln1 zJx@8rw7nl=-AgE=#+0FnS0>E|!SEb-?_RKeeQXEG=s-H))I6-MR-(6^HSiXJu{j~# zsG`oN0gvMtK2&}q*e1Vke5qYQ%%f9^0=_}b0)As%*qGLs)ne}p1;Pmbx;4a%*HEQIhAWc#U@GvE-RzBjR(Ls zr|iSK`|tK*UtfxzgEcVoYXrQ%-;Xr)Tg2ZVrviRMJvcBYgzqJQH+F>G{1IfN*C1-D za}9ktkmlA_t5?1~I8Z5;qyjuK^7R}HlX{MVFLx?Q7w;uycLa4j=#N~BnXOrjC$a^H z+$c$M*xlW5F=MP%5d*4`bBf>pIl;84&U-i63T#~kMq2&yP zI>t2Gfn>79JyDe3`m*siua3&A-AQ^wYxJ!txYs>R1>_9=p8r0sasi9?b%{=4e7FR6Vm>vT2=`^Q2eL9l8{rNMYzjP(-3M)dO39Aq~2(o>|#e zcBCW?yvYU=lkXaA;k|q`=p?u*bQvF&okS3e3VV?7%XHst+?9sUdoYT=IfxMcP<^uV zvhnpazaC{Ktaaj3qc!!`T9+N+G7Du!nC?@ytPVOn@HPI%gmsc5)8cq-jt#T$x$VIA z5z~*e_lhi#8){l6tITD^(U|)qHu)Xg5yqQW#R@7GK(Rgy85qZLL>ny~uDY zVV4fRWLlSS@LnBP`#sgjzx5r%5S%uwkyeM3n|l@Th1kqA2FAY~E_|`r(_F3x({i%g zTRz~WbYRCXVUGAPBs&W|s58v|mk9gdG0#h5uRx1_hFx8(l(SwrT!I!D{tp64G zdP-GEUD=-eZra{{ADptw4}AE+aws za!AdwqLpIqWFv1mt60WDmz6mSz}JMl-$~G;FCF+g@o;)Hq3;HeOa*JT{YWb z9DsjAT0O4Mxf8XYEtLHj5vgGGwk1c#b3Cx}e$=8(8~)D=ry(`DuJXMLC{X$0FiBFy zc443H3gUQm*V+QGmni)4Vo-SXEO$rU=aeRa)E)gXKFf(8G9h;Lqm;HnoOAG?xF-@k z8Dn74`M+v9g#^CF_j@u}rD(kl^d1Yp~H=Q9D-M#NA4NQe|^`3;7{N)tgK- z1f&Lx$wF33ry41UrQ&>Wgq+0(Q~%=JXVfnaue;6($$SfbIpTm(WQSVl5{`iPYatSe z&>A!n{=9A2Jd#!%sa|z*`Vhi_L>6%EFjX#`-#Ov|Ng4Ma_Rv|bv$EN8xl;lO6(d@p zFsH__-vbDbz+~#t)D!2(6JV28-k$^Brw%b*TI$}zh<#3K!;5j&2j(hnpOycCLAc7$ z8Wa1aIm3V=%XnPr)0tps$i2^z7>`-*y&WyfO{8LVVCb&M)Ha z1`kfXI;Izl`)_zTq2VUa!R zAgu2^-L{HVq_`#6@Syi&tVr)Ob>{Qtd9czM9_0e4sJJDn%89-#E+9MK7V5NU0|DRsNgn`dj zax}_`m}!YqD|#e*_WjCurlZGB^|iT;lIGSbiRNdO$|e(2&$^(o-X}0|;-0S#plk1P zaibS;p)LGkaTydWb(x5sQ0Q=q%$Pvh>)9ckS%jtd#Vg+;gTF3Qf|G|@3NQy=fITXI z_gI^EF~Q=vxL|K~sAYu^OhDHR3CO*L#QCyDV2IIhiC^JhEbncek>^O`+zr7^wkk?0 zC>??nr;=|>?W8qTsCn%Q!C9zkTf*45AkjrZUYM9#Ih@$LBslIeaexJs&w?GLr)@0{ z+$6fWAOz(Vy1*?e9HTEm6n+P-04xx=a2kbDL7Pq53<7e4suqwOn64fT$}jJZH(zEi>Lo zAkJ$5<(!-}H8|!QQi`Xf)CMK*1me6bu$)c7ggR)=!_nHu^LD$*F4nhPR~>LKt+Z-N zEyg^(bsvsuJL28qo)E5`TmdJQ(&Y;Boy?F3h4*R*4 z?_3Vsc6z2abc>&$;$vn}Xf=m_=RxcHhLiZWm>fVMcL8|-Gyi$_SZgCBdjbO(s;$|@ z;(W+J3W+NJK@t_4o7MBWF{UPfAz20HE1Ei8AstFBUqRV2-=J)mUa%a5B;w1vAU5x{ zx}G!+aToDB#?5LjN|zK7j{dWZIG-{W*j=$usn(xEoZ-`o>vXmR^M)%cGDf=b~I!p zqMqk{)cS=gMzPpYT)5NNA9&iXq;j^1Gp}>8^+GkpC|9S#F~7n|ViFuk58*Cqzji^= z#~)!Z*YRsUMmJ6`J$URdn(b zQZe!*ymM0Xa%kuNX;;zkrLK(CiuaP)$#ArO0!qCaPg-SSly(X0-MSts zd3?#zpQzFWEy#o8GOO&43bk$KhTW8d4-h^&}9*;ly;f7ENhm@RbRL(b3599g~v@1PjN9zyvC!=SjI34=y}pKR%) zEE?Uv<5cvr-?Ggd<;z1aG;+vyi*5~B{Ps!PfH*LBbNLzMdfKuR`xadO!+UD%LXt*Y zh60QPf(rZP$kt-^{e9J$+fyFap1>Z}u)n}E|sz4-`m zZ)1EzWZX76^k`TT>2mmSbhGt=Q`hbSbksF#@la~y{#VH$v(Q#V|1*}7zO&aNX1@_) zuU#~fgB=Wx1q-&1j7++G+%Zzx1iA$xs9A853IE%%)svEH;!3v;5iYz8+C72_S-#Xs zLHhvy*W;XK>qOy(*c2&xPWtvh*-sArQOlns65F<2BaW%n8jz$=8Uh4eV_xRCOb0oR zPpn*KN}=sX59tqRNA~y_SL2i6!4c;RF@Mdi@UQGicOvO3gFToRojc|B9_Xwk+gB20 zTdG})9KzzG26>v)RwdL>1rf}7+#=hIe*49o0EPNM7Sye2P+M49gxf|i1j|kv=}tQp zJ&S2W7YlM`D$Uesmdi+x@dm8XG^b|TSc=YC{#=|nm>nafb8S(1v=r$ z`3_-*Wv*LpvkYn$B`&OfLPS z7vP{lHR>L^KA#XK{`J)9eLeD={Zh8WSZOImVT_{hi?Cl1Gx)t-Wata>e4&||o8NZh z&$|uTEKNH?J1S?-3oLWvvj7EodyWPxYC%VvvlZC-Q9yF4JAH?9_Q;oC{d z8YIn5;M04@>Croax1dQ>_dSHMMt_`$Dxb@?jn^s{IN(S8F-a8ZjKq_Y5@Kq9(~qIV z;G{VpPNJWcgeE^9sMmJ(yWEB6%TJyb)D+t_DE$7{gy&8bQpHuE80lUIj_D{N{sH1X zfjvFXc8Et$^?DVF|3e-@5}X^HtMP>5dyk5Apj<`Jju`G)ZOL2flwXxaOFZpde#?d6 z``dljR5Bum4xq_QSx#fq0z;2W|DcB!=l2hMOnL(clNH~94s!)4aJ;$_=o0xMAcW7* z+QP6h2Vk9hb7$_+DOoY#ZvenUcEw)LCo1df=m@au=~B-KDNrGd*4>RGT(|0a82Qt* zqe)R|K1x}C7wrbG&%oKBt*Ia1?Z=CmS<7k}Q%WQ*`(^o0!YnGiat2S(!bPR2MbuuQ zT0#pb#@c?`1)%>>Hy5X;54wrWdw3L7x>OBcixPzjkoXDQ>`&&bT|dKLV9NYV%^peO zfruiyVcesK;Wk;}#lDT7@!89ZkP`=)$&!Ky<+gW2=H{M>$zz?cY+N94(ARR1=)@BP z2fzb!83I%LYfEv{8=DoGidYn#N}SeLvVC7mwY-v-RTo?H3Eir_Uv3+IxYs672MD&f8z3E#ThY@H&>i;%iz#ZzFrXf7S$+a4Fo?%}n z)mF(%dF(=K;34{Ce_qP`#+~PDTiKXmi9N_iynXNF($fKG&VU&<4F5?@@M+ik+vGTE z_b{rEe&2EoGg1Zd2kmhzc)E*GPH+Lueel6TI@+qSwFO7xiULE>~ z_-JG9x!-Yy7Pa`Ct2&DR9M_E!iBwf2uy7{Rg~+fLX|-aVnH_AwcK6CR}n#yKe4gRXYhPAuhf(#L7+5Uz~M=qSKK=5Nw zDwjJlvm33%*YoO$Mxg~J6ryF9BmRdAF`dmiFCr9I**d6#>8;}V+h~GVKoJjLlrtg7IQjwL#pFx^AaXLRldQwr0Ov76`JP zxgZ&nb`ud^F<_#lf^YW4If48h@;V^`y2Y}=;3FYehU4yEHgm~NL8#l(x?8-RUMHn% z@~h0#CBkE1+Hirbqjcph4(95aAaww=9c%(Rzvq8ud&yev#)(b{%xC))-|xMUsd;=x z4yVN_!d!G;jyp01`3+Ag|C&vxUZiQfOOEmtK}3H;R^{M3$Y8CS4&Z$_XjQnSR!C?- zho5JMl1o>LI^stHe{kVb_r1!}T;1QHUnP|luMsM78{!$~qc71*H}d*PAoQ>afwR+;}2u^U|0~ttM%u6>alK6_JKVir%jSxp_IqRs3EeoWgsoU zJN^Bi*3hosyBY{Yps3j?>tqru_;gSZyu{|>_joPhi`$ewXprPZe!8Gn6+Q9ux zbdiAsRM)`p36r2dXjqe<;x*2iHV_AbYz=Ob3byLkFeqFn$bkX0Ovr)20I5%pNvWBY zY9vRReYf_FG`UKm5sC>pX_%eht0x?oK1;*)n&fxcbX<#wCwx4qZpwA|Dj>1;08P3` zgrL`a%S@eR_7mg2Iwa}5AKKn6Ji!2v(xa+sQN1l!sPEjLm4+Rti_TI)&TE`5hmbih z_{5|Zm^Ce)L3Y!Q#lH$g2`(Zfff+gZB;v8Xc>c|+8jR@ z1R2ZCB4BCu$X7(tTLk?2@yfX#@GN~ekOExO8*IEj9=a=o{>v5_aho6!mkwn3pF|6N zV*x%&w$|-%J1m632uItd_@+<5c!U~<0t$B*wD+(R*GyqX=>+5+Bcz*EZ*8WV3akMa zsDU?viVbDsFhXu(Etd388u>H~Zv_^wT6G!_>Cg(r*@J})G)otwe5@O`3;%QIbXSY& z#+3hEz2U;NgNg^XzJOih|U$ z)_uZ9P{HPNa&k3mQDy=>a-L`6{4v`*62peR)E#Q>9 zSD7&4Ng2Ca=&L(tnFQ{|oKLI|nPMgTv$b%On&_E%7Gs5cQN|{$XUwQr6ruuNu|~sq zSb-2Rvi0#^b)4Uj_B!u-+7)zuU|vv+$g{Ne4Yy*dW9g_^q;rQ;pkOGl_?7Bsa`4)d zZaC~Gs68tCH;Mbe#N83G;C2D=0O-C;7I4@ZJPlMaknuqvQFk^Efx&+IHaW6^M5gXi zJ4Av-mRzpr{m*axR8UE(IH6azy4?(i5pffY{vNxluE|w$U_bBzrDh@K)mM@P8N0~} zVpRJ(N+*8QS+WMc$w>^&Ai;4{8CRzMF@eK|-i|{j%8WH<0Tlc0LCqq+0txgfq<=mv zX+re9|9sZ5~e1o8YWC@vL zaU$3r0#D`XuhxJObl%eS+n954^nVyKc+hkfKHKrq=+aBuKXNV0!QrTU_|n$QQ#f&t zxRJzl0Wf__XDvI(alPb3S;{5Ke|)bevJz)e#Pg9yXoKgOo#M$1;;u5*(wkFRAq8RkX_bsZ_&QbrudC(uiGmKH(?8aBla$K*QYiwj8m>Tt@LmZUC#@ z6JZG%k999g{>?xLLSv8}Jd;pL7+Z+P)~LxcfWmHySfE}bpO;k^ssR5>7q`q^uMw5N zR)z@5A(xNc;Hy*2T@8aT^HE^-*nYOpWI3MWzS9$+;L1)us_ztM#Ah<}Sp3O<+Mq_I z|6(vuujtV0K_u+op7;L4Iru4*?^3Ahyv}Z3wc)vgv^3S* zP4XhX9G0FsXb$e_-2dIj`56v!&YOtv z%=Eaz%wzp)Rb}&?F-|MARZ=<^<1s~U^c{WX#A+ji$z%*{3$%yUJTr*B5drmK*n+GK zFVUnp`ghH8vLE&>nENL9ZXtxKyzV|W#8`+eB93dzOaS3B!sZuV$60FOjeei#lIYCs z9n@B6r$W*LmFPghv)9Jdu0SCvu!z{8va@+4G{CO0XcX_(@>XlWd8eU$4vCbun{JDK z@48cQ1&t+LWqqDg0WV2J&YVi18|E>exSnja@Bx0`RTWH~=qf}rFg}O?ov+6LkN1dB z|7Xiq?PS$F=gYQaxD+THcL9jnMbHi+J>xW*eX5~;N@z6<0QN?z zu&JrG`$w0Pnvw(`{~`L=)`4V83uU5|d;`-7E%9$m2eW|UPKIWh1QRv7T4*SYHn=26 zy)UW3;wMMBnNq;A$$Py+B4@)GY9`OE>Ufranil^i1tzQu!X{~#q~JLGCir3gITAAS zja2VuAZwbMBJY6PDq}<%7vYw6DYA=!uR!5RWH}0aO{YYhrMCExd%l=KS z5Hal482rqN>$6Sto21-Ytjl`wMTmLqWZ`h}h`qsBpc_mGnt}Ym#ay4~q8q}t5ni@6 z1^nZAr$z0k)?qUam4virk=+3Pe0PJfz-HT(@9d^=$U(-4sX2)!r>nu()eRx+r;uuf9BcL=cXxY@Pxkj?}*^^Fo zMPt8UtK6i*IZoLPH};*^y2Dv%L3xhy-za!%Q#-43CrgQfp<^wJt}uZT z_&CctA)q4?#hq#7MWw!iDEbD$U(g&BW+mGzN^AR^kw%fTju%u&j=IkQ7N8b@RhP1T zuVi6x!O*~n;UHkh^~3$#(6WBRYP=H8QZeh_a)zM1U9u39J=Tva=ROf!pE}#0^0s|w zGcC7~`L1gEPUl^i8(!f1PD-_kS78#1nlaF9o%N<8w;J5523ZKb;74*ku)n8Z@Xyz@ zr2;?nL;p!mq?V9d<60@jjQxqgTCu-2(J2*=XM_0XF;Q?3T`^F_<9T5WBgk{0jX8u* ze%9+dU_!|E@6iMox+CU8P2?gy*n_lgEB?=?S|-M%Ae*l|^MeDcJbd|D25uVn)%U{lQGGyc$5kqFlV-qv zq9WhOF@AMG#}Y5?d%nuYJr(0GFTjfSJc_f*Ae{$O8|8WIV?^P1RK%Ef*7U0 zM~#}`q>?H+&#MdSvzAG_(ErJR7Qh4%qe2LEV|lgEk?H+wKXkxKUnIC)2U}&9+zeJ5Q z?qXiFiaV%kS|vBX!XLt$PXVj8+jy19jZ?9iunrpW9Qw^^={b`gR?_Aw(Z~x5wTICdOUG(?Au0FY@Hnh?^@kw&y zKt|JYHI!mirY3_BJ32pFxK$e|EQEtP3Im7Lpuo!$7g!_{0+{BdF0ry6VlTH}l{b-F zO=Z(V-$Z1PU)zrtm0#0#(%$1wx&z1a!Q&S+%A<8^abzF>UN?Z%wKt1a@eCO6_bLiK znrXp=BFjo>>|D~AZXczBi-vwy;)GpX^6}P+^X~!-8SGD%Ydf=}n@#3_od9Y_tbi2` zm_L^+d7UK$X*r`os7)!=^FKBK`J*Gi+@;}g&Zn}5i=*5OY$phvnaR9GfX^uMl1UmU zle%8zyua)ZTBC28Zfbtl3PeUh;K~0J7>5WcTO6lG(`uxO37d#|8iygmx*`4)rv}4Pn*-^CWNvJw~$%igRDVc z^}#T~wq822Te&QXq*Wrw&AVsWU%?Ro?1Xn@-fq*G zG1Ia9X9t@U4VyStTGh95qaAjtpyP#`o%TWDNg_Ty%jNR`-=@EBS&4Qc$Liq(QQM^F zpONO5fAvK@ou-fdgZXUJ7_BT4p2fD3o0Ud^=)N64i-w#K67@!mY z5`|PTC_?hnS>oCfCKPVV!P*O8oDQJR543;^5qBAP6AT3;Hhur__uPLe2(LF(l%@Z_ zEes@-*lOXcNl|L(K5!;1;gI0%=DacAg6z2o%(?x~dGuT)MlFDhr6>x7clm+>x_uDu2Z?pdaan+JoagJrTbEQ~;)~ zen?tH3c_A27t*K^98@XBXaSB%xx$A2 z*HuhHG?!8#!C`PejRI5n1E(P{!5Ad#$vn0 zF3dNzBI+DM)5!0ZD#c65h2cnH8e`}jfR`G#`oj6ODEYR5!N8cqmr@f!smC2R?Jrm| zY`Vtq7nMFw>lHuyf}X*tHBG@vwX6bIR7pc|vr7riRal*tO~NNMzTWK%@*>|KFAQ|C zyYc`i!3p5?#t{%=m;i zDdZf{+<;Eg{>9I?yP~IzN>Ue@Mnup2M=L;iKZi`XFj25Dq&EF+TJ80Jzn-%b@h@xK zg*=H2uFa#AJnP(w?GOFRhF|cHF&_Cf0?jxDBRq&8bSC5+!$&fcFHjauX1T;SoysE9 zVU&lZdJ}v$sTssQ`#JfRVAeyO!I}FD8lUd2lzsqivB@<_5iof3=`U*}14~uQ4-Dsd zqP(0L!49QDF)v%v&8A`aLod02Lc#v_`TI(|au-92bA#xJj4ypZ^()KIVi1*|IB+=i zb8yGO7$q|K&O5ioHSQ}@8|p#yF12EJ{=I1Jmhgpn3R8LG?OY9IIfmMQRI%mG&=$8Q zfpgDN$HyWN(U*0a>c8PBl_(f!5HU0U$o>5D#Ge9ysu1Kd7=ixBF~v<(dF^XdRADa>+!Cf{BicrPsN1xD zBqcGYI9R8pQmiA4hnXP%;(Y}XfR4Mj0b9!slF%n*VgH6d0Cj0s)x`IuA2tr~N}$&d z20%kjSJB0Sg2@vN|Cb#SEvs)vPBQ)H=lb@{5QQxcC6>MZxgl|q=5$lDazoJz2fj@h^xqFk;O#j zb{j22kJK!`tL$z3@jsifQuG`(qzkv#4^)*B4v&C=OigKGYHletN*;ZEn2Z??ndO20=v zkrKcKO0+<1NzG4*&P4FDmP^7TVD?|Ck~%LX*`5bv zy97e212(2?`f-Nb&PwnG(}G`SvcREN)d!JHBEgk4xSKmmU+R#J;e9C${z@N%T?Mg3 z#Qvz8)vS}8K@;JgF3v-HjgNVf9JJEra0lGDPB^vQ7gfuvbXjj-m%84}J=UDV=MwKQ zS1b%PC~57)f^eZWDc=vWa884Aj7*-hE(M8BIF1=Jv2QzOqBK}r6=;;NF==f4M-D`0 z3eQ{F`TGsimo0+vEmtN<2y9}~`PFp(8CGiW;F_J8Z{PAZSk_oLYx0cyG?F6YjrMYO zT8hSP0z2)kE(}GUp1U;{rB%~7LH+7=O+EVs`?J^~y-Zj6Swj|hr--<%Jewgt^x8dL zu+H+aX40vO!ws)}B0wxUh9oY3=`PQ&4=jaF0M(H@Rq1r+B`6T_*&|zgO{d<1*Wd^% zuuw5hcAp~b3LHYJgy0r3S`Y}WXi)%wjaHg?P`t|zvqMjoz)OT+%t6!5GFhYviq!bzi% zuY-~xy6G(FP@t}j5JU}+2^8UxD1j7cqK|3_6b5l)f6m5vJQNf$O(O9_5J9an?UoKo z-*(MC4>bzkM#UDH+lj!K&iNHx}XD9q1G10>&;HQ!xezzXD zih>HerA21N48JU|%p3QI3CITjE;3t&8T-4twS5SRFZ|@htw8)+tCmPRT0*p6_9u?< zA^9I(W|$pW#Y1|$!#iuOwI^_rj^3whK%<%5b3PpI_`#~W$%8qoc(52+6MA26ZTtya zJ+UKMy`@i?P1_`DbD&Sb6vz|lP!ZY8M~2`Sd1|-)Ddpp^Mrb>Qb;_PmZC5nuepq0^ z*qturrwJJ0VlY2?hjHSOqD3QAxM-8qeA1b%@S1P*&j&J$Mj$KH2&G zPw1{TE_sOy&Qc@OLjIaKn64wpn#A`a2q)&8aAj+j;kfr7lK3ys|_` zlvzXOi=<9ZD<&2M4`sDuTiwwl_%v+lesoy8V&A;>3-0^fit)SWHsk86%l^tev*5V< zUx%c|NxMY1ey~LzW#L1WQJXE~v*cq5Et6Qc&WbPGEl`r(e6#DAb;A8$0wZEi~nH{f4&ST z6lc%CNeMItKLzEK<+PAR(ZS@;h0M)YyN;4t{HfzwMd+SYoGBok&R5AdL4ud}1gVQG zl|+M+6>+eEi#`g?m!l2JI+waX)F+hD!$=PR0@$Onaaoh&4Dg$Gz|rSfU`nJ!pHJ6v zh5i10kZakSnw}Fy?cFGocj?|kRxU?5H-NUgV$vk9g}`m;0Q*oa#TM6YN{K;7&-wdl z?Z_yX`n8K@nd)qUGN=j@@lV%)_VBzE;B@PaGxJBYqgi{nFh%B~rurv~$+y42sNxME z8IoM2&j6E{CLlxVS;#69^V3M77JLnJXj{tpK)S#galni7QXFol`HO+zTKxvJ@^PsH z(8?y4|ID9Uxa~tpmMW3zW3h{vO74V#*+P>hR6(IU(3DzS_&~!tfSc)zUTz zF>VgNsL}%;>HDhmaeTfhkh+dLK`D37{Fw3kR>Jv2T1J$`&9m(b2*Bz-ROm|SV!D?s zWOiSHE0!J;_SEGfzQ_G|qIsoB&+*t>LB5Uw4)t*|q}2T)Qn*%rlCL}VO8T zYXqK)bGmmuePCvp6wO8_06Q=ox5=W(LHGsqB8RR4tt`&K$6ScQYIV1JLoQK?=JIR9 zvpIo!6W=STLG| zT->jyP;ug*C>nqFZVfM2c&l-65%_qhWuzS?I{HgiyiM9x2f4p=8PO2=Wfa||f$~^W z>Gk$yDmN(JAvri@Vej2ke885OnT!L;)B*{ImsU4MEq5HIQfRZ_yIlEOSr?dQuH(fx zXUl`%#qn{nzYgX>j|q5w&UxoUL<|A<;NrTghKsc_o6>*K?{#sY$7jB1AlMROuQRw) zO1<*pz;O&6BU#bF|6g~U6JOI@-1AjdA=Y|k1;oVCuRlx#l?++&Y|6#$__gr+&ION| zk2Jb*5-w`m^aBXQ0VMxUH>F!@sv@cxwW&i|9akEx9g5rmcINJ^?fkdsm~my=O@vl? ztoPk6kd|%sGdH{kqJXJ33t-oKQ81)?~ZF%%d2wYDin*@up9&WS10b~2p;2xKM zvx01&eV{?ULn*#Ha?| zc>@+At3aaUF}2l4EeCldTln~`+~2Xf<1){{<#CIPhVgQHQFQT-e$Alh_E{ocvQ#8Y zs+lM&&y#f8P5ZkQJ96{^D5sli5Tl!GBE+AB@ugtd4v#X1A>0^KiNUqtFN~jJS`L2> z&mVRk8l1g-X#E#K3#Vt{h|bo(!pv^WX-fKwcuDsA zys1PFb>Rx~x(_g#ZW zVzZi@%;qnSVKe;qRc~bCymm6cq)2;HB?8fK`bfXqNR3 z_+9>Hni@#<2q>0+2YI$%^dblzP8(?_&N+T~rnCV9sP@k5V`-zuQ7uB!;+#Pu81UO( zDB0Jo^j}6nMm0?qzP%(cNI;>)>?0U#)Lu2>Clq2I7Ow@Nh$Il^)+&DSF{e9-MI zrU>hybCsxKzyuJ}099$$V8TgC)1exjMbX7C}SE5*u(@QJBbR-^_;8}-ZyqfEQ>)oTZrPEGN&_&I+ zt+u;!SbsWHpFxrBN@cTEy$pU;my%qy%R|Ek=MHuZQ-%AFcrj2ea!eKPbL|%Z)HdaXcs9Fk5=`|RKq}g}OPM#a_ zM-EPYj*CJ9K$qDm=LV|qxcw-ZlDFyhsZx)bb{xGX3{PC&^V6Ts)JFfR?LHnd(+d8I zc!)SL^_zl981_aer}?fzy(y|4 zRzRZR2VtM`@N}N|ewn7gn?5r}TxdQBJC0T8st1NdeLIxP9RL&fK{_ZmzoG-9aEyGN z8zz~SKFx=^Q4zKT{td}8$^s331je>)g%QxXZiTUeoXtVk$y$c3t8D|9EL~qG>8F5? z&D;Z(*`2QW8te_}`iJ=984#Ro5f1Mr0+sD`{)ZBR@yn_O#NWSI1G7ZVHA$&Ye~p%= z)o>$d(1{XB&fcESJ?IxclzT56?CZScJE+9Mu2L_%)WXiWVNeoIWE1Pz!2ur+c@$}K9sojv@WW6mj|0MFVrMzv1U{p~@<9IrwI2#%aC83w- zc$oLsI4J8tjtc&^ExgB~(fqN_4C6e~`9QIHDty_q2f1!FHE23t-Np4R(%oAQ*~dU1;r#mOu|Ym)v{GtW#jC{_WzNj*GOQA zFy^-^1EHI1mG_5I{+$7i5yEPSe_gy&FW2?g_>3w{xy4d5g<<(7C zODHdkzY~Xew3QY6VA1bZ`fnc?>>$)TT;Qg%NbF`BE7o8X@o2 z-&DI(6}T4uJPb*k*939AgGW&wct+fp@+-{)gT5 zqSy^4JfsLYM;<}wT#8QTg|xQ#8&jbXZeQ74xqmD*!FK=a(Pd|`H_JOH#h7Ooz@=TK zQkZ?W5Wb})N;!SvNOZ+sd(oy4gd?5?@%wNmegHU#PE{Zzo)+<-@0N5v1A z(W$t)Y`_yK%wed;9q#xi>Oa8V;oS~!8ox~l_qZ+}1U5#8#uT}xYl48^@7;%HBUb3? zpv9wWJ^ZUnQG1@@R%`LN7-8?a$A;gB#SOnD{bgSps$+4MdmUi%S=h@Ul?L3AX*eIZ zZFI`jHQiVHE(8cP0s|gGG`J4~g`;h>Bwzn5^c|doBoT>ZIP{_IAS0Po!9-yIYzKp9 ziQGy%Xil&R!sv3(cbiPJM$)~R%3QD>%J%B$c)as>AH4KIus^QJ?3U&!R7*#V93vM3 zpUxLb7}##$korwL$cFldcHjcOqLL4ToFJNI)T(yNg>qWNwOU=ELLg#W_)HXkxLTVF zS#5SV9eh~bw^vfMx1R}>13?5gh{@z~Dw!i~ypK8XJ8{mi=orNRL&R%KZgtg z2&)1QurntX!2n@vf8)tc8P%EoM=fCbBhjZ@QfBk^t8T=&`3?G+G)TtPdV3E>eDAk6 zWwqPsd(gkkVG=<7`4Mll-M)t_gNPNKpT=t#IF8|8GswMTTH7w4qp-J!E}^0R{07KeM5!Fd9eJDYer#tCuf zlT!APse&k<`Bu%(6_pz9^=vy5g$(o4EGXL?!M}3$>E53O&HNuDa=V4PTS%ntp&$7pMDsAlh-tyTY_iloBS-o`XOtF#&aOUyaN)-3H} z+A#Ppnb-*sm55ltk@%@u|*cWDxs1pRd9choO&eA zAh7^$F#3`(ux|!0Wi4(1P+J*D7N|)shKKFkfbFL^a9oX6pxt3C(Sop#~%Myx6S_Q=7Wq&toJlLalq1(TPyrdc_9UTM1H(riL!<-I^yz6~Ut zC%K1T4}SmHb67z-iw=!<3baPsHi_Vzup*0}@@O;;oLomA{AgIeU?S>%xJ_if3O@{0 zlNsKA3kCy4Edt`W?8>I}T}4wS*M~H%uNlh5KXXNVw}rGpGuY@GB3;9P-^}4HJ?5PI zpZ9fh=FY38zZZRpW*t8Vyb3BhdS7W45YZiv;<2orl9{0)^|w*Um^epzU3{YUbfJ2a z3t?2H)FD}68wiXgBaLgpB3Q&`qe0+9>x9~7JK)r$)eW#S0au$j;qwT07=eCv0Zz2e ziWkhq6T)e-i4vKtfjfkekjAE>_`0wKBnjF~+Z7GujTn1slB!@Lh1&4DZYn|sftHZ% zUxHR!X&_OLqzLiZ;tSk32r~l1ocP^sD#Sdfn6KpeDh-Z1q9dfu^8^fK%?m@5*zNZq zKlcjJ23(1(5xkdd!~fzyI2aZCA+%+)7J7+~tcM&1w8n}?5|8(;P*wmNx4#9BhZUO~{ZQ4^qh3aRJ|O6fRaAXEzqlTgUFrOPsi*KV05 z4sZwb0zvO&4*Sv0p-1iPGR(zrF~Sh{+_6(t6(`j5mRBGAd{b53P}U0TT6F)UY6>uOXb=AHqB8kPIPPB5$8{wC2a1^>gHO6M-}`d;rq3ts{i*# zY3r0eA7m9gx&Z{Z@x2+W;;6+L4>B$P!>>XHDzs+10!FvNOeEVSZe>OnrL8EpKr#g{ zxxqYH%27~P*R7APYm%Z?=GRY(i4o8tGS;!hp;yc~U=>SQqtlxWXfWh&(H><|x-PMp zQ8eZ{$(qPns^YUVKd~c9Y>ycxMzR+FaIIP>=GfH#3NT|YRz$Vp`3uiZtv6I*y~yU1 z9voFU*I!D*ROr;A!t`gmHA1Qa>$hhDm78+18tzhgd*YCPA!y_Oh~!p;V>_pw_d92t-!(>RXVl*JUTe*{u9?MsB`Nrph>v(S zR+3yYi2?HuV+E1msR)_5eQxx+^WnWctv{Y zoyq?-I+l=k!xw&i>k-53axFRf!u$oLVfrYtD!ayHOfRMQ+!s zN2&bDWc!hx3}5#;pPZb?Eo!30(SoJX@)`;DW%bf(nyF+(Sok{0%(oT`z?e)A*LiFb zuf$0mopF5~bY6VM0D%CJ9oz;Qv^6aZoViSFs?a1^PWFz7A0Q?Mn^>`)pyjmjr0-_6 z(4{2xBBRc`CbrhrzW`&P2prGm0k8^^mb()6Y6y37XFd4&^UIt+D{X?shEar{U&OpCD7M@)D!y}6kQ}5XK99-86Ow=iKwe>~T~!b7L)Z6$tRdn% zFQjPJbiIJx0cGg=n%0fU8Nu(5iXQsV!LcdPr`r?9**2pFxLs%}Kr}Dc7gqz45lR2< z?m%$vzl2bh&YBxCdgF{>k6C`J8*tad`e=7OX@6yXYPQuEf{u!_CkLNL-fM4EpTe?# zaZhwEN^eyHv~yA(Nx?X{vABrmvWqTO-VPEI2Kh@?2Nu9|p1f#QiFts6%|7Y*X3fme z7vf9M6g$WI&GKqvBH3!|3gJ_$U5aq$lC|oN|8%W@F;i$#@0y+@yR+`X??pwM9!zOf(n^qr?d{IinKq)nzy&%3u)Gulbh)N8~l zs9;9f?(y>nkp$x$rb!f3OpEgzNs&prbsTjYBJwFaRf&kYkWpS2funAsDCg{|>8osS zv__^r=uqxmIi+93VT+R7QE)MR2`0BnivKI&y;P#K@MplvR3Kh_yKST=nKl0((P7g# z$052bwhu?SUdJcT{5fBRd%S!7L~z!l#8thZf0n39)K+1@5@aNiLv`2s3%RE6>uu)J<7F@Wogj*Mr}yug{%mUXK;w{9{dMnqCx%gX z{`}4i*8#%+2C*}bHK#G&0y64v%%1grmzLMArku$94-sO$#3`X?uskJ}>4>2{7r+Ot z;duWCt#;TC_ycG?zf&JEzN|-7JMt?K$nTqQ!3S+0zB!QG5@0lKTCU&QnLQwiPlS8! zy%VS{;sY4$THVKBBwhzU7BN|qBS)XV`5v3kzZ3XxucuwbeFQ zo;V{lka>DQ1f5dQ37c_t0yAk(>&FDI3TEAV?+FcMMeBgowU!o8j6MWYiW&GVszKRc z@Cc+k{{7F!yt>+Ngi4Uh_5}|Px7vPS7BNkVP7s*Jt+J8HRiWd+j}a-Yjz#4tCO8!VqBn@z#YKa&!@>~`0zFPlbm7qqWH}2 zDcW$yTGe6}L#SL{vru?XD_|50=hk~xIhi2`un_}ExB6h#FG--wUcJpzFwS>%y_WVH zfhW}bV6-G>9`OL|5p3Lb6zACKt;?{P#ihQ%3=s^8bz^Br{mcPY6u^Csyc==f%>L>U z%U1zk@Y_|x$|Zv9hg&&4MPOMb0!WFVI8F>lcuFka+~+ut>_nF;qrorz2g7X1$)e$k zN88NRTmiezs{(wIqe=1I))oB%>^BMR!~Zx1wZxS=#Ir#w;5rBGVZ^RSd2~CubO8V% zBM>Ou`wn30(~sOHlz@a01`yJyNl?^1Mzh*eU_Wp!y)N?iK!EFG5URSozI$wB=axW` z&TqCWf#|vA%yLe-r)Z_>`Z!mNbQ#QS;T*zBtQ7NS>uC6G)8fS3b5axL>5Y9D!*Pt{gbB6xtI3w#r%{Jwp9dL=!L|H zcV3^GeU7D$kv5R-#RmGA!<7)Nt8;6>9*2d8^x!};7DuAP=j1%^ti@LY6p=hP)z8|F1t%JIZYu!T7v(nvdH&sE%ZjlK5k}qXX0(C z>B$oM2F|=@xZi-0h}V$A@x(DK!DneShmk%+EyWUODn361wUwV@?dp&sy0*Z!-tm_9ab z9;C01E{|*`dvyj7ZJ0=5#~1_sW{&mfqPYX1&+}}r?(+eU*#FjmONWTRaoR;+hWYpF zeMF626LN8Pl^b!nU%5l1O3KmC z&I^rc4+)y(4-?0IcIcQGdETu)&xz|f>I$js0a+jZs|M2xw9fnmGNdoDB$Z>nuKmCN za<2)#oszABHou)$@mfZlvH&-!03am&B!a^Udr}Al;g0Bo4KV4(?X1v_#D2zwxRdqm zwabq+ev~`glW55JeaPmq?~g#B(#is+5ERaqlW-t~XL~vgAZKPHN6zjCK3m7)s80%T z-fd+AtiYJ&$ZAHsi@6#X7Vb4@2OZK<*P2K1Px$`TIEWX(2*D8egNT(ZQ==paB%=$Z zJ4mfp+Qcetm7jZ| ztk}M?LYv^xkvSh>6?rwtl`Yu5auvWbrx&a)0bW5oXb3-VMM*<#)O7qT$xU9>X}FYR z^#YS$`Ergnc4-WeW_RD{q<1Q+x|F>CM0U-(;lpF(Q_Sz#%AB*4|KyYO62DJs%p@ze zo#S0(oq$8z65S{hCkRa`l%FNEV=GNp3n*A%ihB2pd+?h_QAQT|8!FoX`1a8rqj@Er zRMbMMcdYdjwHq9eq3xSvEF#Mf=moj_h!YrKh%+;l=3T+}Mlz=5L7%$b7w$gu7NRJ1 zJ#)!Jf7}KCCuoNy*el=^C{ifDpN0q*(n0N`+CIkBKl-BQQ-?VSgkRTQ>fA7_Xj>3+ zGI|2Z1-wE~pF^BryBk2q$HjkQl*dO$!`mwGxQo=bT0og*L~F5c8R=p z9+9R1#+HssdxEX*QCrpgGPwOm_&m-?WI5rLDEIud$GUmCdUg5O6!VVA7?|3aC^ilB zQiLm88uW%EB*IAlv~f7$v0g+qlT)EB$vW~ju>(-^DF3`1fHt>0GtXvsiW=oS&XIG+ zqXs)LRKAz%1<92Q-yv&h;~8e;`sO3P-;;qv34Ld2PcWp$|I$k71FCQ%(mV^n>Z^3a z^8fc(^MC-(I6kjWwWyP!)pGbe8(lbxy!U|dB9HICRgE>ToC}jjcuiLS)^;&lvYdgk zJ5LUs!98*oMe^Y&$4aiDyf5Ftb;^ zh^DCDH*D(c=;K}=mlKitUN%vVqdl?$HTZj?!)34D6Tz&jKxiFFk3-b@&tSwjbk~MM z(z<&%ONX{G(+`%o7q+rQ*!6RQf+(|dMB(gvrObFwaxg&f!BmFDwXVQiFq^@usS!08 zPa78thI4&N1_QmFoPS6|SQp3J{X8)6RJn#h4;1Ls7Lq()BL6s2ILP@bYAh5DV`Z*o zvm1owI3AHa`n&Z5QKZ^Gg2ODh+OywCHhygr3K^GnPM`Fn^KJ^Rz!pP^+h`Xs&wR9p zm&J_3K5mnu0560NO?0iY@sR2oU#y1H0ptt~Zvb@jqpoGyTr(`!k_hup-K(v#}G~A7Xi#7itoUf6A(kt#5^$C($l(dseQ`*!}PBw;BF(WizNR2{|qXL)7oV#cwr%yop8} za>5&_O;%CRQS>)LS|6o4=W&v7kF9+qQG?u8xKE8#F9xWUg*VM@Wvb%HH*7w>Y|90w&oIQ>3WK2@k!F&FyjK;WC+@aHy zSkpVo%zGE%um(#-WT7bV>VVtRtzt6s?9~tQb&E3j{Js8;2EtuweYvRLGcBMUb|HiY zBP;X^MNG&efNqlV6df`MhO_{NI;sy4q^#@_1);1Y<{Kd(o=+VebWOvjv`zx>e&TPM zec1kf&edJkUtCOv#DiKrKl;D#LIB-9xsssr{9XfM%x*X-if^n^#q>} z?rOn*rEzUHb%+t>h?kIj!gx|iWe>9^aGlQzWsUJ$@X<@*W#JzIV*o-i{&Jifyg(GZUP)^7YW%VAD>VOXAcN3KJFPAVq%?(#PHBM=fcucRdu1*| z#>0cEg3N;rk{IF%PC*FIr9mS}Pi~pr0A4~l=Ps5E)9=|qzi$m7~WPU4#;{;u=v(KYVi7qLG{ zk?vCMACBXwjr!5a&nSMQw76E#ab>jYP{xU<>$7yMb)@j|Z#@t;h>R~dcbJ&8{(7`i zP;=3=hsT5HJ}25jw%zcb!JG%C3p_2(Yns@8!mRyn)uDy@ErmM%DpuO865=`}v3wjw zTh;u)W-@ejor(o@BArq42UHENf$@M=)qENNPM1;U)j_C&=g?|f5u8U5Ao>DG(RLRd zJ2Ly?dWavQ+4Mshva2_o(IeBmG)v7{t0FLJ8}&uuG1N~cbohh`$*1x0Pp01gl-f^p z5v{z3S}?hoF7q05_#C(OWk4{j0;cll)j>||=>*1sT5Z_Qov=rNVxYouJhfIfw|HfJd*cWq`E@ufzc zeLB!LA|e&(hl(>=Qin`jPpt>)q7vuo#!!OM1NC`2AxR?WC4Pi%;ZMMoL-~HyR_D40 zzNX*T1OG(D6jHw|SOB+E=LYGEaPH;?uGt*E*OdQRjW)jY(qIH*OAFBo2FA)4IOykC z!G8!bxCJsm&gFC9oPS6fIgClCar*0Qq4fOh0Z5Mt(t5HPH2q36t48`WE4c0Y4}KsP zr{rMOcO!HSsL(FutpQP3wBCck4k#JDJc^DptziKq^~Nwtv6sLst|eHA%hx##SgQ0X z&E~1h6Fnxww?EKF)$v5M^I&Sz3vLM^0d_-Nm-wCUyjt##vhNgXJ-eSa#s{c#(z46x zi?K}0G9FE2D2q(*IVeVju&G7o1!`mw(lT7f!hAoY9pyq{#bUIXovtUa%+xypb#;sr z3r`Ab0rEpwWJ|zBH=7NSq7;1dzbn{-G&y>kZ_Wq;#Nzm}^(5M2J?pk|zc#IyJc`4C z)~mvG9q^mNhy2hQ%)s60)|S@U4RaVAYe|+@Ves4ahSqK8;q1+HyLJ=LL+SyqLhPk+ftGiJZ5dYXKJb)0Q*C(*l^DkHlgbZdI%`L{Dn1wPXV>M<{Q zQKq18%{0!vgNX{oIOL~8Eah|%I-El6UG z#gxt9D=7uM^iL;QhT(G|dl{u6|oEs)vt7&p@Woc%16?!XuPW zqX91I-QaCI!CpczsPxX}7dIr(hG5qgurWkCpT*j}F@Yx*Lel}Q%2Yp>;Rb;fdGF`^ zmtiVb+a@B;r@elpRvPMg!qBXiIS2$wCeb*T8HbPVbz7ugGwA_z+Ld$Mzm>zu)R&}% zI(hVnrX%u!t)hM{&~KZ`=jn_aznf!+7$_gwuOT9&(dqKQBKh0BG=JMK{Nv)JZ4ZK& z9hD2gLruC*X438YHq1a1#=i61HKzO$I_hE32_bS6$S+hcQw#@n=OU`W41yM}H_y89 ztKq}4fWZM9k_7k&5&{=s&b8y2F5ZoNGC5{n+)u8*Xqo!DwT|_@<1RXE;3-+_l{Ijr z1TUVyP(7|XuDgF_us8#}2O;Qty=H6&Xv zLu%(%Np_|TlQ}|#gvz2Nfi(+A@`jFsMoLaf713h|V_tzxMv~aehJbD43QKxEEJ9C(5um-xy$0Gw3wIXDIrGDO$IJ6Q(avt>S>WPl zb0~N94FlF=Nu_uz>Dj`pg8Lu&#}mdnm3~d~}_0*1Ssu?;D)!B4@014o+pW??-ZQ-heGsBkRdYGAf}KjEv=f zS`)R)4vmH<_Z>v8-8IHjuz3IPw0=e1m30C}$~XgEi<2iz@7+Fx9Hu5pEsRDBcQ5zR zM_a_bGWH!;BHT~)>lwCdgMRmhs8s_fYpyWup)fgv{dvg>0W9ieB_@If@BB)I2Cb}g zvKrN?kTxz0`W49{80Xr6$NiT(L*fbA4(tKa;t)tlqLbaQs3|0r*qhVpCWmL`2 zaRIbkzK!G{_e*NE5wfI2S8|3fV!xn2Z&P)LBV)vyt{^(nz{@p)i9v&C*Z40Y>nMBY zqYN(8k?>eR?Dn9sk*2t$+#$~XCf7hyvplbEmj77~n6D)pLR4s_5ozKj-d%oXiIxvF zwb};p6#Im*idj*_K(S%}GzM`DU$FX+pB5dTLBNQJh$sT9Rm`vkNiGxq!-FK55fa-U z^01O)fMhYta4pT$E8g44jwhr75>)Z4+; zL>NeLzHClTiv5pvgqL0#xIQ{6(c-3*%j83l5G$-Zcw)PQ!VJ+$54QL2c(r<5nR2IX zkw=lMpX+ggWhO7FpuqFb#`%n!YV!O2YXSCbMX_)wm`tYE)NZBtLjhv+5oo8ij=5OT*3$_ja87JyuPNt z0kZ`FwI@Bfo18-zdJl;X!smvN+m!X%5F@1Eq#I%hLPt1W9Ta~(L~=c_`1A9UVwFTR z9=>XiQ1^Tb5oy|GyW<`s1?=kUpmWRMD`4lL*0KeNvkLy9jbicF4jR;;Z`aEO(eHkm z^8n9~r0@H4%Ndx@_q$k&N2&181mfBWIZl(hXZ)Ex_m9)86@row?6ptINgvBr{TSlm zqy@c%;Gd4f8@{JC(<2~4Q&qTFI+-#R6n<21uIw(7(~@cv2~KBD;4r=K!@ThMAJFzA zM&z*z+5t5GE?9tGKsp{yambl*al#VXvA2+to}U0vZ>IA!kz4%L~EBfm<{%J~$?Wpl{? zoXPopzUay<%wpnY-C_hh;EJ&WlNI=+f6ipk{09S_d&QtCe+crPe)gl8<@-*`@t?6$ zI&l=R-|GH|%`k~K_^7c66AA#qh<4LVAItf3r!k~h|3WFP)o(}?4dEF1W(HvB2Om?}a>Q%uROGoyr(l6qKSI0UvgUT&9~^;6CkO_Ymhj(;z3-(Vzi^u058~CG zm`G|>15n24IRe9n9i`YWejQFUezV0-4E6Pby5OHUhKtd^<1~BAw#=Wi01E~AaFE{O z_G}^>tY|#6+Out7c0=Xx!P0M4%qSuFSQ|kyDcWLF_KVw2 z#T+i_|0t^ec0OM3kAS~i>3>Vq%94%1&M@)o3!ypll!QmS7o0ihk=RP2oF+1Z`cEzS z0boUEm!T7zgCzSXP1hgrpB}vtL~by^1z-OcYZM(;ZDZze2iGE}P~NcVXDq#TqZ%-i zQ?YWU*KyuttxExFYYf-Eip2oF#h}BiM#`F!BZF@KGP^tgMt(&a0)CJ?uZ6 zEvma^k(2ZPNE|5FaeLHkD5!SK4!+um#gZ6#LJYLS4%`)(HDhJ9m?2QtEXZv~Bj6Wu zQq9W7+g+k1-SXu>HIpve3;lCKaM`WH{NL{p3PRObzgH4sh!JPv81l>=Ici1(wRCGx zzEmtEOPh?j8LzF~T&8QFN4Kz^oXjq;bmEjmy9hQBZc87`Hy$|q(P*ef1gei3^P+{hR4YW{3Lx#InO+1zFUn9fm9OVzP;L&1JT(azp_6 zw!5T+>x3qb@gd(eLgm$oA>e_+J!oMKFFo8F!JttX@4RqJeU+4VcFo||wo~H;L}84y zYMIR9niH$tJ5A$I$)#G<`M5g)#TGw5b>OT<+Wlx|O$X3Ct^OlD$xyEtvU24D{ls(G zhHq4NtrZofZX&pY&s%IEbB6SFwYL=TI+ir#dOX%7Nwr83-ieW*{AjHu=WUiSALUY{ z42&*hgb_qfY`(ZUP12sj({1|Iq7wh%!LGF2CGnSov@+|31XbiDkNERc@(8$2gl=7{ z%?v>RW*-wauhn6a>a!PZ7?OTU94HmMi~6+`0&-R3Q%IbZ$imgyp~Kkw!bY2-_Dd&x zUZ4MI@F*_rGynU9=@8%WyOZy630-N*9wsqCe0P!V{j#gi=l$Vf~If3-WeO|QlK#aH$DAXY@o0Il-a(cSv<9Op0b%bPfmvH^>H^9#> zJ(vnkYcnJ|%CriMPFCSAavKL^|s+VZ5xR!lj6 zByVy;9+EdYN1ecSj9iRJn#e`qwXGiC%q+A@H|#cWGFgdc>K*;Ax7?G{4ZQ|_I4K2B zG3=P}rkEh8RWh~jf^`5ztYsFM9kPLs%V{AjJ60h{J7G}q__kg_jt8jzm%e-Kz9gVL z0sV7h0q3fhf;;9DW>kZ56+R#NT?qaBmnHY529Zs%jU4x#(lj?nHUPqx?|JjyNbz0* zrTLL(2X2PV3N#CI=VR2(`IaJIf_-^aTI6mh7*f>e5C#X7+xddN{QqjrAnA+2RjkQy z#rJx?hdI%V5+S5O2SZyc&2hDQ$%&Cx`w*0ZNz}CBnYrD7R3?5Am(X(_fG86DjzNW7+p}m^Ll>Zm2Yz8&Ga)sTIwnWdzAiv6 z!RU~fY9x;_PybRFvDdj!C8~C*atDS_;QTHtwbAh9k?L=00g1YH>$Iq=Tpa>7DC+Nc zZ1ZUw#VO+NdkxRyFWqKYJ+t4N7>rRo<;K-K70Np4&`1Bu%Gtxb5sv82kuKd+NKy1G zR(p28_E9CZrcq|l_&BX8^(4tD-osFX%)lkj-&mo{!}0JihO4=17I^(wpSV5PPv428 zrRJ=1xlmJ%uPAba8iaWW5Dydrhk*s8v=r$|Fu=C#!FUmeU{$uVMZOzqI5rnBFV@2z zk4rZJg%TT^paPMowK@k8uk9#;8GcWb5YLhkSHwdODAuFSOq5H5EDz^svc z9uEFH5d01jIA@uyf=K>HNKr|sqjpfnX^cgb0{*w_Wq)sPouyEKN_DJl9Mgi3O7Ux_ zrvln4af$n!3=bbgB)$CO>$VBn4$-kpy5>LB+&PNb-QfhjQY3}13(4+i(?7N={kVTd z%p{G)J)(>s4-h=d;rMbYSZT*UC(TIN|EEvU@MiP8Bb3S8>s`v)vDsfeXsb6E=*$7M+Na zpj(Qb#fc(Xweer=?gSAeJ^8fQmi`}l<*oGLzm={hT0X_?(JrfLPKZhrfOI%&+_zpm zT&b~|hD5O=(z#3)cx6vUVOo7cym29ZU=3hKKl%mO-L;A5Obz)6qk2|oy=d3no9;C5MzmmbOiPlwW|jt9QHbz-4QdFGbbepp^FiB(D(Rl<{Sg9>Yorw;(P_ zE7qE8@_POlM#tVVRgAXo!Wy-oiluo5nN{;yDvZp)qr~zU(*WCu1#YL1o6H+P{ZbD0 zms@B+18ZKhd9GH{fP&57l}Szi`MDY5g@c((nW!nVM_ie*Q0J3f#?7sRiQ z+{*I1(I7#MmE`f!ElM0`RT(1A%^Y8-pj&PYYQtKd9RfI}GFpRyFqCuXJfq|WGVTsH zU1meQpoUvTNTkrC8udku{z(A3R}k7#lkktiE#(0a+M#Fiu`x2`S{QhC1n;G8AHL62**F$(8S`@x$@4b z6&=1Ppa7n>$pAkmIWaV8D_ndjlE$VFd|?=K_|aeq&}3Y;vZ>PiE;R+7TQgi{ZJ0T1Es%kh05`Krh zg1eEJSZwJ}V1Jmc3eXLHa`&*9K7q~HrAOrTg1T;Xd{qzbS##0(m$83ttNl&DW3j-D za7zcJetB@knWCETzk!c5DvbYnHk(D<1u&Pu83=tx0+7T8Y?dVG8tZ}u8iit4MlX&h zF+m+(4(%i-v;v-~QtT4vyVW4( zbG$K~4Ea`rs=&5eMY?5RhePEyN_VqlT0TsA^U_O-~!Z0 z=n6i6B&8Z45L2}ytHeVTV!NP)vkZGjFnPMELFVBcVtMjO51h$hn3=#9Eyn`T4q*B6RT8wscq&nn-pHI3BZtAVhKNS*x!3sr z{5CToIuB1dJa$PSEQD)>mm!gfv5stCt!TWs!dz994{rVwwoq@*_a1HHSa-IlI0Z&h zG+zRkM;d`3h7lRDEUP(`j8tjn3=S7{9(1)+7pjOWiQMbZ5VD>t`~!JoEwAeQv8$`t$BiT;hP~f`F0%+CauNLV=}EcLR*0iqC0b z_$06;R!6L;t5d|skTcp|ThYD@>%T!Q*e42OgOHYDc7kq3qmU`^I^2{t1w|N>RSMIf z>73~$SW5OP?SbdOk_T|5_6)=aFqfihqZdG=f6$~^5Jz)nk=v3mHKdky&W{IGb6a?bkNB9C$Nb<0Q)TY8V? zeZvivN{k|dJ#+RfCCGDPq?*0$80}mN5i<%;9U)~#mRIK*OnTM#+P~bGRpaY>guG

Q?7sF&=ll4^Jv9iL6)VhVGzMT?x zGs*^eaNT~e%^*qaTjJ{KYC?a!w`m1NB=~|;1n&3u@-nQ&M?ZHYIdYcjTf5WvNXJ^# zXpt0!6!3bt*Nu`S`Rbs=1#p*gz%AIMs?0x|;t%2%5I&MMmAxNf(WHOQmZqyJWDGqT& zpgH2m=~ixkAvlCwQPk@<2)>0>)^lHpYJbu+e1z0RQA`1q{Xb6icO$_e(SUJO*)X`g zE3Wu|Sl~2h10K}7Ss0Fp>N>Iv(jF?64r#Cs+(Km+-Vp>J4O8UFGt&0cRSUolvs$lL zOM}r*zm(j&tBZWKSMBaoe_?T%WZgCY;mK7>0KO|J0gWz@%hB1ic02YP(F=o-28S-< z;B3yAYq|a@F@JMbsl`@qeyGx4EAnGSxRVJ@3UKq^;jZU$udHLwVWX^=NM{4P zC}Y@gaRRJQtq!&yh*d6Dijnw?mR4hl!;tq!yK?}|z{V+grnK7>424mX)kJ@nQm;*B$>L|y)mf4Wah$MBt#+3Lt4+ELsLD_N zty}=TcS&EL=G(iMo9$0F-=x`M=a^N2;SOY;gbZ>0S3QZw%xW}*y}cn8CdabkYVo;= zMBDjCwD;ma;%=b*a3@Li&*cRyHE|ki!$qAA^)I9aT$(#V*~Sm7NJ+@kHkK7*#NA=m zL$~wRgJu*@85wASHI8KiLR54#TsM{>Vt|P@>hU2QTl7kH))LU2w_ss@69%i6JzY{<&bUU-lr9C zf7B~0sHu}KSB7KNBFWTFvQu}W?L`b!J}ightP1ZM5WTFzv5aR`ZH?nm5wdWvaG#myq;gkmYoP@0*z1iB9F}eO=RX_W2#&hCq2>Z6w6Af zodosqJ6D&B!{u>ruz0rl2^F*pcSImhCG~yDA|wm z-&|h{(#qBb#+C*`q$++F63aHYO~3w#d<0oo&CymDsD%TE!NA+!M$Cx(ewJj%iEAJf z?TuTiHFO3@CEblz0}FMtbpHd+E4&c?kEaC>$~j@ggLH9S=vE7H3{89t~1dm);R z4fgDhSbcsl23bzO(QdO!)mbuuU@IsUzsj=bRR1r(u}u>BIbjTYm0mlnaI z?p7TJzIo0s2nJONaO=T(^YYTj0kB zGveI=iXiHI(9Q{O#cD_s3Wcs!$EC?sX%VcR)kphYd&C2?uL?$v2R7<2;_Qoqt$9~u zQ}w|+ke_i;`>d60@7;` zSyuhA>qAaGyXPoV2DfnIB{6^rA!d<$=}LE0K1toTZhs35L`yBUpG2u2K6KsDed@`( zM-++YHJSBajbt!E*bpn%OLW@8jZltwF051&hZGavb?xc+lY$g`rNpp#A_`2C_IQySWz7-#EvY;K6Il$YV@B zklKHj8Kx>I0;yz8&uHwG1=b#6b=v#90nbW=YhjxW|XREMl~v2X@)ODT1|U&gVe%cnO}As_}3+q@JLf%3CVZA zN97C(R=8|1-cRTT9?=2kP1ZW&Xh7hKENK;d@LJC9+ z_N!8+&R6u|P+m~hEjzk@-8-ce0H^MlY@}6Cx`~;Op8AI!f@k-vcq?~9Ko5adAl&Ml z<@n0zI|ntEreVHI0=F_|jpHSDPa~aFsi8zPFSw^uUE{){egyG)dkJ{}XSeUt(m9Bh z&hmrRnnzRgQM)pH6|Q^Kt42%Htqf&B*kGg1_54vdMg)xqxSq7JOZrG#MBH8$Jo((z zF`z;dOi}Srx}6HXPY0d)W!XTW+CKB~qE5&BBjpCORYK}Aj+j?fgFz?a!ABFaIPI~s z)kXH?XNo~?_uoM01#ZpBIOvb;hlhRs)XTA+M9@O%Ahb^rEI&tC%&z7y6$l(ao|q>r zxit}XQ%|`ekJpWc*}D>B9rV9iS;~?Q0VccOLCqXLWOQw0vW%htn9l$wTu_#YFNBL^ z8sD z*&`%n1TcT|z@iOHvks!uQ;gr}lu9n+ES0)7KxtQq&_JdNN(w1$#9%;3qt*7oIU)^_ z{Yv?qq5~adRC&Z}@LEt5o|l3UjJ*0gdnyrNMn==rj{qVKUU}{O(XKp@IOGJD6r^ON z3*(b*6Y|wAR)FY{Ck9W(^%blH7abicm3-$L5h6Fk=NDN)wFWQqy8&?-HOE}dP2mJ& zI2V?n9^wo<$Vx~61H}iYz>M{pW?v09xOeOTqrMP>I_Zc7_g4vVkyBqIzj6-D#t6Ic z_!~X+EGlw(m>B%II5#8BY&)+mET!ArKC>w|-&lV)%dVk49cvRIxi)p8#>BvqCfGl#AY=!?p zD|v1sa3ZR&QSK_+z5Juxf6InN4FBb>(Zu(SL7wG#S-DFN_2K;u9hWZK>(TLN(~jd0 z{VtE{Anub`Q-Yt|u6Do1JsD1$PiuQ82}#ti8%%_AWx-12x768UkHBBznR(}@9y*2c z1emTIVi%D}kgTRsQ*<-EU5TOSFnq`FIe`Z{vn&dxn@q?b{ISc#Df<0d3(p+_*mUK# zv;XhA82}cXSIAW}>-pj3!3~|a3Vp2ejS8{91)g`-f09$G@z53ruItFM?6)Hc@SrO;Rv zNDl{E>3|~Blxos5p)EDFLRm)kq-I6NIGvPD;lI+X6=nzovAZ=@=eg99e*@cG3P|yS zDXH7OpIlA0$cR*mO4Hh| zZqt%ycFq1=fWkho*u%u-dG5Cz7}R7#&~{YM3k?4!DAFN{sZVIwF^SWp)#Jia`wSI9 zCJ7lp-|sgkOo)ziU=VYNY*!0e!jY{W3RaS)lp)~_5SGHbtrvl+|B=e4)`y^T6}Ve4 zo9e7YGjykHIo6VN7zwk> zlHwYk58T6lzSkPTyhO+(@j=rB^9*yAWYnABSxp~~rZSI=;N4gxH6(f)xuOlptMZoX zT$HofmYDcySULT|@CX66%!}Xk^CwT+Nm9d>un{ZK{E%xAF#4sogMx#6MJqn-Pgs#$ z>h1xf&WK0{6ackktUpc!R^hYbXG0vjN$@0S=nIh7KqgaDfMbRCb2#n^@tte0v2zDU z@a1%96IC@Uo_q65M;tlA^o%}>VA=7$9>f=}9%-60X7VLw#mtWqt1+*?%MORa20ti- zmZ3e*nXWwe&SrJ6L1)YzuayPmLiN|?x_KzO6+*+GX^w^HN5AlH`Qw?-ECSbEzxr>u zdt%QRqfJ#@j6sf(8&n2F3tpMpe}n^6;488H@dwm#GB2|5g2dY*ensAUKQLmGtF7! zA^)#j4J<@ax}^2(-uIlcpnLkq+$U|46skR_w7!CmY=fV3cG%IvAWdN8^ybXe@vqHyUw9|4(^e{TJ7^^NqV}@c{;RE$%V{6nFRH zUW&VvV#DCYwNRWQ#ob%1P^?&Scej_L_qpeu|KOcp#y)H9y^`##B;O>f>riUCJE9B_ zYwmcxhSZf1|FZ{dtrbEKQ8f?C$!=SX&H-Oke9L-+tX&G#`q`Yh_q9_H=6gb+OPBL{ zkfDR*_{&0_e8LJ#ifd|dO%|OmC=B7Gaiwil=!ysMd+W*v9viya<8nuY~atROOE6}3SVryv(f~XA1io*9@FQ^MJbOloDmg2wHLBT;Kc*UL0=}4>>hi&n6!AP#T zigu#l_?Rn%LR%T}V4yS0?XRnYzMuKKiC`cOXGknD14rd|GeM-jH-!>xb`tv59>Qdy zL3SaB5}2V49LBb0Wo3*WlhwvDNp(N|F*HQQz_`I{Any4?>Q50?3z5L(pZS9Di^^DD zRjXeSmu2_G)SwOBD|oPMW&sfUS_Wj-*~3soOkJ7~{y8S#o%Q+aRV^WdNk{S7J~6NL z{YXpd{OarX(vD<&os<>?M_mLmiMz*3Yx!TF56GH5rOhnBfJ4Q?q4(puef5IqC+J8+ zu18^%xC$x;|E|#G$L_E+=C8wBsW+D&cG4LcV-`%sTXlFW1Z!DKwVx%bXKy5TC(^vd z5PIqywB@oleyWCD=2ne`j!;;2?mJ8DKe(su)V^RgF!Bv$Mgu$mHv58_e3>dZt6&}& zZx>H^3mBxTv{xmXQgZ@r0}sW2nkF%mb0d6v_6ZH~@wwxnulU?n1BT(L+9CzIWQFF# zXa$K5w&dY|UL~;q^a9)^e#u#b;2=fu9}6LDK+DHMYr93!;JA%#QqLE+M0b?fFddQlq8@}l7Q z&uhel?r-tE5Vy@I+V4wrTj4rN#r}3vrEhb&u#jvvPuzri2BbbfFay|BPT=ARV z53#1Vg7sJ~I0L-ABQhK$UP+&~6xU@h#{@f;CH2>QJrUykvUW^J;njZoF8RxQ1;D8t zqQY#`UBp`ytZO=nGl}+ChI`M5vrl0(@3<7K2qom8FQNy~Plvx_4{dzx=*XNpgPtC3 zEdh`2uH}ow;iV?|I{eyerK1!Qv~81!v+v{lR`GK#RVI`|8IGQ=r%zYU#F%VFSQt@J zoAGy~ue^$K)f!U=do&R^l?kBRWJGvgPIPYmwLV>bJN;)+b(c~-D#{pJkFC?o@#z57B1r|v_pUV}pS`6KgTEQ5#7^qfn{!@gN?RzJaefJi zC6T;v27HkApdk>o42%%L9TsuXd4+`$L)xFv@`;^#pq+|yduAF=9&%e(97i0~L zhhi)Dnj%h{Q1Y?h-lh&4?TbkMYtq4EwU#x+*Am=>OP^^H0w78NnD5c+5ggf!932gY z8YVtl_T1h-fKkOanT17_K5?;+qAJ3k-y3*@Xx|>g1_qE+Gko%Cgl5MM!0iZ9*P7?v2 zzN}fR!nysLTHLtj@Hg;5%Px%O1WUkw@^f|zVgi2+kWe5|?;-lr)L3FgF||hMPH+|! zx-0k<-TrvKIM6oU>H<%#hYVXfZH5JV;Owt*q9sGzU8I{)9Xze)_Q!_tEDV+? zb43T0VjR)9kwzPfTI zZw$A@^!v^;jJOyN4vV+zcr{|q=yQzdR|aHSk0duTxrV*Bo^>r^HN1>$$`PDo9zM}B zQ%+Y0c0v(o9ecs3U`UJ6Yi(-b zrSbzUsV*ePi$eS-G)VK!0i$Cjv@-wWD$>x_t<^#P$8{C)7U|J1+vdqD>b3YU1>5$m zB{e6s)d-k-Elk-~x0dfhSbZE(GrN1~um?CpunAlD(&yn}6IrE((Qn?X3jesHx|sYD z(!7L2 zh*}N?xc5HSSZFzq=S4*VkX^jo6#cyx9qzT?@ZRSH^}@7|-;wBViz?Kk)YZKoFF2+P zR8W`g=*7o^{K9!HEm#30dB3obUy=w^Fm>sv5J5|s3`sZXy%k%hyRi4nguyFjX|8H z=bs@ai4;uC0!ioal`UP$KuMQLkMkXu~+t^5%%42p`Rn0Gv z=t;O|IxRP7iL|uIGTBXRvhOdp+5%OqNqv$1HF#TWxZy!#E?7v+{g$}j@u*Htw z-5(jf95Fr;QO270CEgjRAc^d?Aez)u!wUr5LrcS2Z)cA-u-`tC4rG57+FoRIFA}*p ze#(1^nB(ULg?i5tX~th{6HSbU_^|{V#;!^xe7xoQkPM?IYipOEJrEh81WQ?_s*bQz z(*BA`RH%3IOiA%nMJp40ZmH%3XU!_vpT|?UZikrG>S0N{TUaQGaGA0~s;FhP^R6$n z*F3JlHX%JRu-O3|s#zhQLp>Qq8ch1`CyK*Tzv)Z@t68v@gqEm^!6ASmF+5-eVQiJN zVBJhiMQ{SeaV_6yqYO=IIP~M1O?JJs78zD^8iU$b(?jegb%Iq-2KyEM<;cB6hBHJzF;eUNEZ*;pYD}v4U?a

!zVFf zDhJQb!wV0-X8Mssui7i2_3?HOda#$sScov7lF5$Wux!+?l*U+U3CCOpsVU&4DwWkd z+S~*jOSo9w{Qw0HxGAklsu$CP_R{F91>@A&Ucw7A(}G-KaGaW~suUx-$tgUQNCG7M^R;fS+Cu%#>3N7!u}Hw^9#|*rt2iXBZDcQ z)`x*Ocu7<^eB+Ucbnd32H@n!!CXZp3lLA3N`+Q8t2n2dmiAs;{a}?epf@U2B=K(34 zch$yoUlOP48$kX9qv6e|BfD1U&u4QR%NhvL1vmE>9F~5+O6ou855}oT1OiRbYmA3N zAQhoaSZUcw+sO9Ad^kV>h$K8aQ+wI3u$kHP_c!L60FXrWtec(;{J^o}|;Z&U1!AR{w z_UH9O)*>SNNOF`y44ErvQTY@dsntzcU}8qqO-$?Yz8{V?WCdPLen?O~k`DA$7GO5Z z>zUvB^p#^|f*}WvNeM4ZQ_|DJ77M`|4bO5+^qS{pDcMAICzxV6AlT5m=K>G>+;zhE z3!NraoCIGpndOSsYf3tnnM?3mZ_oN|%OT_PUZ}S$ zgH62sXzcXL_bACE;ApSb?gkB#dVG)h1FzdVcU1is^^>QDXM*6<5q)~o%+jymun`R{ z3d%;Bk?fQaWl{ZGFq#ym5ZsVBqv^=in7CY&=HPW+dJ-tS`7IaqQTCbEO{d@%1SzQ* zq)+*H@OJ(3$WPkmyQVdv zN$F}!t@=Vv93M|bZi6i{Kt{R4uM(Is2_1>mQCY?{O_U^6 zc-sK<-IzlTWNI`HjD1e!P(o{pQHamS!%WJE=?x;eo%kstizRgF=e;bOlY}wo{K?zk zcO~*W;u*Y3Yl^UbTvMC$CrI$;+jGj4x-e{;M$A>PA^zM`TMkr|(o5pGhqTqr8g>Vb zv*12wx~MPSzI1<{>Q6TRwvqM9g{@$Mk&)iT_*4t=M_eXPwlK{l)1jVRbX=TBHPAVq zl>gP(lXv(}mjk|)0Y+-Q5QGigxqw?Ga1m)?7*e@mgK7$g5u*`{aVk}yW1PsvcBtDD z;c|+XQGvQ$5+{OeshwhWYWQ9T)FTM>4fAxNj8T*1Vi!N0s|wV!)Lb7`0h@W2HEMYJ zeEXHHssgN(w81Y#97_P5MXh1G$K~oN+B&u&Q5`&x+Dr%6Ep|dz%KG5WbExRf>ID5MslH7RC)GQ>eNVWsDVzCc z;nF)eAVuD=h}k58)`Hbm$!_+@Iq2<6kT@X6&M6TUf1$9bi3EYI5N@Kq-6Mz9>_W22P1}2?hZ^D$+);>6AuvPFsUKgBr8m;;raYcg!Q+`LqHcR>tw2`p z5m1qbyYY z<;FMA`<<5^kSjxvN(H-GJ-aGR_l5Ys;2=|!a_r|cx|v8w)^ol4Zw~#RQZ$>7qWU2Y z;e|AU91J?3UBBVbS=>`BmH%bd|c`2Du*FrsUS%1lw8yr8<(aUb`~wF6FKnFD*dWrPnDRJs!xCY;kBP} zobXv9wA@+!7aLOjuUnf`k>>|@xZb2ycRrOPnSt^;{ObW|B-Oc1nnrKjE+Gb(`^zvS z$&4Nv24$ysJ6?mO37tS5q89`_^{mYNCF5?ePX z-(55NS)b_Z5mXfW0g~y`rDM5SexOzVA{~;iR(rrPthLo4Z|t{8xU=V{7Vy+_G+e&d z5$oAq143FiIdgLBYV`&FXj5%}({EOL*@p;0IbZLsx|hQG`9?&uTJm}Wzq$kEJ#L|q zxFcN%q`;_z7iF@U$vNRWN2{Et*u8*lh8TK-09Z*q8=rX!a6g-D)23lMJdOAPgb_X-_n|^W&#Bwr_>j&OF}HG{_T) z`=*LqN8SOoXMm!Ll#raIYxq}z*E_FAvRn3{O$Ti(XRif-29cx>F zvRtLCl0^K`4oT&v6+8jj;7}|O?&jSc5S}cSVy8rDdCTAJ+qaGc5*|;4hoqELs;BV# z8IC~A9U%c(SUOo`Hrd%ArS3{|)@?}yPqc|Rv?8Hurt@B<*HlfW+F0@o=U9|uGfYK9 zp}gj}Ktl|E5^yiHxWH&gG2r~2pX-u})mFN&0&cIl2|xW}dWgrxN3&4Z;!OWO9kZ^9 z@Q+mOIw_Tif|2*KII)NVswcNX5M%_Z;qNf^XC$*PzZSYf_r58Zv|~#JJxpeW_R<#N zCd8=9N%SB3UV~4aUmMdbsARxSJ0&GVteXdFzxQvO#3cXhB9RzXKdfi+SV`_W7*GPQ z<1p>#eVD8RpaV0hy;TE^s`vdS83dB1I)&Q|b{fvpAcK&%M*>Aa+*~mG9R;6!`_;$5 zp{Olm`jdVl!<@QvY5!(oEQfjD=-MY=F%~MXCt=8k2)etC^hm0Y4UG!g^pbeQ78j@2 zIgf+CR6hBv2x!h}0H{TAV$;p5&N~q#dcxY)HB6q8{Wem(@l<-4;^zaW z_Af2|Fj;=X<9cKOX}cIaO>{i}rBI$LNdRz=%7RustaW3idHUDJUg^A2viuo4Nl#5{ zEw!E(cukInuO(UuEq}#Dj2iKzvmgT{Ldr}`CA*^~0HTkTX!j{d!AsT=UYF}1#4u(d@p&jh)!N##hi1)^;hh49k#YzZ*IkUHk zGbgUSIOoEK?xZ%z;=ClhQs5Yb-p%BnptEaU3a>-lqOw?ss44dOrD#(4X;xc6Zs1Sm zEyt(JPs~k+o+yxz%-AA;E9yr#0L#+__RX%h zyy9JlaguJU`4Hr zFTNG395ktLk?|SiVdm9@eC+A*(6A77VCe2S|B!06Q=447hvitE1%f)EBb0c3e(e!} zuXeRi`2d+iK$k!I3BzK{5T!{=`WY!uGl71U_+HKEgIU%#02>JFPk6~n-U3OYCDFy^ z+p=lUc)T1i8MFwzX={DlEt^EofHYwgzFe&k&KQx5ovV*Jx9C;u<_9(a59`bybJ;#Q z9q4!e(2PXce>*u8k5p2GELo(V@NEkmY7?l~O{!iJ>$u^C?XCDFNY*lU*8>)se)wpY;-BCYkkmERre~5)nY&;sLobY^O1TYz2Ma_ii2x6 z(rerY_-u0GzhY*;1wp+~FrtIj<<-&u!<*k()R`g=1NG1KDG9(B=zC6ROnMl-j@b8o zdKz3C>tJNb3Cym`P)hfYA@}V**-dUj7^(+Oz5cA~U#x$mny32}q%#0L-D!y80nnv| zD!BBPGNm$f{dBd&UznJh$KV)&4DRCz2nM6M2?Otng>8G>%*g6K=gANi!AY(LcWPu~ zGtXmaPXB-z;7Ym-#g%_s-m#58ue{TSvai5h!tBu$Ps+D~46dJ1O+s4T92}4<=@@%D zt6J~3ZwHjkluw^i0+BNMW01{WD$`sDkIXh46xP_5^YZZx<;y=BY<9GdCzmY(Pf+-w z7oUu;#%CgTHyvOd-%RSM2nHdLGpqV$Koezg`jTN5QUUQyH)+T&I}Y(mY5wJgHwRQh zZ`?ZoqAaQ4rw=n56L&XP8sY|;4H?x1F&SJ2SYoF}wKIA0Jq1^qZ{Dq|mL@s*{)e>H z0SM3id)*>dtbt@gboznyDcyfrJbxNKy5evNG@547s1U31GQ=897)jk!GM10V9!;$t zOFN&OF#2o+A5ZOz^2FHNNQ5MJ@UK%6j7uJy=Nt}vl7irC`cZ2VtICkUh&hTBZ-T;ydU;qy$17PJ*MH2`vxeSofH{VU-s1;AwA|6)d>sBxv_vrCIl}J(4 zO?_)+DtOV0PT8x>P6h68bcFT&I!#ak*UT~u}kDu~;9zTD|Y>s&S^wU`~k3{Tz%oF(jE!v@e47hpkc zEc>L^UMWwm6vkwID3zSR%vkHeT9qEg1*yMY^3S4$i!BDe3#jhax@Gf6C2hldHP z6c`?juRDBUwqM+=ysm_gb7|K zDux!NfMfNa8td;j2O)%?7>P1^3F?4v7Gg%48>UQ^KxWWC7~ zxj8nmnrY0TM*f;joo;-aZH?-p2M1*;Wu5>|N1)V%@y2GLe2SuGkJi37nw-E6atmD} zi?!6NzWI1&UWa;-3ecLH#@gcDsZ+3=>`*GNNA)8d1eY-AC>qI8w?(F;J~8c-B9QM{ zR!KnRBpFXt;lbjN%3PV`-6?Ocr1_Z=@|h&Z zDufwwb4Q z=6N(NSpN>7&dTAg>@^p1*n0x*iz&S$Bj^EKQLe!z;{O5v{_;qXU<0lx?LK9M7+Mg8 zsjIZUTJrv32wIjz6rxIeTr!^Bl4dU<7KV=1zbSF^YIsqVdhl^9#d5!KGKXV$B=9by zPCBc(h_X=c!w+;^8j=#Lo?kSBO*Yg>L&E`j$3K?~%g8SBvM?Q62B(HBfCj_40iSMY z*an*=ZkpbDHx^Q-r!muasX@I8%IRK+DA4?xlZWvFo3(IgJaZqL<-9S*x?^>*hy#M(Zq569Zt|fRlJbs3? z#YxzUE2}E@Nw~H_O~LEMfuZ^Ka^UF$9>>HIa2WXp)tW$t;i)=WC=$bP(WOYOV3jXl zst?0oE0l*2ZD9;4HyRfbp{o=ekVMdG1P{wgI77P#-vR*$OX?RxFQA#tpX-zsWiQ2; z**{7&yDwQ$rF1-Q9Ca2MP&Pjq3$Bkh!uh2T+CdMVEBgP~_6x9JTer{qnr)4}LQw`+ ziYWSH@o57p)>E|tV%H6WKau^Ped&)lLIO?hsn2ax7TvYGQkHwfR{HGLJ^quxLs1yn zI=Q`uj%d-Pj~kJjySU{i}^wYRcT1?MHqjGXx37HX9*p zp&y);J`B7{_7W|gbNTSudd{TK;>Iprh>1F#7j*zZvsjdlI58@$u6KST{U#pd9IpYF zN;Ami$pDq=sOj-;Tz<-ZjfF|+>J(S^9%Gw#Un8B2EOv_@g%U-jHpQVpXiKu6abK67 zjPxFeXlqidYPoEy{?)VWQp5OzsxdzKt);4QR_|JNuX*K^d8xdQ4t(N}i*lm$mZZq0 z#HM6F-bS*e5;JpCcHc2)JGTv7zW1wfh6b|0R_H1}5~|S?BgM{b-117&!Y>E{E7#J0#^o(31VI%J+&zN2C~yBYct;_6Ti4$MAw@55m6!FnBkN$pA}d0V>lH=QJ>OYxL!H|=mh7|FQ) zvtJvemZvdBR{M2KlP6VH&>cO1c$RNb=G8`3eyf~EGBn z3AC&+EC2fQO~d`#(9Ph=bESBT)aBe6|D00`DhPIG)coVR8zeGD$_{TbZH+V|x6v?2H?iGdGnbzx(r@KwINq$?ncdPkRdFC8BsUBB&H;Wuj2{}*4Ezq4HAVaGuaZp8r zUKL#>>^ti^9M@}9BRZ|NANGY=s#=b1PWvi?UusrPwJX37_AmXCZgFtf{y67dXU%j= znaNa-1Ky{*wb0C)bmy+Si|2glM*I69a(2mK!WXzYG0;odv7xoVyU+7=mfpzZcd${R zFGknM7yg30o}2#pqkL%!8)X`AD%t8dD&gZ=@ozN~z3MRIPGsTqiv5)5*gnQ3czoRc zmasVri{a(HuH&C@+26MR3nnGeV=zA99?ZV~x30e{IkJq$>+ zxq?had33`?$3qyyMDpjQEbY@MlSsF!0a2euPF2MmY1FZ*#4}RgX8CXdpCb?TEMmy& z<qZrTG)*J}ykR>kBP_E#L3AJ(<<66a^~y zGJv$OE9>Wu1uTUX>*R)-1ROc@i6!O7hhMk`&+|XcQYnwZM@c9MGS8J1wNR;g+AvTY zj(?&%qXXuEhN+K)ln-0BD0dFGQ$}YVS#yM4RY;ckwahIwSAQ0_v>0Fs-*5|V#PAfM zkR>u?y4QBKftv;=it+B z`zkxyBo7&rOiWN6EHM*~8)M_-Q88Y^HV=6Bn9ouu4vR=S-&GZc2v`$kAXu#gWTW@x z>ZbuD?G+KKmy{X%Dzyi6)f}%Z(yu+A;$(C=YoNdSEyIHI`vTLL_+1#Q&yDxa&Y_H& z>&+nD%RvKdahyx>mT`JRGGqL|U5ide>7clS=Q`Q=%FB*AtF2^OIgeb+gv4hv?rR(BEKl7L|*8ntD^a5C^{bI^+v36h^~dcKL}nrofGT7q6Oe z7)jmN>}RMB*h5pDi_7D{t{Rj0u=;(IERv1L6mDdlEvnUP z^jF+wx5jQ4-#St554ETVi!7Wmb$#BXVC&cjWh1|0z+D1(Ue z5k7`FG{fMK>J7f={46@0S~Z_jSo-r%6!FCq42F9mC`Ml8#ScTxpqKk^=v}k-aD*19 zU8896+O>k0x-<+suO~?hY1YV9$kBcLO}A>s+3y0jd20JxWQp4ELp(e^2KUCQI+w+f zl86u|jFx%jE(Nwl-G;+cM=I~yw7AcMVrxKTA42V^Ad6Uk?I*#G*s$$(Cx_?9U2!7R z;&${Wp^f$H$4(oDBW>|7TkR9fQ3D>1wO+=;XAAQqz zax~jCAFG$@fI#XXP1%rfSew>G$Pi|TAd&(EHSmV$a|wm*=!N6!fqNp%@+$S9V1ai` z#cCYl4bnb%(8P0uZ}&;#p$${23 z>FU>dkqx<3Y^bFL#IJdo(H}X{S|BHe@s@5Qx%5jkTmqgaAI7P^E|$hA@2IfjXzJsn zZ9*8Z@`9zFXqbWrzXtz|=8r{2MdrK0qu9;O0?>mOxq;)GUZpzoI_%KYoE(nDEc;ai zWN7BvTgZ^`D73#uBLRhu%?-mar2uG=R_;Fx)yr6|PSto`(9a$$QTbT{a0VGRi*M!L&}kf@c5ruy*;o z-jT{Ab8Hb;Y3@3l4Ej<{N4VN+})*4f&E1$;Etg#n!$YEI{LR28axpW zvsC5P<{HX_9}I~GfO0$H)0;^Uin1=Lyn*N<@4DHZZpq#+gtDFj&s8U)5175 zQ!26WzmQAuOi#mV7j@)XElVdQE{I>gB7;o-EwO(_tAovGCBjKZ*}yQ9NI<9g^=06G_C?yiD+6;vbVp2hdWNrUiwWAb6ia zJ^|;79Ag+(aIAdSl_iClLOt!|hmv<>veubO`A$D;&aivu>X0?SXFI526c!1q1j99S zm+}dp60*TkUQ7zOz7{mSTXa>!J0~u<#F-m~3SH%q5)sjf!0voEqy!pSC|rtJ`hwEb zi3n$KcTQbEi5$E^2w^%d3IgEsePA05d>hdP_p}+ ze&O$9L{Tzi!N!YCa$*D0g9{PypyybXl)a^-`~qH`6*9IHmMpruNx^llUL053H7Hg) zd~i3zKHS$)y<|YaVoB@z1Hk7id08yg179pwccPhAnaKnT+*w?BXyeb*u|JaypKF-r zaa=Z4?u}RdNxD)MA6?~wX`gx{oFg{EBHokLvGoj>e9Pr`mowgqXqqF3@$}>N zrF}r|wSDspDUr=xp0+}GIZAt7_AiTw)(}CD!N3uzT@Jz>`LaCExMf3DSZ=(Xx&U+O zA!Tgl9l$Xs^;<@Wh-}U6+AWwwnU0K_?*%L_BW_7`K{s9@*W63ZVy|s(xa*+9vo+g2 zyh4U|Kh&|*OOrr!)bDv6kPjqmJ3j#6$o0g-@!p4Lt{=;jll-dN+qRlO0_o=;#>}9Y z6Yee-0W%wO0|jzU#^neUMwGb>dE)W1I$5YfwNwP|sdv)g4ane!zzb*0rJ$o#*BI0~ z7G**wx+J5lRg+?5i}%^Ts0I}pG8^di6etT>GfMd@yaa<#@48P^;pWn{+(_pVLV`Om zZG;oyFdlDbUTo~>j`NT@i~pt3J8dL_j#QBBWcM;*ou%8cZ@LH*;SW#F-$|thm9tBs z%O}KaiNy8NGU!uI^Kmj&&m6ovZup1&AqEHR1N|^-D3!r?L3aDkxeJcu`tDyY=J=Xl@!z8<7 z-IW$(kyEN^jF;%rPzutb?uCqphHy?MrWJ&e%d6K?0BPWNM{xD_5zj*RLwR#`!YX=D zfMk+#*161-v7UK`pCUEp@tM@*6D&z|#Ta!9L?9{UxRwU6UTW&Wl2!tenjx=4rvRGC zMU>O4FqVKQ;ncy^t@%D}_tM}S(LwoNCiw~isL~*oeC)*c9=^!%CLHa=AK@%E9xSLC1gA?y{BgZ2k9q)YmP2>CA|AC$V$Z+9CfTLjqB*KNf zJNrJ|o>9?E8j*bo#R!?orFT!X)_E`9IL%X7%b78~OO9HMZ}v^&75#)9b!neItnEoo zA3_sI%{AN5w!Tb<;rlxZf-1o|(xkPnV!YF>ykVt~8WboN0U7h#Ej?tzMjHzdQ8T|Q zHO{_0mraa4W>bHOM69SnX-r3~sc7M#}9OdtXp&eY!o;2VsJxkc{6fx<`_}JRVpT;T)yVs>Q(;FJXe2c>oOm4a{_I zO9W9Z9mj3Tn<+CM2gLRJo^*Z2I?`(AxDi_y_UY*vcV1A{E5SY^Y2Q3iX)JMhR~47% z&|v=``0dXpj4Vdt-TwSat7JqhlZC}8(nVyWq<0s;pVLZ!6K!q6J?4}(uS2n_g}FsfH44Zs#p}L{sv{AKNx`(%RD;=Y|JM`zHsb@Y15n+vo?~Yh(_q%jL~McsbtNN3!i7vDsvdkm%ALNWuv6uj z1=XE&r%vW)DZzu7lH01JTa)-x560T5e@(Y7Hg05L&~7-` zMmMfCpCTyO67|ZAHXq@MgI_FZX8Zi_^BzAfv}F8jh~>oS#ItS8aDaYCFj^05k{Z>p zB=$(vD3lF$nt%VWM56A-iX36pSd{h}?*URAvEH*7?QD&L1CR*nR6yX~_bEXe`~k() zX7noIL|sx+J2*-KVYjYvVi6MUxWXg z&akaB$!36+e~bfk>S_Xs$@^f3E+$k_&W8 z$VGdVuF;$ci&FU*MhE45QY;%z>o)%wGa%J?(n?ru+L%6(d>~It9IHMndgA}y|6ePb zjgZLjsFCVig*YcaOwaC3NjK>C5#bpJ0QX5D`(ZW>*itk%+*9yBCwM;X5*@BIpd6>#*by@g4RIjv5=iVP_rgmX z);oup;f4L=z*qQme5=O+V6JFHYhaz@zmi4WbeJFpOqwXLIW1mnRg;G9yjy%*>iHgj zz$4(TN)``tY_iyoTb?&I6#?I|Z3n#nl_a-_#Z1$2T6Y2uMmheXY3m7X%-mh;RtL(6 zmMSlg#$eN(@FkY&@CF?y>|hUpkklOBHk*HwyK-s3UYq6Y8_ed)*{X(5Ag(IvoHtRT zg01`dM+lI%P>n>@%n*J%!LAp8z zUrf#t3!q^I!>iGkjY`k=Z#-(C9$)M9sd{>5voz*FrM9X1LkIMj0f4Wd&pnA``@3#q)u+BW-Y4GRSN?|;m_PZvPS3D6OV3KgGAV* z64`n7eJbBNtXdoenyhvG>+SOc$LWL0?`**q-JPVE4{(idi6pWwytiR3(P<4ZH&=Dv zdwZ5s{F^u!7IkWdR)0QM($@}}Ym}T@`}~RO`^*~bI@e}-6P1R~-02`)k`giLKQ!R) zi`U_RydTg%6`HV6e6nkqrlrU6lOw;jfoW0_X@a2-YxV2Bnv7QYH*)^~x^x^LYo?|- zr!qhWn&@UcK39hSo1{6Spa2?A$QKd+_xizFXea=k8(l+!fBEnK?{PmxJhghpd4{P1 zUwGaPU|qibHy%{#n|`PY=pcLh@wl2Hw6U>KrM*#uYWaGn%A|ci;PKk^YT+pGtNc2i zOv3U??Q`kbKPTzbLRU(DxHvzmZlQ==R3)3E9B{q5Ioo1bUdV!}MUHmwTB|8A5%Zsa zIKMn_T_FDF_}^!gG5z4vW+`@c7a2`7wi)Div8(mnARq?%zn6Rd1sk5km). It includes both the linear oGWD like that of McFarlane (1987) and nonlinear oGWD like low-level wave breaking (LLWB). The LLWB downstream often results in downslope windstorm that can enhance the drag by several times that of linear oGWD. The incorporation of the nonlinear drag is by adding an "enhancement factor" that is a function of the higher moments of the orography, e.g. orographic asymmetry (OA), orographic convexity (OC), effective orographic length (OL). + +### FBD scheme + +The Xie et al.,(2020) FBD scheme parameterizes the drag by flow blocked on the mountain flanks or flowing around the mountain under upstream stable conditions (>5km). It occurs when the mean flow does not have enough kinetic energy to traverse an obstacle and either stops upstream or diverges around the obstacle. This provides drag near the surface where the blocking occurs in addition to the oGWD. + +### TOFD scheme + +The TOFD scheme (Beljaars et al.,2004) parameterizes the drag generated by the shear stresses in the boundary layer when the flow encounters smaller obstacles (<5km). As airflow encounters an obstacle, it is disrupted, leading to the formation of eddies and vortices. These turbulent structures enhance mixing, allowing different layers of air to interact over a short distance. The intensity of the mixing is typically higher close to the obstacle, with rapid changes in velocity and direction of the airflow and can exhibit large control over the surface wind. It is an alternative scheme to the current TMS in E3SMv3. An important difference between the TOFD and TMS is that TOFD explicitly calculate the stress profile while TMS uses an enhanced effective roughtness length approach. + +### sGWD scheme + +The Tsiringakis et al.,(2017) sGWD scheme parameterizes the small-scale orographic gravity wave drag (sGWD) within the relatively shallow stable boundary layer. Models applying the form drag such as TOFD schemes usually lack sufficient cyclonic filling and do not accurately represent the development of cyclones over land (Louis, 1979; Holtslag, 2006). This caused significant temperature bias that occurs due to runaway cooling at the surface. To bridge the gap of this missing drag in the boundary layer, studies have hypothesized that the missing drag can be generated by sGWD. sGWD occurs under the relative stable boundary layer with low winds where the turbulence is significantly reduced. + +## Namelist parameters + +[orodrag Namelist Parameters](../user-guide/namelist_parameters.md#orographic-drag-schemes) diff --git a/components/eam/docs/user-guide/namelist_parameters.md b/components/eam/docs/user-guide/namelist_parameters.md index b09e8c44ffde..9b7972e0ebf3 100644 --- a/components/eam/docs/user-guide/namelist_parameters.md +++ b/components/eam/docs/user-guide/namelist_parameters.md @@ -156,3 +156,22 @@ | Parameter | Description | Default value | | ------------------------- | ----------------------------------------------------------------- | ---------------------- | | `cosp_lite` | This namelist sets cosp_ncolumns=10 and cosp_nradsteps=3 (appropriate for COSP statistics derived from seasonal averages), and runs MISR, ISCCP, MODIS, and CALIPSO lidar simulators (cosp_lmisr_sim=.true.,cosp_lisccp_sim=.true., cosp_lmodis_sim=.true.,cosp_llidar_sim=.true.). | `false` | +## Orographic drag schemes + +| Parameter | Description | Default value | +| ------------------------- | ----------------------------------------------------------------- | ---------------------- | +| `use_gw_oro` | This namelist controls the default linear orographic gravity wave drag (oGWD) for E3SM, if used, the default oGWD is turned on. | `true` | +| `do_tms` | This namelist controls the default TMS for E3SM, if used, the default TMS is turned on. | `false` | +| `effgw_oro` | Efficiency associated with orographic gravity waves. | `0.375` | +| `tms_orocnst` | Turbulent mountain stress parameter used when turbulent mountain stress calculation +is turned on | `true` | +| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `true` | +| `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `true` | +| `use_od_bl` | This namelist controls the FBD scheme, if used, the FBD scheme is turned on. | `true` | +| `use_od_ss` | This namelist controls the sGWD scheme, if used, the sGWD scheme is turned on. | `true` | +| `use_od_fd` | This namelist controls the TOFD scheme, if used, the TOFD scheme is turned on. | `true` | +| `od_ls_ncleff` | Tuning parameter of nonlinear oGWD. Stands for effective resolution of the grid for oGWD. Scales the magnitude of nonlinear oGWD. | `3` | +| `od_bl_ncd` | Tuning parameter of flow-blocking drag (FBD). Stands for bulk drag coefficient. Scales the magnitude of FBD. | `3` | +| `od_ss_sncleff` | Tuning parameter of small-scale GWD (sGWD). Stands for effective resolution of the grid for sGWD.Scales the magnitude of sGWD. | `1` | + + From 635809d8779806140bc1ef03211bda2deaf792aa Mon Sep 17 00:00:00 2001 From: xie7 Date: Tue, 19 Nov 2024 12:40:02 -0800 Subject: [PATCH 13/19] Minor modification on doc. --- components/eam/docs/user-guide/namelist_parameters.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components/eam/docs/user-guide/namelist_parameters.md b/components/eam/docs/user-guide/namelist_parameters.md index 9b7972e0ebf3..0a0f81eb4ec4 100644 --- a/components/eam/docs/user-guide/namelist_parameters.md +++ b/components/eam/docs/user-guide/namelist_parameters.md @@ -164,8 +164,8 @@ | `do_tms` | This namelist controls the default TMS for E3SM, if used, the default TMS is turned on. | `false` | | `effgw_oro` | Efficiency associated with orographic gravity waves. | `0.375` | | `tms_orocnst` | Turbulent mountain stress parameter used when turbulent mountain stress calculation -is turned on | `true` | -| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `true` | +is turned on | `` | +| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `` | | `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `true` | | `use_od_bl` | This namelist controls the FBD scheme, if used, the FBD scheme is turned on. | `true` | | `use_od_ss` | This namelist controls the sGWD scheme, if used, the sGWD scheme is turned on. | `true` | From cf8101cb6708af6f9fd91715a0c47c446709b3fe Mon Sep 17 00:00:00 2001 From: Robert Jacob Date: Tue, 19 Nov 2024 15:14:02 -0600 Subject: [PATCH 14/19] Fix up orodrag documentation Make sure figure is displayed. Add to top level menu. Fix linting errors. --- components/eam/docs/tech-guide/index.md | 2 ++ components/eam/docs/tech-guide/orodrag.md | 19 +++++++++++-------- .../docs/user-guide/namelist_parameters.md | 8 +++----- components/eam/mkdocs.yml | 1 + 4 files changed, 17 insertions(+), 13 deletions(-) diff --git a/components/eam/docs/tech-guide/index.md b/components/eam/docs/tech-guide/index.md index f93b77155705..10e669367997 100644 --- a/components/eam/docs/tech-guide/index.md +++ b/components/eam/docs/tech-guide/index.md @@ -16,6 +16,8 @@ This Technical Guide describes the physics of version 3 of the E3SM Atmospheric - [RRTMG](rrtmg.md): Parameterization of radiation. +- [ORODRAG](orodrag.md): Parameterization of orographic drag + - [MAM](mam.md): Primary parameterization schemes used to represent aerosols. - [VBS](vbs.md): Parameterization of secondary organic aerosols. diff --git a/components/eam/docs/tech-guide/orodrag.md b/components/eam/docs/tech-guide/orodrag.md index eec7e04828a1..4373d91619df 100644 --- a/components/eam/docs/tech-guide/orodrag.md +++ b/components/eam/docs/tech-guide/orodrag.md @@ -2,21 +2,24 @@ ## Overview -The orographic drag schemes includes a suite of new orographic drag parameterization schemes into E3SM. It includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020), flow-blocking drag (FBD, Xie et al.,2020), small-scale GWD (sGWD, Tsiringakis et al.,2017), and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004). The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987) and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010) module in the E3SMv3, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. In the following section, we'll first introduce the default oGWD and TMS scheme, then describe the newly added orographic drag schemes. +The orographic drag schemes includes two main options: the default Gravity Wave Drag schemeof McFarlane (1987) and a +new suite of orographic drag parameterization schemes. The new suite includes 4 components all +combined in one module (i.e. subroutine gwdo2d). The schemes include +orographic gravity wave drag (oGWD, Xie et al.,2020), flow-blocking drag (FBD, Xie et al.,2020), small-scale GWD (sGWD, Tsiringakis et al.,2017), and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004). The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987) and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010) module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. -[orodrag figure](../figures/orodrag.png) +![orodrag figure](../figures/orodrag.png) -### default oGWD scheme +### Default oGWD scheme The current default oGWD scheme in E3SMv3 is from McFarlane (1987). It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originated from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposit momemtum flux to that level. This scheme is shown to have impact on excessive westerly wind in the extratropics and the wind bias in the polar region. -### default TMS scheme +### Default TMS scheme -The turbulent mountain stress (TMS) scheme parameterizes is documented on Richter et al.,(2010). It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is currently turned off in E3SMv3 and used as an option. +The turbulent mountain stress (TMS) scheme parameterizes is documented on Richter et al.,(2010). It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is turned OFF in E3SMv3.0. -### new oGWD scheme +### New oGWD scheme -The Xie et al.,(2020) oGWD scheme is an nonlinear orographic gravity wave drag scheme that parameterizes the subgrid oGWD (>5km). It includes both the linear oGWD like that of McFarlane (1987) and nonlinear oGWD like low-level wave breaking (LLWB). The LLWB downstream often results in downslope windstorm that can enhance the drag by several times that of linear oGWD. The incorporation of the nonlinear drag is by adding an "enhancement factor" that is a function of the higher moments of the orography, e.g. orographic asymmetry (OA), orographic convexity (OC), effective orographic length (OL). +The Xie et al.,(2020) oGWD scheme is a nonlinear orographic gravity wave drag scheme that parameterizes the subgrid oGWD (>5km). It includes both the linear oGWD like that of McFarlane (1987) and nonlinear oGWD like low-level wave breaking (LLWB). The LLWB downstream often results in downslope windstorm that can enhance the drag by several times that of linear oGWD. The incorporation of the nonlinear drag is by adding an "enhancement factor" that is a function of the higher moments of the orography, e.g. orographic asymmetry (OA), orographic convexity (OC), effective orographic length (OL). ### FBD scheme @@ -28,7 +31,7 @@ The TOFD scheme (Beljaars et al.,2004) parameterizes the drag generated by the s ### sGWD scheme -The Tsiringakis et al.,(2017) sGWD scheme parameterizes the small-scale orographic gravity wave drag (sGWD) within the relatively shallow stable boundary layer. Models applying the form drag such as TOFD schemes usually lack sufficient cyclonic filling and do not accurately represent the development of cyclones over land (Louis, 1979; Holtslag, 2006). This caused significant temperature bias that occurs due to runaway cooling at the surface. To bridge the gap of this missing drag in the boundary layer, studies have hypothesized that the missing drag can be generated by sGWD. sGWD occurs under the relative stable boundary layer with low winds where the turbulence is significantly reduced. +The Tsiringakis et al.,(2017) sGWD scheme parameterizes the small-scale orographic gravity wave drag (sGWD) within the relatively shallow stable boundary layer. Models applying the form drag such as TOFD schemes usually lack sufficient cyclonic filling and do not accurately represent the development of cyclones over land (Louis, 1979; Holtslag, 2006). This caused significant temperature bias that occurs due to runaway cooling at the surface. To bridge the gap of this missing drag in the boundary layer, studies have hypothesized that the missing drag can be generated by sGWD. sGWD occurs under the relative stable boundary layer with low winds where the turbulence is significantly reduced. ## Namelist parameters diff --git a/components/eam/docs/user-guide/namelist_parameters.md b/components/eam/docs/user-guide/namelist_parameters.md index 0a0f81eb4ec4..4b856c6c5fd3 100644 --- a/components/eam/docs/user-guide/namelist_parameters.md +++ b/components/eam/docs/user-guide/namelist_parameters.md @@ -156,6 +156,7 @@ | Parameter | Description | Default value | | ------------------------- | ----------------------------------------------------------------- | ---------------------- | | `cosp_lite` | This namelist sets cosp_ncolumns=10 and cosp_nradsteps=3 (appropriate for COSP statistics derived from seasonal averages), and runs MISR, ISCCP, MODIS, and CALIPSO lidar simulators (cosp_lmisr_sim=.true.,cosp_lisccp_sim=.true., cosp_lmodis_sim=.true.,cosp_llidar_sim=.true.). | `false` | + ## Orographic drag schemes | Parameter | Description | Default value | @@ -163,9 +164,8 @@ | `use_gw_oro` | This namelist controls the default linear orographic gravity wave drag (oGWD) for E3SM, if used, the default oGWD is turned on. | `true` | | `do_tms` | This namelist controls the default TMS for E3SM, if used, the default TMS is turned on. | `false` | | `effgw_oro` | Efficiency associated with orographic gravity waves. | `0.375` | -| `tms_orocnst` | Turbulent mountain stress parameter used when turbulent mountain stress calculation -is turned on | `` | -| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `` | +| `tms_orocnst` | Turbulent mountain stress parameter used when turbulent mountain stress calculation is turned on | `1.0` | +| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `0.75` | | `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `true` | | `use_od_bl` | This namelist controls the FBD scheme, if used, the FBD scheme is turned on. | `true` | | `use_od_ss` | This namelist controls the sGWD scheme, if used, the sGWD scheme is turned on. | `true` | @@ -173,5 +173,3 @@ is turned on | `` | | `od_ls_ncleff` | Tuning parameter of nonlinear oGWD. Stands for effective resolution of the grid for oGWD. Scales the magnitude of nonlinear oGWD. | `3` | | `od_bl_ncd` | Tuning parameter of flow-blocking drag (FBD). Stands for bulk drag coefficient. Scales the magnitude of FBD. | `3` | | `od_ss_sncleff` | Tuning parameter of small-scale GWD (sGWD). Stands for effective resolution of the grid for sGWD.Scales the magnitude of sGWD. | `1` | - - diff --git a/components/eam/mkdocs.yml b/components/eam/mkdocs.yml index e41cb614387d..d0e23a6e7e8a 100644 --- a/components/eam/mkdocs.yml +++ b/components/eam/mkdocs.yml @@ -16,6 +16,7 @@ nav: - tech-guide/clubb.md - tech-guide/zm.md - RRTMG: tech-guide/rrtmg.md + - tech-guide/orodrag.md - tech-guide/mam.md - tech-guide/vbs.md - tech-guide/dust.md From 84d49343f938e033f1ccdfaf134d2c505e119932 Mon Sep 17 00:00:00 2001 From: xie7 Date: Tue, 19 Nov 2024 14:22:29 -0800 Subject: [PATCH 15/19] Added ref to the eam docs. modified: components/eam/docs/tech-guide/orodrag.md modified: components/eam/docs/user-guide/namelist_parameters.md modified: docs/refs/eam.bib [BFB] --- components/eam/docs/tech-guide/orodrag.md | 17 ++--- .../docs/user-guide/namelist_parameters.md | 16 ++--- docs/refs/eam.bib | 66 +++++++++++++++++++ 3 files changed, 81 insertions(+), 18 deletions(-) diff --git a/components/eam/docs/tech-guide/orodrag.md b/components/eam/docs/tech-guide/orodrag.md index 4373d91619df..8c6df04eae2d 100644 --- a/components/eam/docs/tech-guide/orodrag.md +++ b/components/eam/docs/tech-guide/orodrag.md @@ -2,36 +2,33 @@ ## Overview -The orographic drag schemes includes two main options: the default Gravity Wave Drag schemeof McFarlane (1987) and a -new suite of orographic drag parameterization schemes. The new suite includes 4 components all -combined in one module (i.e. subroutine gwdo2d). The schemes include -orographic gravity wave drag (oGWD, Xie et al.,2020), flow-blocking drag (FBD, Xie et al.,2020), small-scale GWD (sGWD, Tsiringakis et al.,2017), and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004). The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987) and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010) module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. +The orographic drag schemes includes two main options: the default Gravity Wave Drag schemeof McFarlane (1987)[@mcfarlane_the_1987] and a new suite of orographic drag parameterization schemes. The new suite includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020)[@xie_an_2020], flow-blocking drag (FBD, Xie et al.,2020)[@xie_an_2020], small-scale GWD (sGWD, Tsiringakis et al.,2017)[@tsiringakis_small_2020], and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004)[@beljaars_a_2020]. The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987)[@mcfarlane_the_1987] and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010)[@richter_the_2010] module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. ![orodrag figure](../figures/orodrag.png) ### Default oGWD scheme -The current default oGWD scheme in E3SMv3 is from McFarlane (1987). It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originated from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposit momemtum flux to that level. This scheme is shown to have impact on excessive westerly wind in the extratropics and the wind bias in the polar region. +The current default oGWD scheme in E3SMv3 is from McFarlane (1987)[@mcfarlane_the_1987]. It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originated from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposit momemtum flux to that level. This scheme is shown to have impact on excessive westerly wind in the extratropics and the wind bias in the polar region. ### Default TMS scheme -The turbulent mountain stress (TMS) scheme parameterizes is documented on Richter et al.,(2010). It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is turned OFF in E3SMv3.0. +The turbulent mountain stress (TMS) scheme parameterizes is documented on Richter et al.,(2010)[@richter_the_2010]. It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is turned OFF in E3SMv3.0. ### New oGWD scheme -The Xie et al.,(2020) oGWD scheme is a nonlinear orographic gravity wave drag scheme that parameterizes the subgrid oGWD (>5km). It includes both the linear oGWD like that of McFarlane (1987) and nonlinear oGWD like low-level wave breaking (LLWB). The LLWB downstream often results in downslope windstorm that can enhance the drag by several times that of linear oGWD. The incorporation of the nonlinear drag is by adding an "enhancement factor" that is a function of the higher moments of the orography, e.g. orographic asymmetry (OA), orographic convexity (OC), effective orographic length (OL). +The Xie et al.(2020)[@xie_an_2020] oGWD scheme is a nonlinear orographic gravity wave drag scheme that parameterizes the subgrid oGWD (>5km). It includes both the linear oGWD like that of McFarlane (1987)[@mcfarlane_the_1987] and nonlinear oGWD like low-level wave breaking (LLWB). The LLWB downstream often results in downslope windstorm that can enhance the drag by several times that of linear oGWD. The incorporation of the nonlinear drag is by adding an "enhancement factor" that is a function of the higher moments of the orography, e.g. orographic asymmetry (OA), orographic convexity (OC), effective orographic length (OL). ### FBD scheme -The Xie et al.,(2020) FBD scheme parameterizes the drag by flow blocked on the mountain flanks or flowing around the mountain under upstream stable conditions (>5km). It occurs when the mean flow does not have enough kinetic energy to traverse an obstacle and either stops upstream or diverges around the obstacle. This provides drag near the surface where the blocking occurs in addition to the oGWD. +The Xie et al.(2020)[@xie_an_2020] FBD scheme parameterizes the drag by flow blocked on the mountain flanks or flowing around the mountain under upstream stable conditions (>5km). It occurs when the mean flow does not have enough kinetic energy to traverse an obstacle and either stops upstream or diverges around the obstacle. This provides drag near the surface where the blocking occurs in addition to the oGWD. ### TOFD scheme -The TOFD scheme (Beljaars et al.,2004) parameterizes the drag generated by the shear stresses in the boundary layer when the flow encounters smaller obstacles (<5km). As airflow encounters an obstacle, it is disrupted, leading to the formation of eddies and vortices. These turbulent structures enhance mixing, allowing different layers of air to interact over a short distance. The intensity of the mixing is typically higher close to the obstacle, with rapid changes in velocity and direction of the airflow and can exhibit large control over the surface wind. It is an alternative scheme to the current TMS in E3SMv3. An important difference between the TOFD and TMS is that TOFD explicitly calculate the stress profile while TMS uses an enhanced effective roughtness length approach. +The TOFD scheme (Beljaars et al.,2004)[@beljaars_a_2020] parameterizes the drag generated by the shear stresses in the boundary layer when the flow encounters smaller obstacles (<5km). As airflow encounters an obstacle, it is disrupted, leading to the formation of eddies and vortices. These turbulent structures enhance mixing, allowing different layers of air to interact over a short distance. The intensity of the mixing is typically higher close to the obstacle, with rapid changes in velocity and direction of the airflow and can exhibit large control over the surface wind. It is an alternative scheme to the current TMS in E3SMv3. An important difference between the TOFD and TMS is that TOFD explicitly calculate the stress profile while TMS uses an enhanced effective roughtness length approach. ### sGWD scheme -The Tsiringakis et al.,(2017) sGWD scheme parameterizes the small-scale orographic gravity wave drag (sGWD) within the relatively shallow stable boundary layer. Models applying the form drag such as TOFD schemes usually lack sufficient cyclonic filling and do not accurately represent the development of cyclones over land (Louis, 1979; Holtslag, 2006). This caused significant temperature bias that occurs due to runaway cooling at the surface. To bridge the gap of this missing drag in the boundary layer, studies have hypothesized that the missing drag can be generated by sGWD. sGWD occurs under the relative stable boundary layer with low winds where the turbulence is significantly reduced. +The Tsiringakis et al.(2017)[@tsiringakis_small_2020] sGWD scheme parameterizes the small-scale orographic gravity wave drag (sGWD) within the relatively shallow stable boundary layer. Models applying the form drag such as TOFD schemes usually lack sufficient cyclonic filling and do not accurately represent the development of cyclones over land (Holstag 2006)[@holtslag_preface_2006]. This caused significant temperature bias that occurs due to runaway cooling at the surface. To bridge the gap of this missing drag in the boundary layer, studies have hypothesized that the missing drag can be generated by sGWD. sGWD occurs under the relative stable boundary layer with low winds where the turbulence is significantly reduced. ## Namelist parameters diff --git a/components/eam/docs/user-guide/namelist_parameters.md b/components/eam/docs/user-guide/namelist_parameters.md index 4b856c6c5fd3..73d3c262fff6 100644 --- a/components/eam/docs/user-guide/namelist_parameters.md +++ b/components/eam/docs/user-guide/namelist_parameters.md @@ -162,14 +162,14 @@ | Parameter | Description | Default value | | ------------------------- | ----------------------------------------------------------------- | ---------------------- | | `use_gw_oro` | This namelist controls the default linear orographic gravity wave drag (oGWD) for E3SM, if used, the default oGWD is turned on. | `true` | -| `do_tms` | This namelist controls the default TMS for E3SM, if used, the default TMS is turned on. | `false` | +| `do_tms` | This namelist controls the default Turbulent Mountain Stress (TMS) for E3SM, if used, the default TMS is turned on. | `false` | | `effgw_oro` | Efficiency associated with orographic gravity waves. | `0.375` | -| `tms_orocnst` | Turbulent mountain stress parameter used when turbulent mountain stress calculation is turned on | `1.0` | -| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ]. | `0.75` | +| `tms_orocnst` | Turbulent mountain stress parameter used when TMS calculation is turned on | `1.0` | +| `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ] for TMS. | `0.75` | | `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `true` | -| `use_od_bl` | This namelist controls the FBD scheme, if used, the FBD scheme is turned on. | `true` | -| `use_od_ss` | This namelist controls the sGWD scheme, if used, the sGWD scheme is turned on. | `true` | -| `use_od_fd` | This namelist controls the TOFD scheme, if used, the TOFD scheme is turned on. | `true` | +| `use_od_bl` | This namelist controls the Flow-blocking drag (FBD) scheme, if used, the FBD scheme is turned on. | `true` | +| `use_od_ss` | This namelist controls the small-scale GWD (sGWD) scheme, if used, the sGWD scheme is turned on. | `true` | +| `use_od_fd` | This namelist controls the Turbulent orographic form drag (TOFD) scheme, if used, the TOFD scheme is turned on. | `true` | | `od_ls_ncleff` | Tuning parameter of nonlinear oGWD. Stands for effective resolution of the grid for oGWD. Scales the magnitude of nonlinear oGWD. | `3` | -| `od_bl_ncd` | Tuning parameter of flow-blocking drag (FBD). Stands for bulk drag coefficient. Scales the magnitude of FBD. | `3` | -| `od_ss_sncleff` | Tuning parameter of small-scale GWD (sGWD). Stands for effective resolution of the grid for sGWD.Scales the magnitude of sGWD. | `1` | +| `od_bl_ncd` | Tuning parameter of FBD. Stands for bulk drag coefficient. Scales the magnitude of FBD. | `3` | +| `od_ss_sncleff` | Tuning parameter of sGWD. Stands for effective resolution of the grid for sGWD.Scales the magnitude of sGWD. | `1` | diff --git a/docs/refs/eam.bib b/docs/refs/eam.bib index ff4415a519b8..c8b8ffded406 100644 --- a/docs/refs/eam.bib +++ b/docs/refs/eam.bib @@ -1035,3 +1035,69 @@ @article{neale_description_2012 journal = {UNKNOWN}, year = {2012}, } + +@article{xie_an_2020, + title = {An Orographic-Drag Parametrization Scheme Including Orographic Anisotropy for All Flow Directions}, + url = {https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2019MS001921/}, + doi = {10.1029/2019MS001921}, + language = {en}, + urldate = {2024-11-19}, + author = {J., Xie and M.,Zhang and Z., Xie and H., Liu and Z., Chai and J., He and H. Zhang}, + journal = {Journal of Advances in Modeling Earth Systems}, + year = {2020}, +} + +@article{beljaars_a_2020, + title = {A new parametrization of turbulent orographic form drag}, + url = {https://rmets.onlinelibrary.wiley.com/doi/abs/10.1256/qj.03.73/}, + doi = {10.1256/qj.03.73}, + language = {en}, + urldate = {2024-11-19}, + author = {A. Beljaars, A. Brown, N. Wood}, + journal = {Quarterly Journal of the Royal Meterological Society}, + year = {2004}, +} + +@article{tsiringakis_small_2020, + title = {Small-scale orographic gravity wave drag in stable boundary layers and its impact on synoptic systems and near-surface meteorology}, + url = {https://rmets.onlinelibrary.wiley.com/doi/abs/10.1002/qj.3021}, + doi = {10.1002/qj.3021}, + language = {en}, + urldate = {2024-11-19}, + author = {A. Tsiringakis, G.J. Steeneveld, A.A.M. Holtslag}, + journal = {Quarterly Journal of the Royal Meterological Society}, + year = {2017}, +} + +@article{mcfarlane_the_1987, + title = {The Effect of Orographically Excited Gravity Wave Drag on the General Circulation of the Lower Stratosphere and Troposphere}, + url = {https://journals.ametsoc.org/view/journals/atsc/44/14/1520-0469_1987_044_1775_teooeg_2_0_co_2.xml}, + doi = {10.1175/1520-0469(1987)044<1775:TEOOEG>2.0.CO;2}, + language = {en}, + urldate = {2024-11-19}, + author = {N.A. McFarlane}, + journal = {Journal of the Atmospheric Sciences}, + year = {1987}, +} + +@article{richter_the_2010, + title = {The Effect of Orographically Excited Gravity Wave Drag on the General Circulation of the Lower Stratosphere and Troposphere}, + url = {https://journals.ametsoc.org/view/journals/atsc/67/1/2009jas3112.1.xml?tab_body=pdf}, + doi = {10.1175/2009JAS3112.1}, + language = {en}, + urldate = {2024-11-19}, + author = {J.H. Richter, F. Sassi, R.R. Garcia}, + journal = {Journal of the Atmospheric Sciences}, + year = {2010}, +} + +@article{holtslag_preface_2006, + title = {Preface:GEWEXatmospheric boundary-layer study (GABLS) on stable boundary layers}, + url = {https://link.springer.com/article/10.1007/s10546-005-9008-6}, + doi = {10.1007/s10546-005-9008-6}, + language = {en}, + urldate = {2024-11-19}, + author = {A.A Holtslag}, + journal = {Boundary-Layer Meterology}, + year = {2006}, +} From d7b2e498fec75326366d218928d38a36fc5633c3 Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Thu, 21 Nov 2024 13:31:39 -0700 Subject: [PATCH 16/19] fix to address merge conflict --- components/eam/src/physics/cam/gw_drag.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/components/eam/src/physics/cam/gw_drag.F90 b/components/eam/src/physics/cam/gw_drag.F90 index 96ac9f70021e..6017d588682d 100644 --- a/components/eam/src/physics/cam/gw_drag.F90 +++ b/components/eam/src/physics/cam/gw_drag.F90 @@ -120,8 +120,7 @@ module gw_drag ! namelist logical :: history_amwg ! output the variables used by the AMWG diag package - integer :: pblh_idx = 0 - ! + !========================================================================== contains !========================================================================== @@ -305,7 +304,7 @@ subroutine gw_init(pbuf2d) !----------------------------------------------------------------------- call oro_drag_init(pbuf2d) - + ! Set model flags. do_spectral_waves = (pgwv > 0 .and. (use_gw_front .or. use_gw_convect)) orographic_only = (use_gw_oro .and. .not. do_spectral_waves) @@ -676,7 +675,6 @@ subroutine gw_tend(state, sgh, pbuf, dt, ptend, cam_in) real(r8) :: dummx_fd(pcols) real(r8) :: dummy_fd(pcols) ! - real(r8), pointer :: pblh(:) real(r8) :: dx(pcols),dy(pcols) !---------------------------Local storage------------------------------- From 203df58e67448429f07ff9af7d77121b8494fd62 Mon Sep 17 00:00:00 2001 From: xie7 Date: Mon, 25 Nov 2024 17:39:41 -0800 Subject: [PATCH 17/19] Minor edits on orodrag documentation. modified: tech-guide/orodrag.md modified: user-guide/namelist_parameters.md [BFB] --- components/eam/docs/tech-guide/orodrag.md | 6 +++--- components/eam/docs/user-guide/namelist_parameters.md | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/components/eam/docs/tech-guide/orodrag.md b/components/eam/docs/tech-guide/orodrag.md index 8c6df04eae2d..f71fc07f2826 100644 --- a/components/eam/docs/tech-guide/orodrag.md +++ b/components/eam/docs/tech-guide/orodrag.md @@ -2,17 +2,17 @@ ## Overview -The orographic drag schemes includes two main options: the default Gravity Wave Drag schemeof McFarlane (1987)[@mcfarlane_the_1987] and a new suite of orographic drag parameterization schemes. The new suite includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020)[@xie_an_2020], flow-blocking drag (FBD, Xie et al.,2020)[@xie_an_2020], small-scale GWD (sGWD, Tsiringakis et al.,2017)[@tsiringakis_small_2020], and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004)[@beljaars_a_2020]. The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987)[@mcfarlane_the_1987] and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010)[@richter_the_2010] module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. +The orographic drag schemes includes two main options: the default Gravity Wave Drag scheme of McFarlane (1987)[@mcfarlane_the_1987] and a new suite of orographic drag parameterization schemes. The new suite includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020)[@xie_an_2020], flow-blocking drag (FBD, Xie et al.,2020)[@xie_an_2020], small-scale GWD (sGWD, Tsiringakis et al.,2017)[@tsiringakis_small_2020], and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004)[@beljaars_a_2020]. The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987)[@mcfarlane_the_1987] and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010)[@richter_the_2010] module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. Currently, only the scheme of McFarlane (1987) is opened as default in E3SMv3.0. ![orodrag figure](../figures/orodrag.png) ### Default oGWD scheme -The current default oGWD scheme in E3SMv3 is from McFarlane (1987)[@mcfarlane_the_1987]. It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originated from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposit momemtum flux to that level. This scheme is shown to have impact on excessive westerly wind in the extratropics and the wind bias in the polar region. +The current default oGWD scheme in E3SMv3.0 is from McFarlane (1987)[@mcfarlane_the_1987]. It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originating from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposits momemtum flux to that level. This scheme is shown to have improve the excessive westerly wind bias in the extratropics and the wind bias in the polar region. This scheme is turned on by default in E3SMv3.0. ### Default TMS scheme -The turbulent mountain stress (TMS) scheme parameterizes is documented on Richter et al.,(2010)[@richter_the_2010]. It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is turned OFF in E3SMv3.0. +The turbulent mountain stress (TMS) scheme is documented on Richter et al.,(2010)[@richter_the_2010]. It parameterizes the turbulent scale form drag (TOFD) through adding enhanced effective roughness length to the model. This method is justified by the observation that area-averaged wind sufficiently far above hilly terrain behave logarithmically. It leads to significant decrease of overspeed surface wind in the model. It is turned OFF in E3SMv3.0. ### New oGWD scheme diff --git a/components/eam/docs/user-guide/namelist_parameters.md b/components/eam/docs/user-guide/namelist_parameters.md index 73d3c262fff6..8aa4b40299c5 100644 --- a/components/eam/docs/user-guide/namelist_parameters.md +++ b/components/eam/docs/user-guide/namelist_parameters.md @@ -166,10 +166,10 @@ | `effgw_oro` | Efficiency associated with orographic gravity waves. | `0.375` | | `tms_orocnst` | Turbulent mountain stress parameter used when TMS calculation is turned on | `1.0` | | `tms_z0fac` | Factor determining z_0 from orographic standard deviation [ no unit ] for TMS. | `0.75` | -| `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `true` | -| `use_od_bl` | This namelist controls the Flow-blocking drag (FBD) scheme, if used, the FBD scheme is turned on. | `true` | -| `use_od_ss` | This namelist controls the small-scale GWD (sGWD) scheme, if used, the sGWD scheme is turned on. | `true` | -| `use_od_fd` | This namelist controls the Turbulent orographic form drag (TOFD) scheme, if used, the TOFD scheme is turned on. | `true` | +| `use_od_ls` | This namelist controls the new nonlinear oGWD, if used, the nonlinear oGWD is turned on. use_od_ls should not be used at the same time with use_gw_oro. | `false` | +| `use_od_bl` | This namelist controls the Flow-blocking drag (FBD) scheme, if used, the FBD scheme is turned on. | `false` | +| `use_od_ss` | This namelist controls the small-scale GWD (sGWD) scheme, if used, the sGWD scheme is turned on. | `false` | +| `use_od_fd` | This namelist controls the Turbulent orographic form drag (TOFD) scheme, if used, the TOFD scheme is turned on. | `false` | | `od_ls_ncleff` | Tuning parameter of nonlinear oGWD. Stands for effective resolution of the grid for oGWD. Scales the magnitude of nonlinear oGWD. | `3` | | `od_bl_ncd` | Tuning parameter of FBD. Stands for bulk drag coefficient. Scales the magnitude of FBD. | `3` | | `od_ss_sncleff` | Tuning parameter of sGWD. Stands for effective resolution of the grid for sGWD.Scales the magnitude of sGWD. | `1` | From b635da778898f728b85e3619fd0557bbef9070bc Mon Sep 17 00:00:00 2001 From: xie7 Date: Tue, 26 Nov 2024 11:07:58 -0800 Subject: [PATCH 18/19] Minor text fix. modified: orodrag.md [BFB] --- components/eam/docs/tech-guide/orodrag.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components/eam/docs/tech-guide/orodrag.md b/components/eam/docs/tech-guide/orodrag.md index f71fc07f2826..a0be96e4f756 100644 --- a/components/eam/docs/tech-guide/orodrag.md +++ b/components/eam/docs/tech-guide/orodrag.md @@ -2,13 +2,13 @@ ## Overview -The orographic drag schemes includes two main options: the default Gravity Wave Drag scheme of McFarlane (1987)[@mcfarlane_the_1987] and a new suite of orographic drag parameterization schemes. The new suite includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020)[@xie_an_2020], flow-blocking drag (FBD, Xie et al.,2020)[@xie_an_2020], small-scale GWD (sGWD, Tsiringakis et al.,2017)[@tsiringakis_small_2020], and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004)[@beljaars_a_2020]. The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987)[@mcfarlane_the_1987] and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010)[@richter_the_2010] module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The conceptual location of each scheme is illustrate below. Currently, only the scheme of McFarlane (1987) is opened as default in E3SMv3.0. +The orographic drag schemes includes two main options: the default Gravity Wave Drag scheme of McFarlane (1987)[@mcfarlane_the_1987] and a new suite of orographic drag parameterization schemes. The new suite includes 4 components all combined in one module (i.e. subroutine gwdo2d). The schemes include orographic gravity wave drag (oGWD, Xie et al.,2020)[@xie_an_2020], flow-blocking drag (FBD, Xie et al.,2020)[@xie_an_2020], small-scale GWD (sGWD, Tsiringakis et al.,2017)[@tsiringakis_small_2020], and turbulent-scale orographic form drag (TOFD, Beljaars et al., 2004)[@beljaars_a_2020]. The oGWD and TOFD schemes are used to replace the default oGWD (McFarlane, 1987)[@mcfarlane_the_1987] and Turbulent Mountain Stress (TMS, documented on Richter et al., 2010)[@richter_the_2010] module in EAM, while the FBD and sGWD are added enhanced drag schemes. Each of the schemes are used to predict and add enhanced drags from surface to high level that would help decelerate the wind especially over the mountainous regions among the globe. The oGWD, FBD, and sGWD are implemented in gw_drag.F90, while TOFD is implemented in clubb_intr.F90 to join the vertical diffusion process. There are also new topographic parameters (orographic asymmetry [OA], orographic convexity [OC], effective orographic length [OL]) are input into the model for the new oGWD and FBD scheme implmented. The concept of each scheme is illustrate in the figure below. Currently, only the scheme of McFarlane (1987) is turned on as default in E3SMv3.0. ![orodrag figure](../figures/orodrag.png) ### Default oGWD scheme -The current default oGWD scheme in E3SMv3.0 is from McFarlane (1987)[@mcfarlane_the_1987]. It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originating from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposits momemtum flux to that level. This scheme is shown to have improve the excessive westerly wind bias in the extratropics and the wind bias in the polar region. This scheme is turned on by default in E3SMv3.0. +The current default oGWD scheme in E3SMv3.0 is from McFarlane (1987)[@mcfarlane_the_1987]. It is a linear orographic gravity wave drag scheme that parameterizes the subgrid process of vertical propagation of gravity wave originating from orographic source. The output from this scheme is a vertical profile of drag (or deceleration terms) when gravity wave breaks at higher levels and deposits momemtum flux to that level. This scheme is shown to improve the excessive westerly wind bias in the extratropics and the wind bias in the polar region. This scheme is turned on by default in E3SMv3.0. ### Default TMS scheme From 87a6906f102affd2c5472a6b50904411a5557f70 Mon Sep 17 00:00:00 2001 From: Walter Hannah Date: Tue, 3 Dec 2024 14:17:01 -0600 Subject: [PATCH 19/19] fix MMF build issues --- .../physics/crm/dummy_modules/clubb_intr.F90 | 31 +++++++++++++++++++ components/eam/src/physics/crm/physpkg.F90 | 2 +- 2 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 components/eam/src/physics/crm/dummy_modules/clubb_intr.F90 diff --git a/components/eam/src/physics/crm/dummy_modules/clubb_intr.F90 b/components/eam/src/physics/crm/dummy_modules/clubb_intr.F90 new file mode 100644 index 000000000000..d6729e33f6b3 --- /dev/null +++ b/components/eam/src/physics/crm/dummy_modules/clubb_intr.F90 @@ -0,0 +1,31 @@ +module clubb_intr +!------------------------------------------------------------------------------- +! Dummy module to override src/physics/cam/clubb_intr.F90 +!------------------------------------------------------------------------------- +use shr_kind_mod, only: r8=>shr_kind_r8 +public :: clubb_implements_cnst +public :: clubb_init_cnst +public :: clubb_readnl +contains +!=============================================================================== +function clubb_implements_cnst(name) + ! Return true if specified constituent is implemented + character(len=*), intent(in) :: name ! constituent name + logical :: clubb_implements_cnst ! return value + clubb_implements_cnst = .false. +end function clubb_implements_cnst +!=============================================================================== +subroutine clubb_init_cnst(name, q, gcid) + ! Initialize the state if clubb_do_adv + character(len=*), intent(in) :: name ! constituent name + real(r8), intent(out) :: q(:,:) ! mass mixing ratio (gcol, plev) + integer, intent(in) :: gcid(:) ! global column id + return +end subroutine clubb_init_cnst +!=============================================================================== +subroutine clubb_readnl(nlfile) + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + return +end subroutine clubb_readnl +!=============================================================================== +end module clubb_intr diff --git a/components/eam/src/physics/crm/physpkg.F90 b/components/eam/src/physics/crm/physpkg.F90 index 33fab14066d0..6ad53894f4e3 100644 --- a/components/eam/src/physics/crm/physpkg.F90 +++ b/components/eam/src/physics/crm/physpkg.F90 @@ -638,7 +638,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) if (co2_transport()) call co2_init() call co2_diags_init(phys_state) - call gw_init() + call gw_init(pbuf2d) call rayleigh_friction_init()