From 3be97cfa0ed007a08d17394984ecf3ac24165e72 Mon Sep 17 00:00:00 2001 From: GeorgeGayno-NOAA <52789452+GeorgeGayno-NOAA@users.noreply.github.com> Date: Mon, 30 Sep 2024 08:34:16 -0400 Subject: [PATCH] Clean up orography code (#987) 1) Remove unused subroutines and logic. 2) Move utility routines to their own module. 3) Move I/O routines to their own module. 4) Remove dependency on IP and SP libraries. 5) Add some unit testing. Fixes #970. --- .../orog_mask_tools.fd/orog.fd/CMakeLists.txt | 14 +- .../orog.fd/{netcdf_io.F90 => io_utils.F90} | 339 +- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F | 4468 ----------------- .../orog.fd/mtnlm7_oclsm.F90 | 1365 +++++ .../orog_mask_tools.fd/orog.fd/orog_utils.F90 | 1104 ++++ tests/CMakeLists.txt | 1 + tests/orog/CMakeLists.txt | 23 + tests/orog/ftst_get_ll_angle.F90 | 58 + tests/orog/ftst_ll2xyz.F90 | 87 + tests/orog/ftst_minmax.F90 | 44 + 10 files changed, 3004 insertions(+), 4499 deletions(-) rename sorc/orog_mask_tools.fd/orog.fd/{netcdf_io.F90 => io_utils.F90} (65%) delete mode 100644 sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F create mode 100644 sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 create mode 100644 sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 create mode 100644 tests/orog/CMakeLists.txt create mode 100644 tests/orog/ftst_get_ll_angle.F90 create mode 100644 tests/orog/ftst_ll2xyz.F90 create mode 100644 tests/orog/ftst_minmax.F90 diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index 6fbed0573..955101450 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -1,5 +1,5 @@ -set(lib_src netcdf_io.F90) -set(exe_src mtnlm7_oclsm.F) +set(lib_src io_utils.F90 orog_utils.F90) +set(exe_src mtnlm7_oclsm.F90) if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian -assume byterecl") @@ -9,14 +9,11 @@ elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-invalid-boz") endif() endif() -if(ip_VERSION GREATER_EQUAL 4.0.0) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -DIP_V4") -endif() set(exe_name orog) add_library(orog_lib STATIC ${lib_src}) -add_executable(${exe_name} mtnlm7_oclsm.F) +add_executable(${exe_name} mtnlm7_oclsm.F90) set(mod_dir "${CMAKE_CURRENT_BINARY_DIR}/mod") set_target_properties(orog_lib PROPERTIES Fortran_MODULE_DIRECTORY ${mod_dir}) @@ -27,13 +24,8 @@ target_link_libraries( PUBLIC bacio::bacio_4 w3emc::w3emc_d - ip::ip_d NetCDF::NetCDF_Fortran) -if(sp_FOUND) - target_link_libraries(orog_lib PUBLIC sp::sp_d) -endif() - if(OpenMP_Fortran_FOUND) target_link_libraries(orog_lib PUBLIC OpenMP::OpenMP_Fortran) endif() diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 similarity index 65% rename from sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 rename to sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 index 4e13fc8ef..51a646779 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/io_utils.F90 @@ -1,6 +1,27 @@ !> @file -!! @brief Write out data in netcdf format -!! @author Jordan Alpert NOAA/EMC +!! @brief i/o utilities +!! @author George Gayno NOAA/EMC + +!> Module containing utilities that read and write data. +!! +!! @author George Gayno NOAA/EMC + + module io_utils + + implicit none + + private + + public :: qc_orog_by_ramp + public :: read_global_mask + public :: read_global_orog + public :: read_mask + public :: read_mdl_dims + public :: read_mdl_grid_file + public :: write_mask_netcdf + public :: write_netcdf + + contains !> Write out orography file in netcdf format. !! @@ -9,7 +30,6 @@ !! @param[in] slm Land-sea mask. !! @param[in] land_frac Land fraction. !! @param[in] oro Orography -!! @param[in] orf Filtered orography. Currently the same as 'oro'. !! @param[in] hprime The gravity wave drag fields on the model grid tile. !! @param[in] ntiles Number of tiles to output. !! @param[in] tile Tile number to output. @@ -18,11 +38,11 @@ !! @param[in] lon Longitude of the first row of the model grid tile. !! @param[in] lat Latitude of the first column of the model grid tile. !! @author Jordan Alpert NOAA/EMC GFDL Programmer - subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, geolon, geolat, lon, lat) + subroutine write_netcdf(im, jm, slm, land_frac, oro, hprime, ntiles, tile, geolon, geolat, lon, lat) implicit none integer, intent(in):: im, jm, ntiles, tile real, intent(in) :: lon(im), lat(jm) - real, intent(in), dimension(im,jm) :: slm, oro, orf, geolon, geolat, land_frac + real, intent(in), dimension(im,jm) :: slm, oro, geolon, geolat, land_frac real, intent(in), dimension(im,jm,14):: hprime character(len=128) :: outfile integer :: error, ncid @@ -46,7 +66,6 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, dim1=size(lon,1) dim2=size(lat,1) - write(6,*) ' netcdf dims are: ',dim1, dim2 !--- open the file error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) @@ -170,7 +189,8 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, error = nf_put_var_double( ncid, id_orog_raw, oro(:dim1,:dim2)) call netcdf_err(error, 'write var orog_raw for file='//trim(outfile) ) - error = nf_put_var_double( ncid, id_orog_filt, orf(:dim1,:dim2)) +! We no longer filter the orog, so the raw and filtered records are the same. + error = nf_put_var_double( ncid, id_orog_filt, oro(:dim1,:dim2)) call netcdf_err(error, 'write var orog_filt for file='//trim(outfile) ) error = nf_put_var_double( ncid, id_stddev, hprime(:dim1,:dim2,1)) @@ -208,7 +228,7 @@ subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, error = nf_close(ncid) call netcdf_err(error, 'close file='//trim(outfile) ) - end subroutine + end subroutine write_netcdf !> Check NetCDF error code and output the error message. !! @@ -263,7 +283,6 @@ subroutine write_mask_netcdf(im, jm, slm, land_frac, ntiles, tile, geolon, geola dim1=im dim2=jm - write(6,*) ' netcdf dims are: ',dim1, dim2 !--- open the file error = NF__CREATE(outfile, IOR(NF_NETCDF4,NF_CLASSIC_MODEL), inital, fsize, ncid) @@ -319,8 +338,7 @@ subroutine write_mask_netcdf(im, jm, slm, land_frac, ntiles, tile, geolon, geola error = nf_close(ncid) call netcdf_err(error, 'close file='//trim(outfile) ) - end subroutine - + end subroutine write_mask_netcdf !> Read the land mask file !! @@ -349,7 +367,7 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) fsize = 66536 - print*, "merge_file=", trim(merge_file) + print*,'- READ IN EXTERNAL LANDMASK FILE: ',trim(merge_file) error=NF__OPEN(merge_file,NF_NOWRITE,fsize,ncid) call netcdf_err(error, 'Open file '//trim(merge_file) ) @@ -358,23 +376,304 @@ subroutine read_mask(merge_file,slm,land_frac,lake_frac,im,jm) error=nf_get_var_double(ncid, id_var, land_frac) call netcdf_err(error, 'inquire data of land_frac') - print*,'land_frac ',maxval(land_frac),minval(land_frac) - error=nf_inq_varid(ncid, 'slmsk', id_var) call netcdf_err(error, 'inquire varid of slmsk') error=nf_get_var_double(ncid, id_var, slm) call netcdf_err(error, 'inquire data of slmsk') - print*,'slmsk ',maxval(slm),minval(slm) - error=nf_inq_varid(ncid, 'lake_frac', id_var) call netcdf_err(error, 'inquire varid of lake_frac') error=nf_get_var_double(ncid, id_var, lake_frac) call netcdf_err(error, 'inquire data of lake_frac') - print*,'lake_frac ',maxval(lake_frac),minval(lake_frac) - error = nf_close(ncid) - print*,'bot of read_mask' - end subroutine + end subroutine read_mask + +!> Read the grid dimensions from the model 'grid' file +!! +!! @param[in] mdl_grid_file path/name of model 'grid' file. +!! @param[out] im 'i' dimension of a model grid tile. +!! @param[out] jm 'j' dimension of a model grid tile. +!! @author George Gayno NOAA/EMC + subroutine read_mdl_dims(mdl_grid_file, im, jm) + + implicit none + include "netcdf.inc" + + character(len=*), intent(in) :: mdl_grid_file + + integer, intent(out) :: im, jm + + integer ncid, error, fsize, id_dim, nx, ny + + fsize = 66536 + + print*, "- READ MDL GRID DIMENSIONS FROM= ", trim(mdl_grid_file) + + error=NF__OPEN(mdl_grid_file,NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening file '//trim(mdl_grid_file) ) + + error=nf_inq_dimid(ncid, 'nx', id_dim) + call netcdf_err(error, 'inquire dimension nx from file '// trim(mdl_grid_file) ) + error=nf_inq_dimlen(ncid,id_dim,nx) + call netcdf_err(error, 'inquire nx from file '//trim(mdl_grid_file) ) + + error=nf_inq_dimid(ncid, 'ny', id_dim) + call netcdf_err(error, 'inquire dimension ny from file '// trim(mdl_grid_file) ) + error=nf_inq_dimlen(ncid,id_dim,ny) + call netcdf_err(error, 'inquire ny from file '//trim(mdl_grid_file) ) + + error=nf_close(ncid) + + IM = nx/2 + JM = ny/2 + + print*,"- MDL GRID DIMENSIONS ", im, jm + + end subroutine read_mdl_dims + +!> Read the grid dimensions from the model 'grid' file +!! +!! @param[in] mdl_grid_file Path/name of model 'grid' file. +!! @param[in] im 'i' Dimension of a model grid tile. +!! @param[in] jm 'j' Dimension of a model grid tile. +!! @param[out] geolon Longitude at the grid point centers. +!! @param[out] geolon_c Longitude at the grid point corners. +!! @param[out] geolat Latitude at the grid point centers. +!! @param[out] geolat_c Latitude at the grid point corners. +!! @param[out] dx Length of model grid points in the 'x' direction. +!! @param[out] dy Length of model grid points in the 'y' direction. +!! @param[out] is_north_pole 'true' for points surrounding the north pole. +!! @param[out] is_south_pole 'true' for points surrounding the south pole. +!! @author George Gayno NOAA/EMC + subroutine read_mdl_grid_file(mdl_grid_file, im, jm, & + geolon, geolon_c, geolat, geolat_c, dx, dy, & + is_north_pole, is_south_pole) + + use orog_utils, only : find_poles, find_nearest_pole_points + + implicit none + include "netcdf.inc" + + character(len=*), intent(in) :: mdl_grid_file + + integer, intent(in) :: im, jm + + logical, intent(out) :: is_north_pole(im,jm) + logical, intent(out) :: is_south_pole(im,jm) + + real, intent(out) :: geolat(im,jm) + real, intent(out) :: geolat_c(im+1,jm+1) + real, intent(out) :: geolon(im,jm) + real, intent(out) :: geolon_c(im+1,jm+1) + real, intent(out) :: dx(im,jm), dy(im,jm) + + integer :: i, j + integer :: ncid, error, fsize, id_var, nx, ny + integer :: i_south_pole,j_south_pole + integer :: i_north_pole,j_north_pole + + real, allocatable :: tmpvar(:,:) + fsize = 66536 + + nx = 2*im + ny = 2*jm + + allocate(tmpvar(nx+1,ny+1)) + + print*, "- OPEN AND READ= ", trim(mdl_grid_file) + + error=NF__OPEN(mdl_grid_file,NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening file '//trim(mdl_grid_file) ) + + error=nf_inq_varid(ncid, 'x', id_var) + call netcdf_err(error, 'inquire varid of x from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of x from file ' // trim(mdl_grid_file)) + +! Adjust lontitude to be between 0 and 360. + do j = 1,ny+1 + do i = 1,nx+1 + if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 + if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 + enddo + enddo + + geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + + error=nf_inq_varid(ncid, 'y', id_var) + call netcdf_err(error, 'inquire varid of y from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of y from file ' // trim(mdl_grid_file)) + + geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) + geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) + + call find_poles(tmpvar, nx, ny, i_north_pole, j_north_pole, & + i_south_pole, j_south_pole) + + deallocate(tmpvar) + + call find_nearest_pole_points(i_north_pole, j_north_pole, & + i_south_pole, j_south_pole, im, jm, is_north_pole, & + is_south_pole) + + allocate(tmpvar(nx,ny)) + + error=nf_inq_varid(ncid, 'area', id_var) + call netcdf_err(error, 'inquire varid of area from file ' // trim(mdl_grid_file)) + error=nf_get_var_double(ncid, id_var, tmpvar) + call netcdf_err(error, 'inquire data of area from file ' // trim(mdl_grid_file)) + + error = nf_close(ncid) + + do j = 1, jm + do i = 1, im + dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) & + + tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) + dy(i,j) = dx(i,j) + enddo + enddo + + deallocate(tmpvar) + + end subroutine read_mdl_grid_file + +!> Read input global 30-arc second orography data. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[out] glob The orography data. +!! @author Jordan Alpert NOAA/EMC + subroutine read_global_orog(imn,jmn,glob) + + use orog_utils, only : transpose_orog + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + integer*2, intent(out) :: glob(imn,jmn) + + integer :: ncid, error, id_var, fsize + + fsize=65536 + + print*,"- OPEN AND READ ./topography.gmted2010.30s.nc" + + error=NF__OPEN("./topography.gmted2010.30s.nc", & + NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file topography.gmted2010.30s.nc' ) + error=nf_inq_varid(ncid, 'topo', id_var) + call netcdf_err(error, 'Inquire varid of topo') + error=nf_get_var_int2(ncid, id_var, glob) + call netcdf_err(error, 'Read topo') + error = nf_close(ncid) + + print*,"- MAX/MIN OF OROGRAPHY DATA ",maxval(glob),minval(glob) + + call transpose_orog(imn,jmn,glob) + + return + end subroutine read_global_orog + +!> Read input global 30-arc second land mask data. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[out] mask The land mask data. +!! @author G. Gayno NOAA/EMC + subroutine read_global_mask(imn, jmn, mask) + + use orog_utils, only : transpose_mask + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + + integer(1), intent(out) :: mask(imn,jmn) + + integer :: ncid, fsize, id_var, error + + fsize = 65536 + + print*,"- OPEN AND READ ./landcover.umd.30s.nc" + + error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) + error=nf_inq_varid(ncid, 'land_mask', id_var) + call netcdf_err(error, 'Inquire varid of land_mask') + error=nf_get_var_int1(ncid, id_var, mask) + call netcdf_err(error, 'Inquire data of land_mask') + error = nf_close(ncid) + + call transpose_mask(imn,jmn,mask) + + end subroutine read_global_mask + +!> Quality control the global orography and landmask +!! data over Antarctica using RAMP data. +!! +!! @param[in] imn i-dimension of the global data. +!! @param[in] jmn j-dimension of the global data. +!! @param[inout] zavg The global orography data. +!! @param[inout] zslm The global landmask data. +!! @author G. Gayno + subroutine qc_orog_by_ramp(imn, jmn, zavg, zslm) + + implicit none + + include 'netcdf.inc' + + integer, intent(in) :: imn, jmn + integer, intent(inout) :: zavg(imn,jmn) + integer, intent(inout) :: zslm(imn,jmn) + + integer :: i, j, error, ncid, id_var, fsize + + real(4), allocatable :: gice(:,:) + + fsize = 65536 + + allocate (GICE(IMN+1,3601)) + +! Read 30-sec Antarctica RAMP data. Points scan from South +! to North, and from Greenwich to Greenwich. + + print*,"- OPEN/READ RAMP DATA ./topography.antarctica.ramp.30s.nc" + + error=NF__OPEN("./topography.antarctica.ramp.30s.nc", & + NF_NOWRITE,fsize,ncid) + call netcdf_err(error, 'Opening RAMP topo file' ) + error=nf_inq_varid(ncid, 'topo', id_var) + call netcdf_err(error, 'Inquire varid of RAMP topo') + error=nf_get_var_real(ncid, id_var, GICE) + call netcdf_err(error, 'Inquire data of RAMP topo') + error = nf_close(ncid) + + print*,"- QC GLOBAL OROGRAPHY DATA WITH RAMP." + +! If RAMP values are valid, replace the global value with the RAMP +! value. Invalid values are less than or equal to 0 (0, -1, or -99). + + do j = 1, 3601 + do i = 1, IMN + if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then + if ( GICE(i,j) .gt. 0.) then + ZAVG(i,j) = int( GICE(i,j) + 0.5 ) + ZSLM(i,j) = 1 + endif + endif + enddo + enddo + + deallocate (GICE) + + end subroutine qc_orog_by_ramp + + end module io_utils diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F deleted file mode 100644 index 041c9be5b..000000000 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F +++ /dev/null @@ -1,4468 +0,0 @@ -C> @file -C> Terrain maker for global spectral model. -C> @author Mark Iredell @date 92-04-16 - -C> This program creates 7 terrain-related files computed from the -C> GMTED2010 terrain dataset. The model physics grid parameters and -C> spectral truncation and filter parameters are read by this program as -C> input. -C> -C> The 7 files produced are: -C> 1. sea-land mask on model physics grid -C> 2. gridded orography on model physics grid -C> 3. mountain std dev on model physics grid -C> 4. spectral orography in spectral domain -C> 5. unfiltered gridded orography on model physics grid -C> 6. grib sea-land mask on model physics grid -C> 7. grib gridded orography on model physics grid -C> -C> The orography is only filtered for wavenumbers greater than nf0. For -C> wavenumbers n between nf0 and nf1, the orography is filtered by the -C> factor 1-((n-nf0)/(nf1-nf0))**2. The filtered orography will not have -C> information beyond wavenumber nf1. -C> -C> PROGRAM HISTORY LOG: -C> - 92-04-16 IREDELL -C> - 98-02-02 IREDELL FILTER -C> - 98-05-31 HONG Modified for subgrid orography used in Kim's scheme -C> - 98-12-31 HONG Modified for high-resolution GTOPO orography -C> - 99-05-31 HONG Modified for getting OL4 (mountain fraction) -C> - 00-02-10 Moorthi's modifications -C> - 00-04-11 HONG Modified for reduced grids -C> - 00-04-12 Iredell Modified for reduced grids -C> - 02-01-07 (*j*) modified for principal axes of orography -C> There are now 14 files, 4 additional for lm mb -C> - 04-04-04 (*j*) re-Test on IST/ilen calc for sea-land mask(*j*) -C> - 04-09-04 minus sign here in MAKEOA IST and IEN as in MAKEMT! -C> - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT -C> - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm -C> - 08-08-07 All input 30", UMD option, and filter as described below -C> Quadratic filter applied by default. -C> NF0 is normally set to an even value beyond the previous truncation, -C> for example, for jcap=382, NF0=254+2 -C> NF1 is set as jcap+2 (and/or nearest even), eg., for t382, NF1=382+2=384 -C> if no filter is desired then NF1=NF0=0 and ORF=ORO -C> but if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 -C> -C> INPUT FILES: -C> - UNIT5 - PHYSICS LONGITUDES (IM), PHYSICS LATITUDES (JM), -C> SPECTRAL TRUNCATION (NM), RHOMBOIDAL FLAG (NR), -C> AND FIRST AND SECOND FILTER PARAMETERS (NF0,NF1). -C> RESPECTIVELY READ IN FREE FORMAT. -C> - NCID - GMTED2010 USGS orography (NetCDF) -C> - NCID - 30" UMD land cover mask. (NetCDF) -C> - NCID - GICE Grumbine 30" RAMP Antarctica orog IMNx3601. (NetCDF) -C> - UNIT25 - Ocean land-sea mask on gaussian grid -C> -C> OUTPUT FILES: -C> - UNIT51 - SEA-LAND MASK (IM,JM) -C> - UNIT52 - GRIDDED OROGRAPHY (IM,JM) -C> - UNIT54 - SPECTRAL OROGRAPHY ((NM+1)*((NR+1)*NM+2)) -C> - UNIT55 - UNFILTERED GRIDDED OROGRAPHY (IM,JM) -C> - UNIT57 - GRIB GRIDDED OROGRAPHY (IM,JM) -C> -C> SUBPROGRAMS CALLED: -C> - UNIQUE: -C> - TERSUB - MAIN SUBPROGRAM -C> - SPLAT - COMPUTE GAUSSIAN LATITUDES OR EQUALLY-SPACED LATITUDES -C> - LIBRARY: -C> - SPTEZ - SPHERICAL TRANSFORM -C> - GBYTES - UNPACK BITS -C> -C> @return 0 for success, error code otherwise. - include 'netcdf.inc' - logical fexist, opened - integer fsize, ncid, error, id_dim, nx, ny - character(len=256) :: OUTGRID = "none" - character(len=256) :: INPUTOROG = "none" - character(len=256) :: merge_file = "none" - logical :: mask_only = .false. - integer :: MTNRES,IM,JM,NM,NR,NF0,NF1,EFAC,NW - fsize=65536 - READ(5,*) OUTGRID - READ(5,*) mask_only - READ(5,*) merge_file - NM=0 - NF0=0 - NF1=0 - EFAC=0 - NR=0 - print*, "INPUTOROG= ", trim(INPUTOROG) - print*, "MASK_ONLY", mask_only - print*, "MERGE_FILE ", trim(merge_file) -! --- MTNRES defines the input (highest) elev resolution -! --- =1 is topo30 30" in units of 1/2 minute. -! so MTNRES for old values must be *2. -! =16 is now Song Yu's 8' orog the old ops standard -! --- other possibilities are =8 for 4' and =4 for 2' see -! HJ for T1000 test. Must set to 1 for now. - MTNRES=1 - print*, MTNRES,NM,NR,NF0,NF1,EFAC - NW=(NM+1)*((NR+1)*NM+2) - IMN = 360*120/MTNRES - JMN = 180*120/MTNRES - print *, ' Starting terr12 mtnlm7_slm30.f IMN,JMN:',IMN,JMN - -! --- read the grid resolution from OUTGRID. - inquire(file=trim(OUTGRID), exist=fexist) - if(.not. fexist) then - print*, "FATAL ERROR: file "//trim(OUTGRID) - print*, " does not exist." - CALL ERREXIT(4) - endif - do ncid = 103, 512 - inquire( ncid,OPENED=opened ) - if( .NOT.opened )exit - end do - - print*, "READ outgrid=", trim(outgrid) - error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(OUTGRID) ) - error=nf_inq_dimid(ncid, 'nx', id_dim) - call netcdf_err(error, 'inquire dimension nx from file '// - & trim(OUTGRID) ) - error=nf_inq_dimlen(ncid,id_dim,nx) - call netcdf_err(error, 'inquire dimension nx length '// - & 'from file '//trim(OUTGRID) ) - - error=nf_inq_dimid(ncid, 'ny', id_dim) - call netcdf_err(error, 'inquire dimension ny from file '// - & trim(OUTGRID) ) - error=nf_inq_dimlen(ncid,id_dim,ny) - call netcdf_err(error, 'inquire dimension ny length '// - & 'from file '//trim(OUTGRID) ) - IM = nx/2 - JM = ny/2 - print*, "nx, ny, im, jm = ", nx, ny, im, jm - error=nf_close(ncid) - call netcdf_err(error, 'close file '//trim(OUTGRID) ) - - CALL TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, - & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) - STOP - END - -!> Driver routine to compute terrain. -!! -!! @param[in] IMN "i" dimension of the input terrain dataset. -!! @param[in] JMN "j" dimension of the input terrain dataset. -!! @param[in] IM "i" dimension of the model grid tile. -!! @param[in] JM "j" dimension of the model grid tile. -!! @param[in] NM Spectral truncation. -!! @param[in] NR Rhomboidal flag. -!! @param[in] NF0 First order spectral filter parameters. -!! @param[in] NF1 Second order spectral filter parameters. -!! @param[in] NW Number of waves. -!! @param[in] EFAC Factor to adjust orography by its variance. -!! @param[in] OUTGRID The 'grid' file for the model tile. -!! @param[in] INPUTOROG Input orography/GWD file on gaussian -!! grid. When specified, will be interpolated to model tile. -!! When not specified, program will create fields from -!! raw high-resolution topography data. -!! @param[in] MASK_ONLY Flag to generate the Land Mask only -!! @param[in] MERGE_FILE Ocean merge file -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC, - & OUTGRID,INPUTOROG,MASK_ONLY,MERGE_FILE) - implicit none - include 'netcdf.inc' -C - integer :: IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW - character(len=*), intent(in) :: OUTGRID - character(len=*), intent(in) :: INPUTOROG - character(len=*), intent(in) :: MERGE_FILE - - logical, intent(in) :: mask_only - - real, parameter :: MISSING_VALUE=-9999. - real, PARAMETER :: PI=3.1415926535897931 - integer, PARAMETER :: NMT=14 - - integer :: efac,zsave1,zsave2 - integer :: mskocn,notocn - integer :: i,j,nx,ny,ncid,js,jn,iw,ie,k,it,jt,error,id_dim - integer :: id_var,nx_in,ny_in,fsize,wgta,IN,INW,INE,IS,ISW,ISE - integer :: M,N,ios,istat,itest,jtest - integer :: i_south_pole,j_south_pole,i_north_pole,j_north_pole - integer :: maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 - integer(1) :: i3save - integer(2) :: i2save - - integer, allocatable :: JST(:),JEN(:),numi(:) - - integer, allocatable :: IST(:,:),IEN(:,:),ZSLMX(:,:) - integer, allocatable :: ZAVG(:,:),ZSLM(:,:) - integer(1), allocatable :: UMD(:,:) - integer(2), allocatable :: glob(:,:) - - integer, allocatable :: IWORK(:,:,:) - - real :: DEGRAD,maxlat, minlat,timef,tbeg,tend,tbeg1 - real :: PHI,DELXN,slma,oroa,vara,var4a,xn,XS,FFF,WWW - real :: sumdif,avedif - - real, allocatable :: COSCLT(:),WGTCLT(:),RCLT(:),XLAT(:),DIFFX(:) - real, allocatable :: XLON(:),ORS(:),oaa(:),ola(:),GLAT(:) - - real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) - real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) - real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:),ORF(:,:) - real, allocatable :: land_frac(:,:),lake_frac(:,:) - real, allocatable :: THETA(:,:),GAMMA(:,:),SIGMA(:,:),ELVMAX(:,:) - real, allocatable :: VAR4(:,:),SLMI(:,:) - real, allocatable :: WORK1(:,:),WORK2(:,:),WORK3(:,:),WORK4(:,:) - real, allocatable :: WORK5(:,:),WORK6(:,:) - real, allocatable :: tmpvar(:,:) - real, allocatable :: slm_in(:,:), lon_in(:,:), lat_in(:,:) - real(4), allocatable:: GICE(:,:),OCLSM(:,:) - - real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) - real, allocatable :: oa_in(:,:,:), ol_in(:,:,:) - - logical :: grid_from_file,fexist,opened - logical :: SPECTR, FILTER - logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) - - tbeg1=timef() - tbeg=timef() - fsize = 65536 -! integers - allocate (JST(JM),JEN(JM),numi(jm)) - allocate (IST(IM,jm),IEN(IM,jm),ZSLMX(2700,1350)) - allocate (glob(IMN,JMN)) - -! reals - allocate (COSCLT(JM),WGTCLT(JM),RCLT(JM),XLAT(JM),DIFFX(JM/2)) - allocate (XLON(IM),ORS(NW),oaa(4),ola(4),GLAT(JMN)) - - allocate (ZAVG(IMN,JMN)) - allocate (ZSLM(IMN,JMN)) - allocate (UMD(IMN,JMN)) - -! -! SET CONSTANTS AND ZERO FIELDS -! - DEGRAD = 180./PI - SPECTR = NM .GT. 0 ! if NM <=0 grid is assumed lat/lon - FILTER = .TRUE. ! Spectr Filter defaults true and set by NF1 & NF0 - MSKOCN = 1 ! Ocean land sea mask =1, =0 if not present - NOTOCN = 1 ! =1 Ocean lsm input reverse: Ocean=1, land=0 -! --- The LSM Gaussian file from the ocean model sometimes arrives with -! --- 0=Ocean and 1=Land or it arrives with 1=Ocean and 0=land without -! --- metadata to distinguish its disposition. The AI below mitigates this. - - print *,' In TERSUB' - if (mskocn .eq. 1)then - print *,' Ocean Model LSM Present and ' - print *, ' Overrides OCEAN POINTS in LSM: mskocn=',mskocn - if (notocn .eq. 1)then - print *,' Ocean LSM Reversed: NOTOCN=',notocn - endif - endif - - print *,' Attempt to open/read UMD 30sec slmsk.' - - error=NF__OPEN("./landcover.umd.30s.nc",NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file landcover.umd.30s.nc' ) - error=nf_inq_varid(ncid, 'land_mask', id_var) - call netcdf_err(error, 'Inquire varid of land_mask') - error=nf_get_var_int1(ncid, id_var, UMD) - call netcdf_err(error, 'Inquire data of land_mask') - error = nf_close(ncid) - - print *,' UMD lake, UMD(50,50)=',UMD(50,50) -C -C- READ_G for global 30" terrain -C - print *,' Call read_g to read global topography' - call read_g(glob) -! --- transpose even though glob 30" is from S to N and NCEP std is N to S - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - i2save = glob(I,j) - glob(I,j)=glob(I,jt) - glob(I,jt) = i2save - enddo - enddo -! --- transpose glob as USGS 30" is from dateline and NCEP std is 0 - do j=1,jmn - do I=1,imn/2 - it=imn/2 + i - i2save = glob(i,J) - glob(i,J)=glob(it,J) - glob(it,J) = i2save - enddo - enddo - print *,' After read_g, glob(500,500)=',glob(500,500) -! - -! --- IMN,JMN - print*, ' IM, JM, NM, NR, NF0, NF1, EFAC' - print*, IM,JM,NM,NR,NF0,NF1,EFAC - print *,' imn,jmn,glob(imn,jmn)=',imn,jmn,glob(imn,jmn) - print *,' UBOUND ZAVG=',UBOUND(ZAVG) - print *,' UBOUND glob=',UBOUND(glob) - print *,' UBOUND ZSLM=',UBOUND(ZSLM) - print *,' UBOUND GICE=',IMN+1,3601 - print *,' UBOUND OCLSM=',IM,JM -! -! --- 0 is ocean and 1 is land for slm -! -C -! --- ZSLM initialize with all land 1, ocean 0 - ZSLM=1 -! --- ZAVG initialize from glob - ZAVG=glob - -! --- transpose mask even though glob 30" is from N to S and NCEP std is S to N - do j=1,jmn/2 - do I=1,imn - jt=jmn - j + 1 - i3save = UMD(I,j) - UMD(I,j)=UMD(I,jt) - UMD(I,jt) = i3save - enddo - enddo -! --- transpose UMD as USGS 30" is from dateline and NCEP std is 0 - do j=1,jmn - do i=1,imn/2 - it=imn/2 + i - i3save = UMD(i,J) - UMD(i,J)=UMD(it,J) - UMD(it,J) = i3save - enddo - enddo -! --- Non-land is 0. - do j=1,jmn - do i=1,imn - if ( UMD(i,j) .eq. 0 ) ZSLM(i,j) = 0 - enddo - enddo - - deallocate (ZSLMX,UMD,glob) -! --- -! --- Fixing an error in the topo 30" data set at pole (-9999). - do i=1,imn - ZSLM(i,1)=0 - ZSLM(i,JMN)=1 - enddo -! -! print *,' kount1,2,ZAVG(1,1),ZAVG(imn,jmn),ZAVG(500,500)', -! & kount,kount2,ZAVG(1,1),ZAVG(imn,jmn),ZAVG(500,500) -! --- The center of pixel (1,1) is 89.9958333N/179.9958333W with dx/dy -! --- spacing of 1/120 degrees. -! -! When the gaussian grid routines makemt, makepc and makeoa are -! removed, numi can be removed. - do j=1,jm - numi(j)=im - enddo -! -! This code assumes that lat runs from north to south for gg! -! - - print *,' SPECTR=',SPECTR,' ** with GICE-07 **' - IF (SPECTR) THEN - CALL SPLAT(4,JM,COSCLT,WGTCLT) - DO J=1,JM/2 - RCLT(J) = ACOS(COSCLT(J)) - ENDDO - DO J = 1,JM/2 - PHI = RCLT(J) * DEGRAD - XLAT(J) = 90. - PHI - XLAT(JM-J+1) = PHI - 90. - ENDDO - ELSE - CALL SPLAT(0,JM,COSCLT,WGTCLT) - DO J=1,JM - RCLT(J) = ACOS(COSCLT(J)) - XLAT(J) = 90.0 - RCLT(J) * DEGRAD - ENDDO - ENDIF - - allocate (GICE(IMN+1,3601)) -! - sumdif = 0. - DO J = JM/2,2,-1 - DIFFX(J) = xlat(J) - XLAT(j-1) - sumdif = sumdif + DIFFX(J) - ENDDO - avedif=sumdif/(float(JM/2)) -! print *,' XLAT= avedif: ',avedif -! write (6,107) (xlat(J)-xlat(j-1),J=JM,2,-1) - print *,' XLAT=' - write (6,106) (xlat(J),J=JM,1,-1) - 106 format( 10(f7.3,1x)) - 107 format( 10(f9.5,1x)) -C - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *, - & ' Before GICE ZAVG(1,2)=',ZAVG(1,2),ZSLM(1,2) - print *, - & ' Before GICE ZAVG(1,12)=',ZAVG(1,12),ZSLM(1,12) - print *, - & ' Before GICE ZAVG(1,52)=',ZAVG(1,52),ZSLM(1,52) - print *, - & ' Before GICE ZAVG(1,112)=',ZAVG(1,JMN-112),ZSLM(1,112) - -! Read 30-sec Antarctica RAMP data. Points scan from South -! to North, and from Greenwich to Greenwich. - - error=NF__OPEN("./topography.antarctica.ramp.30s.nc", - & NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Opening RAMP topo file' ) - error=nf_inq_varid(ncid, 'topo', id_var) - call netcdf_err(error, 'Inquire varid of RAMP topo') - error=nf_get_var_real(ncid, id_var, GICE) - call netcdf_err(error, 'Inquire data of RAMP topo') - error = nf_close(ncid) - - print *,' GICE 30" Antarctica RAMP orog 43201x3601 read OK' - print *,' Processing! ' - print *,' Processing! ' - print *,' Processing! ' - do j = 1, 3601 - do i = 1, IMN - zsave1 = ZAVG(i,j) - zsave2 = ZSLM(i,j) - if( GICE(i,j) .ne. -99. .and. GICE(i,j) .ne. -1.0 ) then - if ( GICE(i,j) .gt. 0.) then - ZAVG(i,j) = int( GICE(i,j) + 0.5 ) -!! --- for GICE values less than or equal to 0 (0, -1, or -99) then -!! --- radar-sat (RAMP) values are not valid and revert back to old orog - ZSLM(i,j) = 1 - endif - endif - 152 format(1x,' ZAVG(i=',i4,' j=',i4,')=',i5,i3, - &' orig:',i5,i4,' Lat=',f7.3,f8.2,'E',' GICE=',f8.1) - enddo - enddo - - deallocate (GICE) - - allocate (OCLSM(IM,JM),SLMI(IM,JM)) -!C -C COMPUTE MOUNTAIN DATA : ORO SLM VAR (Std Dev) OC -C -! --- The coupled ocean model is already on a Guasian grid if (IM,JM) -! --- Attempt to Open the file if mskocn=1 - istat=0 - if (mskocn .eq. 1) then -! open(25,form='unformatted',iostat=istat) -! open(25,form='binary',iostat=istat) -! --- open to fort.25 with link to file in script - open(25,form='formatted',iostat=istat) - if (istat.ne.0) then - mskocn = 0 - print *,' Ocean lsm file Open failure: mskocn,istat=',mskocn,istat - else - mskocn = 1 - print *,' Ocean lsm file Opened OK: mskocn,istat=',mskocn,istat - endif -! --- Read it in - ios=0 - OCLSM=0. -! read(25,iostat=ios)OCLSM - read(25,*,iostat=ios)OCLSM - if (ios.ne.0) then - mskocn = 0 -! --- did not properly read Gaussian grid ocean land-sea mask, but -! continue using ZSLMX - print *,' Rd fail: Ocean lsm - continue, mskocn,ios=',mskocn,ios - else - mskocn = 1 - print *,' Rd OK: ocean lsm: mskocn,ios=',mskocn,ios -! --- LSM initialized to ocean mask especially for case where Ocean -! --- changed by ocean model to land to cope with its problems -! --- remember, that lake mask is in zslm to be assigned in MAKEMT. - if ( mskocn .eq. 1 ) then - DO J = 1,JM - DO I = 1,IM - if ( notocn .eq. 0 ) then - slmi(i,j) = float(NINT(OCLSM(i,j))) - else - if ( NINT(OCLSM(i,j)) .eq. 0) then - slmi(i,j) = 1 - else - slmi(i,j) = 0 - endif - endif - enddo - enddo - print *,' OCLSM',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - print *,' SLMI:',SLMI(1,1),SLMI(50,50),SLMI(75,75),SLMI(IM,JM) -! --- Diag -! WRITE(27,iostat=ios) REAL(SLMI,4) -! print *,' write SLMI/OCLSM diag input:',ios - endif - endif - - else - print *,' Not using Ocean model land sea mask' - endif - - if (mskocn .eq. 1)then - print *,' LSM:',OCLSM(1,1),OCLSM(50,50),OCLSM(75,75),OCLSM(IM,JM) - endif - - allocate (GEOLON(IM,JM),GEOLON_C(IM+1,JM+1),DX(IM,JM)) - allocate (GEOLAT(IM,JM),GEOLAT_C(IM+1,JM+1),DY(IM,JM)) - allocate (SLM(IM,JM),ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM)) - allocate (land_frac(IM,JM),lake_frac(IM,JM)) - -!--- reading grid file. - grid_from_file = .false. - is_south_pole = .false. - is_north_pole = .false. - i_south_pole = 0 - j_south_pole = 0 - i_north_pole = 0 - j_north_pole = 0 - if( trim(OUTGRID) .NE. "none" ) then - grid_from_file = .true. - inquire(file=trim(OUTGRID), exist=fexist) - if(.not. fexist) then - print*, "FATAL ERROR: file "//trim(OUTGRID) - print*, "does not exist." - CALL ERREXIT(4) - endif - do ncid = 103, 512 - inquire( ncid,OPENED=opened ) - if( .NOT.opened )exit - end do - - print*, "outgrid=", trim(outgrid) - error=NF__OPEN(trim(OUTGRID),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(OUTGRID) ) - error=nf_inq_dimid(ncid, 'nx', id_dim) - call netcdf_err(error, 'inquire dimension nx from file '// - & trim(OUTGRID) ) - nx = 2*IM - ny = 2*JM - print*, "Read the grid from file "//trim(OUTGRID) - - allocate(tmpvar(nx+1,ny+1)) - - error=nf_inq_varid(ncid, 'x', id_var) - call netcdf_err(error, 'inquire varid of x from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of x from file ' - & //trim(OUTGRID) ) - !--- adjust lontitude to be between 0 and 360. - do j = 1,ny+1; do i = 1,nx+1 - if(tmpvar(i,j) .NE. MISSING_VALUE) then - if(tmpvar(i,j) .GT. 360) tmpvar(i,j) = tmpvar(i,j) - 360 - if(tmpvar(i,j) .LT. 0) tmpvar(i,j) = tmpvar(i,j) + 360 - endif - enddo; enddo - - geolon(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolon_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - - error=nf_inq_varid(ncid, 'y', id_var) - call netcdf_err(error, 'inquire varid of y from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of y from file ' - & //trim(OUTGRID) ) - geolat(1:IM,1:JM) = tmpvar(2:nx:2,2:ny:2) - geolat_c(1:IM+1,1:JM+1) = tmpvar(1:nx+1:2,1:ny+1:2) - - !--- figure out pole location. - maxlat = -90 - minlat = 90 - i_north_pole = 0 - j_north_pole = 0 - i_south_pole = 0 - j_south_pole = 0 - do j = 1, ny+1; do i = 1, nx+1 - if( tmpvar(i,j) > maxlat ) then - i_north_pole=i - j_north_pole=j - maxlat = tmpvar(i,j) - endif - if( tmpvar(i,j) < minlat ) then - i_south_pole=i - j_south_pole=j - minlat = tmpvar(i,j) - endif - enddo ; enddo - !--- only when maxlat is close to 90. the point is north pole - if(maxlat < 89.9 ) then - i_north_pole = 0 - j_north_pole = 0 - endif - if(minlat > -89.9 ) then - i_south_pole = 0 - j_south_pole = 0 - endif - print*, "minlat=", minlat, "maxlat=", maxlat - print*, "north pole supergrid index is ", - & i_north_pole, j_north_pole - print*, "south pole supergrid index is ", - & i_south_pole, j_south_pole - deallocate(tmpvar) - - if(i_south_pole >0 .and. j_south_pole > 0) then - if(mod(i_south_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_south_pole/2 .and. (j==j_south_pole/2 - & .or. j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "south pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_south_pole/2 .or. i==i_south_pole/2+1) - & .and. (j==j_south_pole/2 .or. - & j==j_south_pole/2+1) ) then - is_south_pole(i,j) = .true. - print*, "south pole at i,j=", i, j - endif - enddo; enddo - endif - endif - if(i_north_pole >0 .and. j_north_pole > 0) then - if(mod(i_north_pole,2)==0) then ! stretched grid - do j = 1, JM; do i = 1, IM - if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - else - do j = 1, JM; do i = 1, IM - if((i==i_north_pole/2 .or. i==i_north_pole/2+1) - & .and. (j==j_north_pole/2 .or. - & j==j_north_pole/2+1) ) then - is_north_pole(i,j) = .true. - print*, "north pole at i,j=", i, j - endif - enddo; enddo - endif - endif - - - allocate(tmpvar(nx,ny)) - error=nf_inq_varid(ncid, 'area', id_var) - call netcdf_err(error, 'inquire varid of area from file ' - & //trim(OUTGRID) ) - error=nf_get_var_double(ncid, id_var, tmpvar) - call netcdf_err(error, 'inquire data of area from file ' - & //trim(OUTGRID) ) - - do j = 1, jm - do i = 1, im - dx(i,j) = sqrt(tmpvar(2*i-1,2*j-1)+tmpvar(2*i,2*j-1) - & +tmpvar(2*i-1,2*j )+tmpvar(2*i,2*j )) - dy(i,j) = dx(i,j) - enddo - enddo -! allocate(tmpvar(nx,ny+1)) - -! error=nf_inq_varid(ncid, 'dx', id_var) -! call netcdf_err(error, 'inquire varid of dx from file ' -! & //trim(OUTGRID) ) -! error=nf_get_var_double(ncid, id_var, tmpvar) -! call netcdf_err(error, 'inquire data of dx from file ' -! & //trim(OUTGRID) ) -! dx(1:IM,1:JM+1) = tmpvar(2:nx:2,1:ny+1:2) -! deallocate(tmpvar) - -! allocate(tmpvar(nx+1,ny)) -! error=nf_inq_varid(ncid, 'dy', id_var) -! call netcdf_err(error, 'inquire varid of dy from file ' -! & //trim(OUTGRID) ) -! error=nf_get_var_double(ncid, id_var, tmpvar) -! call netcdf_err(error, 'inquire data of dy from file ' -! & //trim(OUTGRID) ) -! dy(1:IM+1,1:JM) = tmpvar(1:nx+1:2,2:ny:2) - deallocate(tmpvar) - endif - tend=timef() - write(6,*)' Timer 1 time= ',tend-tbeg - ! - if(grid_from_file) then - tbeg=timef() - - IF (MERGE_FILE == 'none') then - CALL MAKE_MASK(ZSLM,SLM,land_frac,GLAT, - & IM,JM,IMN,JMN,geolon_c,geolat_c) - lake_frac=9999.9 - ELSE - print*,'Read in external mask ',merge_file - CALL READ_MASK(MERGE_FILE,SLM,land_frac,lake_frac,im,jm) - ENDIF - - IF (MASK_ONLY) THEN - print*,'Computing mask only.' - CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, - 1 1,1,GEOLON,GEOLAT) - - print*,' DONE.' - STOP - END IF - - CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, - & IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) - - tend=timef() - write(6,*)' MAKEMT2 time= ',tend-tbeg - else - CALL MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4,GLAT, - & IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif - - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,SLM,' SLM') - call minmxj(IM,JM,VAR,' VAR') - call minmxj(IM,JM,VAR4,' VAR4') -! -C check antarctic pole -! DO J = 1,JM -! DO I = 1,IM -! if ( i .le. 100 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -! if (height .eq. 0.) print *,'I,J,SLM:',I,J,SLM(I,J) -! write(6,153)i,j,ORO(i,j),HEIGHT,SLM(i,j) -! endif -! endif -! ENDDO -! ENDDO -C -C === Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA -C - allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) - if(grid_from_file) then - tbeg=timef() - CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, - 1 IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) - tend=timef() - write(6,*)' MAKEPC2 time= ',tend-tbeg - else - CALL MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA,GLAT, - 1 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif - - call minmxj(IM,JM,THETA,' THETA') - call minmxj(IM,JM,GAMMA,' GAMMA') - call minmxj(IM,JM,SIGMA,' SIGMA') - -C -C COMPUTE MOUNTAIN DATA : OA OL -C - allocate (IWORK(IM,JM,4)) - allocate (OA(IM,JM,4),OL(IM,JM,4),HPRIME(IM,JM,14)) - allocate (WORK1(IM,JM),WORK2(IM,JM),WORK3(IM,JM),WORK4(IM,JM)) - allocate (WORK5(IM,JM),WORK6(IM,JM)) - - call minmxj(IM,JM,ORO,' ORO') - print*, "inputorog=", trim(INPUTOROG) - if(grid_from_file) then - if(trim(INPUTOROG) == "none") then - print*, "calling MAKEOA2 to compute OA, OL" - tbeg=timef() - CALL MAKEOA2(ZAVG,zslm,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, - 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, - 2 IM,JM,IMN,JMN,geolon_c,geolat_c, - 3 geolon,geolat,dx,dy,is_south_pole,is_north_pole) - tend=timef() - write(6,*)' MAKEOA2 time= ',tend-tbeg - else - !-- read the data from INPUTOROG file. - error=NF__OPEN(trim(INPUTOROG),NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file '//trim(INPUTOROG) ) - error=nf_inq_dimid(ncid, 'lon', id_dim) - call netcdf_err(error, 'inquire dimension lon from file '// - & trim(INPUTOROG) ) - error=nf_inq_dimlen(ncid,id_dim,nx_in) - call netcdf_err(error, 'inquire dimension lon length '// - & 'from file '//trim(INPUTOROG) ) - error=nf_inq_dimid(ncid, 'lat', id_dim) - call netcdf_err(error, 'inquire dimension lat from file '// - & trim(INPUTOROG) ) - error=nf_inq_dimlen(ncid,id_dim,ny_in) - call netcdf_err(error, 'inquire dimension lat length '// - & 'from file '//trim(INPUTOROG) ) - - print*, "extrapolate OA, OL from Gaussian grid with nx=", - & nx_in, ", ny=", ny_in - allocate(oa_in(nx_in,ny_in,4), ol_in(nx_in,ny_in,4)) - allocate(slm_in(nx_in,ny_in) ) - allocate(lon_in(nx_in,ny_in), lat_in(nx_in,ny_in) ) - - error=nf_inq_varid(ncid, 'oa1', id_var) - call netcdf_err(error, 'inquire varid of oa1 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,1)) - call netcdf_err(error, 'inquire data of oa1 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa2', id_var) - call netcdf_err(error, 'inquire varid of oa2 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,2)) - call netcdf_err(error, 'inquire data of oa2 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa3', id_var) - call netcdf_err(error, 'inquire varid of oa3 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,3)) - call netcdf_err(error, 'inquire data of oa3 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'oa4', id_var) - call netcdf_err(error, 'inquire varid of oa4 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, oa_in(:,:,4)) - call netcdf_err(error, 'inquire data of oa4 from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'ol1', id_var) - call netcdf_err(error, 'inquire varid of ol1 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,1)) - call netcdf_err(error, 'inquire data of ol1 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol2', id_var) - call netcdf_err(error, 'inquire varid of ol2 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,2)) - call netcdf_err(error, 'inquire data of ol2 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol3', id_var) - call netcdf_err(error, 'inquire varid of ol3 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,3)) - call netcdf_err(error, 'inquire data of ol3 from file ' - & //trim(INPUTOROG) ) - error=nf_inq_varid(ncid, 'ol4', id_var) - call netcdf_err(error, 'inquire varid of ol4 from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, ol_in(:,:,4)) - call netcdf_err(error, 'inquire data of ol4 from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'slmsk', id_var) - call netcdf_err(error, 'inquire varid of slmsk from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, slm_in) - call netcdf_err(error, 'inquire data of slmsk from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'geolon', id_var) - call netcdf_err(error, 'inquire varid of geolon from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, lon_in) - call netcdf_err(error, 'inquire data of geolon from file ' - & //trim(INPUTOROG) ) - - error=nf_inq_varid(ncid, 'geolat', id_var) - call netcdf_err(error, 'inquire varid of geolat from file ' - & //trim(INPUTOROG) ) - error=nf_get_var_double(ncid, id_var, lat_in) - call netcdf_err(error, 'inquire data of geolat from file ' - & //trim(INPUTOROG) ) - - ! set slmsk=2 to be ocean (0) - do j=1,ny_in; do i=1,nx_in - if(slm_in(i,j) == 2) slm_in(i,j) = 0 - enddo; enddo - - error=nf_close(ncid) - call netcdf_err(error, 'close file ' - & //trim(INPUTOROG) ) - - print*, "calling MAKEOA3 to compute OA, OL" - CALL MAKEOA3(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO,SLM, - 1 WORK1,WORK2,WORK3,WORK4,WORK5,WORK6, - 2 IM,JM,IMN,JMN,geolon_c,geolat_c, - 3 geolon,geolat,nx_in,ny_in, - 4 oa_in,ol_in,slm_in,lon_in,lat_in) - - deallocate(oa_in,ol_in,slm_in,lon_in,lat_in) - - endif - else - CALL MAKEOA(ZAVG,VAR,GLAT,OA,OL,IWORK,ELVMAX,ORO, - 1 WORK1,WORK2,WORK3,WORK4, - 2 WORK5,WORK6, - 3 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - endif - -! Deallocate 2d vars - deallocate(IST,IEN) - deallocate (ZSLM,ZAVG) - deallocate (dx,dy) - deallocate (WORK2,WORK3,WORK4,WORK5,WORK6) - -! Deallocate 3d vars - deallocate(IWORK) - - tbeg=timef() - call minmxj(IM,JM,OA,' OA') - call minmxj(IM,JM,OL,' OL') - call minmxj(IM,JM,ELVMAX,' ELVMAX') - call minmxj(IM,JM,ORO,' ORO') - - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,IM - if (ELVMAX(I,J) .gt. 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) .gt. 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) .gt. 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) .gt. 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) .gt. 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) .gt. 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - print *,' MAXC3:',maxc3,maxc4,maxc5,maxc6,maxc7,maxc8 -! -c itest=151 -c jtest=56 -C - print *,' ===> Replacing ELVMAX with ELVMAX-ORO <=== ' - print *,' ===> if ELVMAX<=ORO replace with proxy <=== ' - print *,' ===> the sum of mean orog (ORO) and std dev <=== ' - DO J = 1,JM - DO I = 1,IM - if (ELVMAX(I,J) .lt. ORO(I,J) ) then -C--- subtracting off ORO leaves std dev (this should never happen) - ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) - else - ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) - endif - ENDDO - ENDDO - maxc3 = 0 - maxc4 = 0 - maxc5 = 0 - maxc6 = 0 - maxc7 = 0 - maxc8 = 0 - DO J = 1,JM - DO I = 1,IM - if (ELVMAX(I,J) .gt. 3000.) maxc3 = maxc3 +1 - if (ELVMAX(I,J) .gt. 4000.) maxc4 = maxc4 +1 - if (ELVMAX(I,J) .gt. 5000.) maxc5 = maxc5 +1 - if (ELVMAX(I,J) .gt. 6000.) maxc6 = maxc6 +1 - if (ELVMAX(I,J) .gt. 7000.) maxc7 = maxc7 +1 - if (ELVMAX(I,J) .gt. 8000.) maxc8 = maxc8 +1 - ENDDO - ENDDO - print *,' after MAXC 3-6 km:',maxc3,maxc4,maxc5,maxc6 -c - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! if (JM .gt. 0) stop -C -C ZERO OVER OCEAN -C - print *,' Testing at point (itest,jtest)=',itest,jtest - print *,' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - print *,' ORO(itest,jtest)=',oro(itest,jtest),itest,jtest - DO J = 1,JM - DO I = 1,IM - IF(SLM(I,J).EQ.0.) THEN -C VAR(I,J) = 0. - VAR4(I,J) = 0. - OA(I,J,1) = 0. - OA(I,J,2) = 0. - OA(I,J,3) = 0. - OA(I,J,4) = 0. - OL(I,J,1) = 0. - OL(I,J,2) = 0. - OL(I,J,3) = 0. - OL(I,J,4) = 0. -C THETA(I,J) =0. -C GAMMA(I,J) =0. -C SIGMA(I,J) =0. -C ELVMAX(I,J)=0. -! --- the sub-grid scale parameters for mtn blocking and gwd retain -! --- properties even if over ocean but there is elevation within the -! --- gaussian grid box. - ENDIF - ENDDO - ENDDO -C -! --- if mskocn=1 ocean land sea mask given, =0 if not present -! --- OCLSM is real(*4) array with fractional values possible -! --- 0 is ocean and 1 is land for slm -! --- Step 1: Only change SLM after GFS SLM is applied -! --- SLM is only field that will be altered by OCLSM -! --- Ocean land sea mask ocean points made ocean in atm model -! --- Land and Lakes and all other atm elv moments remain unchanged. - - IF (MERGE_FILE == 'none') then - - MSK_OCN : if ( mskocn .eq. 1 ) then - - DO j = 1,jm - DO i = 1,im - if (abs (oro(i,j)) .lt. 1. ) then - slm(i,j) = slmi(i,j) - else - if ( slmi(i,j) .eq. 1. .and. slm(i,j) .eq. 1) slm(i,j) = 1 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 0) slm(i,j) = 0 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 1) slm(i,j) = 0 - if ( slmi(i,j) .eq. 0. .and. slm(i,j) .eq. 0) slm(i,j) = 0 - endif - enddo - enddo - endif MSK_OCN - endif - print *,' SLM(itest,jtest)=',slm(itest,jtest),itest,jtest - print *,' ORO(itest,jtest)=',oro(itest,jtest),itest,jtest - - deallocate(SLMI) - - IF (MERGE_FILE == 'none') then - -C REMOVE ISOLATED POINTS - iso_loop : DO J=2,JM-1 - JN=J-1 - JS=J+1 - DO I=1,IM - IW=MOD(I+IM-2,IM)+1 - IE=MOD(I,IM)+1 - SLMA=SLM(IW,J)+SLM(IE,J) - OROA=ORO(IW,J)+ORO(IE,J) - VARA=VAR(IW,J)+VAR(IE,J) - VAR4A=VAR4(IW,J)+VAR4(IE,J) - DO K=1,4 - OAA(K)=OA(IW,J,K)+OA(IE,J,K) -! --- (*j*) fix typo: - OLA(K)=OL(IW,J,K)+OL(IE,J,K) - ENDDO - WGTA=2 - XN=(I-1)+1 - IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN - IN=MOD(NINT(XN)-1,IM)+1 - INW=MOD(IN+IM-2,IM)+1 - INE=MOD(IN,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+3 - ELSE - INW=INT(XN) - INE=MOD(INW,IM)+1 - SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) - OROA=OROA+ORO(INW,JN)+ORO(INE,JN) - VARA=VARA+VAR(INW,JN)+VAR(INE,JN) - VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) - DO K=1,4 - OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) - OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) - ENDDO - WGTA=WGTA+2 - ENDIF - XS=(I-1)+1 - IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN - IS=MOD(NINT(XS)-1,IM)+1 - ISW=MOD(IS+IM-2,IM)+1 - ISE=MOD(IS,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+3 - ELSE - ISW=INT(XS) - ISE=MOD(ISW,IM)+1 - SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) - OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) - VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) - VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) - DO K=1,4 - OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) - OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) - ENDDO - WGTA=WGTA+2 - ENDIF - OROA=OROA/WGTA - VARA=VARA/WGTA - VAR4A=VAR4A/WGTA - DO K=1,4 - OAA(K)=OAA(K)/WGTA - OLA(K)=OLA(K)/WGTA - ENDDO - IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN - PRINT '("SEA ",2F8.0," MODIFIED TO LAND",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=1. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN - PRINT '("LAND",2F8.0," MODIFIED TO SEA ",2F8.0," AT ",2I8)', - & ORO(I,J),VAR(I,J),OROA,VARA,I,J - SLM(I,J)=0. - ORO(I,J)=OROA - VAR(I,J)=VARA - VAR4(I,J)=VAR4A - DO K=1,4 - OA(I,J,K)=OAA(K) - OL(I,J,K)=OLA(K) - ENDDO - ENDIF - ENDDO - ENDDO iso_loop -C--- print for testing after isolated points removed - print *,' after isolated points removed' - call minmxj(IM,JM,ORO,' ORO') - print *,' ORO(itest,jtest)=',oro(itest,jtest) - print *,' VAR(itest,jtest)=',var(itest,jtest) - print *,' VAR4(itest,jtest)=',var4(itest,jtest) - print *,' OA(itest,jtest,1)=',oa(itest,jtest,1) - print *,' OA(itest,jtest,2)=',oa(itest,jtest,2) - print *,' OA(itest,jtest,3)=',oa(itest,jtest,3) - print *,' OA(itest,jtest,4)=',oa(itest,jtest,4) - print *,' OL(itest,jtest,1)=',ol(itest,jtest,1) - print *,' OL(itest,jtest,2)=',ol(itest,jtest,2) - print *,' OL(itest,jtest,3)=',ol(itest,jtest,3) - print *,' OL(itest,jtest,4)=',ol(itest,jtest,4) - print *,' Testing at point (itest,jtest)=',itest,jtest - print *,' THETA(itest,jtest)=',theta(itest,jtest) - print *,' GAMMA(itest,jtest)=',GAMMA(itest,jtest) - print *,' SIGMA(itest,jtest)=',SIGMA(itest,jtest) - print *,' ELVMAX(itest,jtest)=',ELVMAX(itest,jtest) - print *,' EFAC=',EFAC - - endif - -C - DO J=1,JM - DO I=1,IM - ORO(I,J) = ORO(I,J) + EFAC*VAR(I,J) - HPRIME(I,J,1) = VAR(I,J) - HPRIME(I,J,2) = VAR4(I,J) - HPRIME(I,J,3) = oa(I,J,1) - HPRIME(I,J,4) = oa(I,J,2) - HPRIME(I,J,5) = oa(I,J,3) - HPRIME(I,J,6) = oa(I,J,4) - HPRIME(I,J,7) = ol(I,J,1) - HPRIME(I,J,8) = ol(I,J,2) - HPRIME(I,J,9) = ol(I,J,3) - HPRIME(I,J,10)= ol(I,J,4) - HPRIME(I,J,11)= THETA(I,J) - HPRIME(I,J,12)= GAMMA(I,J) - HPRIME(I,J,13)= SIGMA(I,J) - HPRIME(I,J,14)= ELVMAX(I,J) - ENDDO - ENDDO -! - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') -! --- Quadratic filter applied by default. -! --- NF0 is normally set to an even value beyond the previous truncation, -! --- for example, for jcap=382, NF0=254+2 -! --- NF1 is set as jcap+2 (and/or nearest even), eg., for t382, NF1=382+2=384 -! --- if no filter is desired then NF1=NF0=0 and ORF=ORO -! --- if no filter but spectral to grid (with gibbs) then NF1=jcap+2, and NF1=jcap+1 -! - deallocate(VAR4) - allocate (ORF(IM,JM)) - IF ( NF1 - NF0 .eq. 0 ) FILTER=.FALSE. - print *,' NF1, NF0, FILTER=',NF1,NF0,FILTER - IF (FILTER) THEN -C SPECTRALLY TRUNCATE AND FILTER OROGRAPHY - - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORO,-1) -! - print *,' about to apply spectral filter ' - FFF=1./(NF1-NF0)**2 - I=0 - DO M=0,NM - DO N=M,NM+NR*M - IF(N.GT.NF0) THEN - WWW=MAX(1.-FFF*(N-NF0)**2,0.) - ORS(I+1)=ORS(I+1)*WWW - ORS(I+2)=ORS(I+2)*WWW - ENDIF - I=I+2 - ENDDO - ENDDO -! - CALL SPTEZ(NR,NM,4,IM,JM,ORS,ORF,+1) - - ELSE - ORS=0. - ORF=ORO - ENDIF - - deallocate (WORK1) - - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) - print *,' after spectral filter is applied' - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') -C - print *,' after nearest neighbor interpolation applied ' - call minmxj(IM,JM,ORO,' ORO') - call minmxj(IM,JM,ORF,' ORF') - call mnmxja(IM,JM,ELVMAX,itest,jtest,' ELVMAX') - print *,' ORO,ORF(itest,jtest),itest,jtest:', - & ORO(itest,jtest),ORF(itest,jtest),itest,jtest - print *,' ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) - - -C check antarctic pole - DO J = 1,JM - DO I = 1,IM - if ( i .le. 21 .and. i .ge. 1 )then - if (j .eq. JM )write(6,153)i,j,ORO(i,j),ELVMAX(i,j),SLM(i,j) - 153 format(1x,' ORO,ELVMAX(i=',i4,' j=',i4,')=',2E14.5,f5.1) - endif - ENDDO - ENDDO - tend=timef() - write(6,*)' Timer 5 time= ',tend-tbeg -C - DELXN = 360./IM - do i=1,im - xlon(i) = DELXN*(i-1) - enddo - IF(trim(OUTGRID) == "none") THEN - do j=1,jm - do i=1,im - geolon(i,j) = xlon(i) - geolat(i,j) = xlat(j) - enddo - enddo - else - do j = 1, jm - xlat(j) = geolat(1,j) - enddo - do i = 1, im - xlon(i) = geolon(i,1) - enddo - endif - - tbeg=timef() - CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,ORF,HPRIME,1,1, - 1 GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) - tend=timef() - write(6,*)' WRITE_NETCDF time= ',tend-tbeg - print *,' wrote netcdf file out.oro.tile?.nc' - - print *,' ===== Deallocate Arrays and ENDING MTN VAR OROG program' - -! Deallocate 1d vars - deallocate(JST,JEN,numi) - deallocate(COSCLT,WGTCLT,RCLT,XLAT,DIFFX,XLON,ORS,oaa,ola,GLAT) - -! Deallocate 2d vars - deallocate (OCLSM) - deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) - deallocate (SLM,ORO,VAR,ORF,land_frac) - deallocate (THETA,GAMMA,SIGMA,ELVMAX) - - - tend=timef() - write(6,*)' Total runtime time= ',tend-tbeg1 - RETURN - END SUBROUTINE TERSUB - -!> Create the orography, land-mask, standard deviation of -!! orography and the convexity on a model gaussian grid. -!! This routine was used for the spectral GFS model. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] oro Orography on the model grid. -!! @param[out] slm Land-mask on the model grid. -!! @param[out] var Standard deviation of orography on the model grid. -!! @param[out] var4 Convexity on the model grid. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! the high-resolution dataset with respect to the 'east' edge -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the hi-res input orog/mask dataset. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask dataset. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEMT(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - DIMENSION GLAT(JMN),XLAT(JM) -! REAL*4 OCLSM - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - DIMENSION ORO(IM,JM),SLM(IM,JM),VAR(IM,JM),VAR4(IM,JM) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - LOGICAL FLAG -C -! ---- OCLSM holds the ocean (im,jm) grid - print *,' _____ SUBROUTINE MAKEMT ' -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 - DO J=1,JM - DO I=1,numi(j) - IM1 = numi(j) - 1 - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 + 1 -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 -C - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -! -! if ( I .lt. 10 .and. J .ge. JM-1 ) -! 1 PRINT*,' MAKEMT: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO -! if ( J .ge. JM-1 ) then -! print *,' *** FACLON=',FACLON, 'numi(j=',j,')=',numi(j) -! endif - ENDDO - print *,' DELX=',DELX,' DELXN=',DELXN - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO -CX PRINT*, ' J JST JEN ',J,JST(J),JEN(J),XLAT(J),GLAT(J1) - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) -! PRINT*, ' JM JST JEN=',JST(JM),JEN(JM),XLAT(JM),GLAT(JMN) -C -C...FIRST, AVERAGED HEIGHT -C - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = 0.0 - VAR(I,J) = 0.0 - VAR4(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - XL1 = 0.0 - XS1 = 0.0 - XW1 = 0.0 - XW2 = 0.0 - XW4 = 0.0 - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN -! if ( i .le. 10 .and. i .ge. 1 ) then -! if (j .eq. JM ) -! &print *,' J,JST,JEN,IST,IEN,I1=', -! &J,JST(j),JEN(J),IST(I,j),IEN(I,j),I1 -! endif - DO J1=JST(J),JEN(J) - XLAND = XLAND + FLOAT(ZSLM(I1,J1)) - XWATR = XWATR + FLOAT(1-ZSLM(I1,J1)) - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I1,J1)) -C......... - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) - XW1 = XW1 + HEIGHT - XW2 = XW2 + HEIGHT ** 2 -C check antarctic pole -! if ( i .le. 10 .and. i .ge. 1 )then -! if (j .ge. JM-1 )then -C=== degub testing -! print *," I,J,I1,J1,XL1,XS1,XW1,XW2:",I,J,I1,J1,XL1,XS1,XW1,XW2 -! 153 format(1x,' ORO,ELVMAX(i=',i4,' j=',i4,')=',2E14.5,3f5.1) -! endif -! endif - ENDDO - ENDDO - IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied - - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J).NE.0.) THEN - ORO(I,J)= XL1 / XLAND - ELSE - ORO(I,J)= XS1 / XWATR - ENDIF - VAR(I,J)=SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) - DO II1 = 1, IEN(I,j) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XW4 = XW4 + (HEIGHT-ORO(I,J)) ** 4 - ENDDO - ENDDO - IF(VAR(I,J).GT.1.) THEN -! if ( I .lt. 20 .and. J .ge. JM-19 ) then -! print *,'I,J,XW4,XNSUM,VAR(I,J)',I,J,XW4,XNSUM,VAR(I,J) -! endif - VAR4(I,J) = MIN(XW4/XNSUM/VAR(I,J) **4,10.) - ENDIF - ENDIF - ENDDO - ENDDO - WRITE(6,*) "! MAKEMT ORO SLM VAR VAR4 DONE" -C - - RETURN - END - -!> Determine the location of a cubed-sphere point within -!! the high-resolution orography data. The location is -!! described by the range of i/j indices on the high-res grid. -!! -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data set. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data set. -!! @param[in] npts Number of vertices to describe the cubed-sphere point. -!! @param[in] lonO The longitudes of the cubed-sphere vertices. -!! @param[in] latO The latitudes of the cubed-sphere vertices. -!! @param[in] delxn Resolution of the high-resolution orography -!! data set. -!! @param[out] jst Starting 'j' index on the high-resolution grid. -!! @param[out] jen Ending 'j' index on the high-resolution grid. -!! @param[out] ilist List of 'i' indices on the high-resolution grid. -!! @param[out] numx The number of 'i' indices on the high-resolution -!! grid. -!! @author GFDL programmer - SUBROUTINE get_index(IMN,JMN,npts,lonO,latO,DELXN, - & jst,jen,ilist,numx) - implicit none - integer, intent(in) :: IMN,JMN - integer :: npts - real, intent(in) :: LONO(npts), LATO(npts) - real, intent(in) :: DELXN - integer, intent(out) :: jst,jen - integer, intent(out) :: ilist(IMN) - integer, intent(out) :: numx - real minlat,maxlat,minlon,maxlon - integer i2, ii, ist, ien - - minlat = minval(LATO) - maxlat = maxval(LATO) - minlon = minval(LONO) - maxlon = maxval(LONO) - ist = minlon/DELXN+1 - ien = maxlon/DELXN+1 - jst = (minlat+90)/DELXN+1 - jen = (maxlat+90)/DELXN - !--- add a few points to both ends of j-direction - jst = jst - 5 - if(jst<1) jst = 1 - jen = jen + 5 - if(jen>JMN) jen = JMN - - !--- when around the pole, just search through all the points. - if((jst == 1 .OR. jen == JMN) .and. - & (ien-ist+1 > IMN/2) )then - numx = IMN - do i2 = 1, IMN - ilist(i2) = i2 - enddo - else if( ien-ist+1 > IMN/2 ) then ! cross longitude = 0 - !--- find the minimum that greater than IMN/2 - !--- and maximum that less than IMN/2 - ist = 0 - ien = IMN+1 - do i2 = 1, npts - ii = LONO(i2)/DELXN+1 - if(ii <0 .or. ii>IMN) print*,"ii=",ii,IMN,LONO(i2),DELXN - if( ii < IMN/2 ) then - ist = max(ist,ii) - else if( ii > IMN/2 ) then - ien = min(ien,ii) - endif - enddo - if(ist<1 .OR. ist>IMN) then - print*, "FATAL ERROR: ist<1 .or. ist>IMN" - call ABORT() - endif - if(ien<1 .OR. ien>IMN) then - print*, "FATAL ERROR: iend<1 .or. iend>IMN" - call ABORT() - endif - - numx = IMN - ien + 1 - do i2 = 1, numx - ilist(i2) = ien + (i2-1) - enddo - do i2 = 1, ist - ilist(numx+i2) = i2 - enddo - numx = numx+ist - else - numx = ien-ist+1 - do i2 = 1, numx - ilist(i2) = ist + (i2-1) - enddo - endif - - END - -!> Create the land-mask, land fraction. -!! This routine is used for the FV3GFS model. -!! -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] slm Land-mask on the model tile. -!! @param[out] land_frac Land fraction on the model tile. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. -!! @param[in] lon_c Longitude of the model grid corner points. -!! @param[in] lat_c Latitude on the model grid corner points. -!! @author GFDL Programmer - SUBROUTINE MAKE_MASK(zslm,SLM,land_frac, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c) - implicit none - real, parameter :: D2R = 3.14159265358979/180. - integer, parameter :: MAXSUM=20000000 - integer IM, JM, IMN, JMN, jst, jen - real GLAT(JMN), GLON(IMN) - INTEGER ZSLM(IMN,JMN) - real land_frac(IM,JM) - real SLM(IM,JM) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real LONO(4),LATO(4),LONI,LATI - integer JM1,i,j,nsum,nsum_all,ii,jj,numx,i2 - integer ilist(IMN) - real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1 - real XNSUM_ALL,XLAND_ALL,XWATR_ALL - logical inside_a_polygon -C -! ---- OCLSM holds the ocean (im,jm) grid - print *,' _____ SUBROUTINE MAKE_MASK ' -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - DO I=1,IMN - GLON(I) = 0. + (I-1) * DELXN + DELXN * 0.5 - ENDDO - - land_frac(:,:) = 0.0 -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,lono, -!$omp* lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati, -!$omp* xnsum_all,xland_all,xwatr_all,nsum_all) -!$omp* - DO J=1,JM -! print*, "J=", J - DO I=1,IM - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - nsum = 0 - XNSUM_ALL = 0.0 - XLAND_ALL = 0.0 - XWATR_ALL = 0.0 - nsum_all = 0 - - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - do jj = jst, jen; do i2 = 1, numx - ii = ilist(i2) - LONI = ii*DELXN - LATI = -90 + jj*DELXN - - XLAND_ALL = XLAND_ALL + FLOAT(ZSLM(ii,jj)) - XWATR_ALL = XWATR_ALL + FLOAT(1-ZSLM(ii,jj)) - XNSUM_ALL = XNSUM_ALL + 1. - nsum_all = nsum_all+1 - if(nsum_all > MAXSUM) then - print*, "FATAL ERROR: nsum_all is greater than MAXSUM," - print*, "increase MAXSUM." - call ABORT() - endif - - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - - XLAND = XLAND + FLOAT(ZSLM(ii,jj)) - XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) - XNSUM = XNSUM + 1. - nsum = nsum+1 - if(nsum > MAXSUM) then - print*, "FATAL ERROR: nsum is greater than MAXSUM," - print*, "increase MAXSUM." - call ABORT() - endif - endif - enddo ; enddo - - - IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied - land_frac(i,j) = XLAND/XNSUM - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - ELSEIF(XNSUM_ALL.GT.1.) THEN - land_frac(i,j) = XLAND_ALL/XNSUM _ALL - SLM(I,J) = FLOAT(NINT(XLAND_ALL/XNSUM_ALL)) - ELSE - print*, "FATAL ERROR: no source points in MAKE_MASK." - call ABORT() - ENDIF - ENDDO - ENDDO -!$omp end parallel do - WRITE(6,*) "! MAKE_MASK DONE" -C - RETURN - END SUBROUTINE MAKE_MASK -!> Create the orography, land-mask, land fraction, standard -!! deviation of orography and the convexity on a model -!! cubed-sphere tile. This routine is used for the FV3GFS model. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] oro Orography on the model tile. -!! @param[in] slm Land-mask on the model tile. -!! @param[out] var Standard deviation of orography on the model tile. -!! @param[out] var4 Convexity on the model tile. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. -!! @param[in] lon_c Longitude of the model grid corner points. -!! @param[in] lat_c Latitude on the model grid corner points. -!! @param[in] lake_frac Fractional lake within the grid -!! @param[in] land_frac Fractional land within the grid -!! @author GFDL Programmer - SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) - implicit none - real, parameter :: D2R = 3.14159265358979/180. - integer, parameter :: MAXSUM=20000000 - real, dimension(:), allocatable :: hgt_1d, hgt_1d_all - integer IM, JM, IMN, JMN - real GLAT(JMN), GLON(IMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real ORO(IM,JM),VAR(IM,JM),VAR4(IM,JM) - real, intent(in) :: SLM(IM,JM), lake_frac(im,jm),land_frac(im,jm) - integer JST, JEN - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real LONO(4),LATO(4),LONI,LATI - real HEIGHT - integer JM1,i,j,nsum,nsum_all,ii,jj,i1,numx,i2 - integer ilist(IMN) - real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1,XW2,XW4 - real XNSUM_ALL,XLAND_ALL,XWATR_ALL,HEIGHT_ALL - real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL - logical inside_a_polygon -C -! ---- OCLSM holds the ocean (im,jm) grid -! --- mskocn=1 Use ocean model sea land mask, OK and present, -! --- mskocn=0 dont use Ocean model sea land mask, not OK, not present - print *,' _____ SUBROUTINE MAKEMT2 ' - allocate(hgt_1d(MAXSUM)) - allocate(hgt_1d_all(MAXSUM)) -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - DO I=1,IMN - GLON(I) = 0. + (I-1) * DELXN + DELXN * 0.5 - ENDDO - -! land_frac(:,:) = 0.0 -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C (*j*) for hard wired zero offset (lambda s =0) for terr05 -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,xw2,xw4,lono, -!$omp* lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati,height, -!$omp* hgt_1d, -!$omp* xnsum_all,xland_all,xwatr_all,nsum_all, -!$omp* xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, -!$omp* height_all,hgt_1d_all) - DO J=1,JM -! print*, "J=", J - DO I=1,IM - ORO(I,J) = 0.0 - VAR(I,J) = 0.0 - VAR4(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - nsum = 0 - XL1 = 0.0 - XS1 = 0.0 - XW1 = 0.0 - XW2 = 0.0 - XW4 = 0.0 - XNSUM_ALL = 0.0 - XLAND_ALL = 0.0 - XWATR_ALL = 0.0 - nsum_all = 0 - XL1_ALL = 0.0 - XS1_ALL = 0.0 - XW1_ALL = 0.0 - XW2_ALL = 0.0 - XW4_ALL = 0.0 - - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - do jj = jst, jen; do i2 = 1, numx - ii = ilist(i2) - LONI = ii*DELXN - LATI = -90 + jj*DELXN - - XLAND_ALL = XLAND_ALL + FLOAT(ZSLM(ii,jj)) - XWATR_ALL = XWATR_ALL + FLOAT(1-ZSLM(ii,jj)) - XNSUM_ALL = XNSUM_ALL + 1. - HEIGHT_ALL = FLOAT(ZAVG(ii,jj)) - nsum_all = nsum_all+1 - if(nsum_all > MAXSUM) then - print*, "FATAL ERROR: nsum_all is greater than MAXSUM," - print*, "increase MAXSUM." - call ABORT() - endif - hgt_1d_all(nsum_all) = HEIGHT_ALL - IF(HEIGHT_ALL.LT.-990.) HEIGHT_ALL = 0.0 - XL1_ALL = XL1_ALL + HEIGHT_ALL * FLOAT(ZSLM(ii,jj)) - XS1_ALL = XS1_ALL + HEIGHT_ALL * FLOAT(1-ZSLM(ii,jj)) - XW1_ALL = XW1_ALL + HEIGHT_ALL - XW2_ALL = XW2_ALL + HEIGHT_ALL ** 2 - - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - - XLAND = XLAND + FLOAT(ZSLM(ii,jj)) - XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(ii,jj)) - nsum = nsum+1 - if(nsum > MAXSUM) then - print*, "FATAL ERROR: nsum is greater than MAXSUM," - print*, "increase MAXSUM." - call ABORT() - endif - hgt_1d(nsum) = HEIGHT - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(ii,jj)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(ii,jj)) - XW1 = XW1 + HEIGHT - XW2 = XW2 + HEIGHT ** 2 - endif - enddo ; enddo - - IF(XNSUM.GT.1.) THEN -! --- SLM initialized with OCLSM calc from all land points except .... -! --- 0 is ocean and 1 is land for slm -! --- Step 1 is to only change SLM after GFS SLM is applied - - !IF(SLM(I,J).NE.0.) THEN - IF(SLM(I,J) .NE. 0. .OR. LAND_FRAC(I,J) > 0.) THEN - IF (XLAND > 0) THEN - ORO(I,J)= XL1 / XLAND - ELSE - ORO(I,J)= XS1 / XWATR - ENDIF - ELSE - IF (XWATR > 0) THEN - ORO(I,J)= XS1 / XWATR - ELSE - ORO(I,J)= XL1 / XLAND - ENDIF - ENDIF - - VAR(I,J)=SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) - do I1 = 1, NSUM - XW4 = XW4 + (hgt_1d(I1) - ORO(i,j)) ** 4 - enddo - - IF(VAR(I,J).GT.1.) THEN - VAR4(I,J) = MIN(XW4/XNSUM/VAR(I,J) **4,10.) - ENDIF - - ELSEIF(XNSUM_ALL.GT.1.) THEN - - !IF(SLM(I,J).NE.0.) THEN - IF(SLM(I,J) .NE. 0. .OR. LAND_FRAC(I,J) > 0.) THEN - IF (XLAND_ALL > 0) THEN - ORO(I,J)= XL1_ALL / XLAND_ALL - ELSE - ORO(I,J)= XS1_ALL / XWATR_ALL - ENDIF - ELSE - IF (XWATR_ALL > 0) THEN - ORO(I,J)= XS1_ALL / XWATR_ALL - ELSE - ORO(I,J)= XL1_ALL / XLAND_ALL - ENDIF - ENDIF - - VAR(I,J)=SQRT(MAX(XW2_ALL/XNSUM_ALL- - & (XW1_ALL/XNSUM_ALL)**2,0.)) - do I1 = 1, NSUM_ALL - XW4_ALL = XW4_ALL + - & (hgt_1d_all(I1) - ORO(i,j)) ** 4 - enddo - - IF(VAR(I,J).GT.1.) THEN - VAR4(I,J) = MIN(XW4_ALL/XNSUM_ALL/VAR(I,J) **4,10.) - ENDIF - ELSE - print*, "FATAL ERROR: no source points in MAKEMT2." - call ABORT() - ENDIF - -! set orog to 0 meters at ocean. -! IF (LAKE_FRAC(I,J) .EQ. 0. .AND. SLM(I,J) .EQ. 0.)THEN - IF (LAKE_FRAC(I,J) .EQ. 0. .AND. LAND_FRAC(I,J) .EQ. 0.)THEN - ORO(I,J) = 0.0 - ENDIF - - ENDDO - ENDDO -!$omp end parallel do - WRITE(6,*) "! MAKEMT2 ORO SLM VAR VAR4 DONE" -C - deallocate(hgt_1d) - deallocate(hgt_1d_all) - RETURN - END - -!> Make the principle coordinates - slope of orography, -!! anisotropy, angle of mountain range with respect to east. -!! This routine is used for spectral GFS gaussian grids. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] theta Angle of mountain range with respect to -!! east for each model point. -!! @param[out] gamma Anisotropy for each model point. -!! @param[out] sigma Slope of orography for each model point. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEPC(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) -C -C=== PC: principal coordinates of each Z avg orog box for L&M -C - parameter(REARTH=6.3712E+6) - DIMENSION GLAT(JMN),XLAT(JM),DELTAX(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - DIMENSION ORO(IM,JM),SLM(IM,JM),HL(IM,JM),HK(IM,JM) - DIMENSION HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - DIMENSION THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM),numi(jm) - LOGICAL FLAG, DEBUG -C=== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -C - PI = 4.0 * ATAN(1.0) - CERTH = PI * REARTH -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION - DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC: DELTAY=',DELTAY -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - DELTAX(J) = DELTAY * COS(GLAT(J)*PI/180.0) - ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - DO J=1,JM - DO I=1,numi(j) -C IM1 = numi(j) - 1 - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 -C if (debug) then -C if ( I .lt. 10 .and. J .lt. 10 ) -C 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) -C endif -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN - if (debug) then - if ( I .lt. 10 .and. J .lt. 10 ) - 1 PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - endif - IF (IEN(I,j) .LT. IST(I,j)) - 1 print *,' MAKEPC: IEN < IST: I,J,IST(I,J),IEN(I,J)', - 2 I,J,IST(I,J),IEN(I,J) - ENDDO - ENDDO - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 - JEN(J+1) = J1 - 1 - FLAG = .FALSE. - ENDIF - ENDDO - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) - if (debug) then - PRINT*, ' IST,IEN(1,1-numi(1,JM))',IST(1,1),IEN(1,1), - 1 IST(numi(JM),JM),IEN(numi(JM),JM), numi(JM) - PRINT*, ' JST,JEN(1,JM) ',JST(1),JEN(1),JST(JM),JEN(JM) - endif -C -C... DERIVITIVE TENSOR OF HEIGHT -C - DO J=1,JM - DO I=1,numi(j) - ORO(I,J) = 0.0 - HX2(I,J) = 0.0 - HY2(I,J) = 0.0 - HXY(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - XWATR = 0.0 - XL1 = 0.0 - XS1 = 0.0 - xfp = 0.0 - yfp = 0.0 - xfpyfp = 0.0 - xfp2 = 0.0 - yfp2 = 0.0 - HL(I,J) = 0.0 - HK(I,J) = 0.0 - HLPRIM(I,J) = 0.0 - THETA(I,J) = 0.0 - GAMMA(I,J) = 0. - SIGMA2(I,J) = 0. - SIGMA(I,J) = 0. -C - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 - IF(I1.LE.0.) I1 = I1 + IMN - IF(I1.GT.IMN) I1 = I1 - IMN -C -C=== set the rest of the indexs for ave: 2pt staggered derivitive -C - i0 = i1 - 1 - if (i1 - 1 .le. 0 ) i0 = i0 + imn - if (i1 - 1 .gt. imn) i0 = i0 - imn -C - ip1 = i1 + 1 - if (i1 + 1 .le. 0 ) ip1 = ip1 + imn - if (i1 + 1 .gt. imn) ip1 = ip1 - imn -C - DO J1=JST(J),JEN(J) - if (debug) then - if ( I1 .eq. IST(I,J) .and. J1 .eq. JST(J) ) - 1 PRINT*, ' J, J1,IST,JST,DELTAX,GLAT ', - 2 J,J1,IST(I,J),JST(J),DELTAX(J1),GLAT(J1) - if ( I1 .eq. IEN(I,J) .and. J1 .eq. JEN(J) ) - 1 PRINT*, ' J, J1,IEN,JEN,DELTAX,GLAT ', - 2 J,J1,IEN(I,J),JEN(J),DELTAX(J1),GLAT(J1) - endif - XLAND = XLAND + FLOAT(ZSLM(I1,J1)) - XWATR = XWATR + FLOAT(1-ZSLM(I1,J1)) - XNSUM = XNSUM + 1. -C - HEIGHT = FLOAT(ZAVG(I1,J1)) - hi0 = float(zavg(i0,j1)) - hip1 = float(zavg(ip1,j1)) -C - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - if(hi0 .lt. -990.) hi0 = 0.0 - if(hip1 .lt. -990.) hip1 = 0.0 -C........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -C -! --- not at boundaries -!RAB if ( J1 .ne. JST(1) .and. J1 .ne. JEN(JM) ) then - if ( J1 .ne. JST(JM) .and. J1 .ne. JEN(1) ) then - hj0 = float(zavg(i1,j1-1)) - hjp1 = float(zavg(i1,j1+1)) - if(hj0 .lt. -990.) hj0 = 0.0 - if(hjp1 .lt. -990.) hjp1 = 0.0 -C....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 -C -C..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then -C === the NH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JST(1) ) then - elseif ( J1 .eq. JST(JM) ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn -C..... at N pole we stay at the same latitude j1 but cross to opp side - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 -C....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY - yfp = 0.5 * ( ( 0.5 * ( hijax - hi1j1 ) ) )/DELTAY - yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) - 1 / DELTAY )**2 -C -C === the SH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JEN(JM) ) then - elseif ( J1 .eq. JEN(1) ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 - if ( i1 .lt. 5 )print *,' S.Pole i1,j1 :',i1,j1,hijax,hi1j1 -C..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) - 1 / DELTAY )**2 - endif -C -C === The above does an average across the pole for the bndry in j. -C23456789012345678901234567890123456789012345678901234567890123456789012...... -C - xfpyfp = xfpyfp + xfp * yfp - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I1,J1)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I1,J1)) -C -C === average the HX2, HY2 and HXY -C === This will be done over all land -C - ENDDO - ENDDO -C -C === HTENSR -C - IF(XNSUM.GT.1.) THEN - SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM(I,J).NE.0.) THEN - ORO(I,J)= XL1 / XLAND - HX2(I,J) = xfp2 / XLAND - HY2(I,J) = yfp2 / XLAND - HXY(I,J) = xfpyfp / XLAND - ELSE - ORO(I,J)= XS1 / XWATR - ENDIF -C=== degub testing - if (debug) then - print *," I,J,i1,j1,HEIGHT:", I,J,i1,j1,HEIGHT, - 1 XLAND,SLM(i,j) - print *," xfpyfp,xfp2,yfp2:",xfpyfp,xfp2,yfp2 - print *," HX2,HY2,HXY:",HX2(I,J),HY2(I,J),HXY(I,J) - ENDIF -C -C === make the principal axes, theta, and the degree of anisotropy, -C === and sigma2, the slope parameter -C - HK(I,J) = 0.5 * ( HX2(I,J) + HY2(I,J) ) - HL(I,J) = 0.5 * ( HX2(I,J) - HY2(I,J) ) - HLPRIM(I,J) = SQRT(HL(I,J)*HL(I,J) + HXY(I,J)*HXY(I,J)) - IF( HL(I,J).NE. 0. .AND. SLM(I,J) .NE. 0. ) THEN -C - THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) * 180.0 / PI -C === for testing print out in degrees -C THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) - ENDIF - SIGMA2(I,J) = ( HK(I,J) + HLPRIM(I,J) ) - if ( SIGMA2(I,J) .GE. 0. ) then - SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) .ne. 0. .and. - & HK(I,J) .GE. HLPRIM(I,J) ) - 1 GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) - else - SIGMA(I,J)=0. - endif - ENDIF - if (debug) then - print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J), - 1 SIGMA(I,J),GAMMA(I,J) - print *," HK,HL,HLPRIM:",HK(I,J),HL(I,J),HLPRIM(I,J) - endif - ENDDO - ENDDO - WRITE(6,*) "! MAKE Principal Coord DONE" -C - RETURN - END - -!> Make the principle coordinates - slope of orography, -!! anisotropy, angle of mountain range with respect to east. -!! This routine is used for the FV3GFS cubed-sphere grid. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] zslm The high-resolution input land-mask dataset. -!! @param[out] theta Angle of mountain range with respect to -!! east for each model point. -!! @param[out] gamma Anisotropy for each model point. -!! @param[out] sigma Slope of orography for each model point. -!! @param[out] glat Latitude of each row of the high-resolution -!! orography and land-mask datasets. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. -!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. -!! @param[in] lon_c Longitude of model grid corner points. -!! @param[in] lat_c Latitude of the model grid corner points. -!! @param[in] SLM mask -!! @author GFDL Programmer - SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, - 1 GLAT,IM,JM,IMN,JMN,lon_c,lat_c,SLM) -C -C=== PC: principal coordinates of each Z avg orog box for L&M -C - implicit none - real, parameter :: REARTH=6.3712E+6 - real, parameter :: D2R = 3.14159265358979/180. - integer :: IM,JM,IMN,JMN - real :: GLAT(JMN),DELTAX(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real, intent(in) :: SLM(IM,JM) - real HL(IM,JM),HK(IM,JM) - real HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) - real THETA(IM,JM),GAMMA(IM,JM),SIGMA2(IM,JM),SIGMA(IM,JM) - real PI,CERTH,DELXN,DELTAY,XNSUM,XLAND - real xfp,yfp,xfpyfp,xfp2,yfp2 - real hi0,hip1,hj0,hjp1,hijax,hi1j1 - real LONO(4),LATO(4),LONI,LATI - integer i,j,i1,j1,i2,jst,jen,numx,i0,ip1,ijax - integer ilist(IMN) - logical inside_a_polygon - LOGICAL DEBUG -C=== DATA DEBUG/.TRUE./ - DATA DEBUG/.FALSE./ -C - PI = 4.0 * ATAN(1.0) - CERTH = PI * REARTH -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION - DELTAY = CERTH / FLOAT(JMN) - print *, 'MAKEPC2: DELTAY=',DELTAY -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - DELTAX(J) = DELTAY * COS(GLAT(J)*D2R) - ENDDO -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - -C... DERIVITIVE TENSOR OF HEIGHT -C -!$omp parallel do -!$omp* private (j,i,xnsum,xland,xfp,yfp,xfpyfp, -!$omp* xfp2,yfp2,lono,lato,jst,jen,ilist,numx,j1,i2,i1, -!$omp* loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, -!$omp* hijax,hi1j1) - JLOOP : DO J=1,JM -! print*, "J=", J - ILOOP : DO I=1,IM - HX2(I,J) = 0.0 - HY2(I,J) = 0.0 - HXY(I,J) = 0.0 - XNSUM = 0.0 - XLAND = 0.0 - xfp = 0.0 - yfp = 0.0 - xfpyfp = 0.0 - xfp2 = 0.0 - yfp2 = 0.0 - HL(I,J) = 0.0 - HK(I,J) = 0.0 - HLPRIM(I,J) = 0.0 - THETA(I,J) = 0.0 - GAMMA(I,J) = 0. - SIGMA2(I,J) = 0. - SIGMA(I,J) = 0. - - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - - do j1 = jst, jen; do i2 = 1, numx - i1 = ilist(i2) - LONI = i1*DELXN - LATI = -90 + j1*DELXN - INSIDE : if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - -C=== set the rest of the indexs for ave: 2pt staggered derivitive -C - i0 = i1 - 1 - if (i1 - 1 .le. 0 ) i0 = i0 + imn - if (i1 - 1 .gt. imn) i0 = i0 - imn -C - ip1 = i1 + 1 - if (i1 + 1 .le. 0 ) ip1 = ip1 + imn - if (i1 + 1 .gt. imn) ip1 = ip1 - imn - - XLAND = XLAND + FLOAT(ZSLM(I1,J1)) - XNSUM = XNSUM + 1. -C - hi0 = float(zavg(i0,j1)) - hip1 = float(zavg(ip1,j1)) -C - if(hi0 .lt. -990.) hi0 = 0.0 - if(hip1 .lt. -990.) hip1 = 0.0 -C........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) - xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 -C -! --- not at boundaries -!RAB if ( J1 .ne. JST(1) .and. J1 .ne. JEN(JM) ) then - if ( J1 .ne. 1 .and. J1 .ne. JMN ) then - hj0 = float(zavg(i1,j1-1)) - hjp1 = float(zavg(i1,j1+1)) - if(hj0 .lt. -990.) hj0 = 0.0 - if(hjp1 .lt. -990.) hjp1 = 0.0 -C....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY - yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 -C -C..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then -C === the NH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JST(1) ) then - elseif ( J1 .eq. 1 ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn -C..... at N pole we stay at the same latitude j1 but cross to opp side - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 -C....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY - yfp = 0.5 * ( ( 0.5 * ( hijax - hi1j1 ) ) )/DELTAY - yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) - 1 / DELTAY )**2 -C -C === the SH pole: NB J1 goes from High at NP to Low toward SP -C -!RAB elseif ( J1 .eq. JEN(JM) ) then - elseif ( J1 .eq. JMN ) then - ijax = i1 + imn/2 - if (ijax .le. 0 ) ijax = ijax + imn - if (ijax .gt. imn) ijax = ijax - imn - hijax = float(zavg(ijax,j1)) - hi1j1 = float(zavg(i1,j1)) - if(hijax .lt. -990.) hijax = 0.0 - if(hi1j1 .lt. -990.) hi1j1 = 0.0 - if ( i1 .lt. 5 )print *,' S.Pole i1,j1 :',i1,j1, - & hijax,hi1j1 -C..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY - yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) - 1 / DELTAY )**2 - endif -C -C === The above does an average across the pole for the bndry in j. -C23456789012345678901234567890123456789012345678901234567890123456789012...... -C - xfpyfp = xfpyfp + xfp * yfp - ENDIF INSIDE -C -C === average the HX2, HY2 and HXY -C === This will be done over all land -C - ENDDO - ENDDO -C -C === HTENSR -C - XNSUM_GT_1 : IF(XNSUM.GT.1.) THEN - IF(SLM(I,J).NE.0.) THEN - IF (XLAND > 0) THEN - HX2(I,J) = xfp2 / XLAND - HY2(I,J) = yfp2 / XLAND - HXY(I,J) = xfpyfp / XLAND - ELSE - HX2(I,J) = xfp2 / XNSUM - HY2(I,J) = yfp2 / XNSUM - HXY(I,J) = xfpyfp / XNSUM - ENDIF - ENDIF -C=== degub testing - if (debug) then - print *," I,J,i1,j1:", I,J,i1,j1, - 1 XLAND,SLM(i,j) - print *," xfpyfp,xfp2,yfp2:",xfpyfp,xfp2,yfp2 - print *," HX2,HY2,HXY:",HX2(I,J),HY2(I,J),HXY(I,J) - ENDIF -C -C === make the principal axes, theta, and the degree of anisotropy, -C === and sigma2, the slope parameter -C - HK(I,J) = 0.5 * ( HX2(I,J) + HY2(I,J) ) - HL(I,J) = 0.5 * ( HX2(I,J) - HY2(I,J) ) - HLPRIM(I,J) = SQRT(HL(I,J)*HL(I,J) + HXY(I,J)*HXY(I,J)) - IF( HL(I,J).NE. 0. .AND. SLM(I,J) .NE. 0. ) THEN -C - THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) / D2R -C === for testing print out in degrees -C THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) - ENDIF - SIGMA2(I,J) = ( HK(I,J) + HLPRIM(I,J) ) - if ( SIGMA2(I,J) .GE. 0. ) then - SIGMA(I,J) = SQRT(SIGMA2(I,J) ) - if (sigma2(i,j) .ne. 0. .and. - & HK(I,J) .GE. HLPRIM(I,J) ) - 1 GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) - else - SIGMA(I,J)=0. - endif - ENDIF XNSUM_GT_1 - if (debug) then - print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J), - 1 SIGMA(I,J),GAMMA(I,J) - print *," HK,HL,HLPRIM:",HK(I,J),HL(I,J),HLPRIM(I,J) - endif - ENDDO ILOOP - ENDDO JLOOP -!$omp end parallel do - WRITE(6,*) "! MAKE Principal Coord DONE" -C - RETURN - END SUBROUTINE MAKEPC2 - -!> Create orographic asymmetry and orographic length scale on -!! the model grid. This routine is used for the spectral -!! GFS gaussian grid. -!! -!! @param[in] zavg The high-resolution input orography dataset. -!! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. -!! @param[out] oa4 Orographic asymmetry on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ol Orographic length scale on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. -!! @param[out] elvmax Maximum elevation on the model grid. -!! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[out] xnsum Number of high-resolution orography points -!! higher than the model grid box average. -!! @param[out] xnsum1 Number of high-resolution orography points -!! higher than the critical height. -!! @param[out] xnsum2 Total number of high-resolution orography points -!! within a model grid box. -!! @param[out] xnsum3 Same as xnsum1, except shifted by half a -!! model grid box. -!! @param[out] xnsum4 Same as xnsum2, except shifted by half a -!! model grid box. -!! @param[out] ist This is the 'i' index of high-resolution data set -!! at the east edge of the model grid cell. -!! @param[out] ien This is the 'i' index of high-resolution data set -!! at the west edge of the model grid cell. -!! @param[out] jst This is the 'j' index of high-resolution data set -!! at the south edge of the model grid cell. -!! @param[out] jen This is the 'j' index of high-resolution data set -!! at the north edge of the model grid cell. -!! @param[in] im "i" dimension of the model grid. -!! @param[in] jm "j" dimension of the model grid. -!! @param[in] imn "i" dimension of the input terrain dataset. -!! @param[in] jmn "j" dimension of the input terrain dataset. -!! @param[in] xlat The latitude of each row of the model grid. -!! @param[in] numi For reduced gaussian grids, the number of 'i' points -!! for each 'j' row. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEOA(ZAVG,VAR,GLAT,OA4,OL,IOA4,ELVMAX, - 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IST,IEN,JST,JEN,IM,JM,IMN,JMN,XLAT,numi) - DIMENSION GLAT(JMN),XLAT(JM) - INTEGER ZAVG(IMN,JMN) - DIMENSION ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - DIMENSION OA4(IM,JM,4),IOA4(IM,JM,4) - DIMENSION IST(IM,jm),IEN(IM,jm),JST(JM),JEN(JM) - DIMENSION XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - DIMENSION XNSUM3(IM,JM),XNSUM4(IM,JM) - DIMENSION VAR(IM,JM),OL(IM,JM,4),numi(jm) - LOGICAL FLAG -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C -! --- IM1 = IM - 1 removed (not used in this sub) - JM1 = JM - 1 - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C - DO j=1,jm - DO I=1,numi(j) - DELX = 360./numi(j) ! GAUSSIAN GRID RESOLUTION - FACLON = DELX / DELXN -C --- minus sign here in IST and IEN as in MAKEMT! - IST(I,j) = FACLON * FLOAT(I-1) - FACLON * 0.5 - IST(I,j) = IST(I,j) + 1 - IEN(I,j) = FACLON * FLOAT(I) - FACLON * 0.5 -! IST(I,j) = FACLON * FLOAT(I-1) + 1.0001 -! IEN(I,j) = FACLON * FLOAT(I) + 0.0001 - IF (IST(I,j) .LE. 0) IST(I,j) = IST(I,j) + IMN - IF (IEN(I,j) .LT. IST(I,j)) IEN(I,j) = IEN(I,j) + IMN -cx PRINT*, ' I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .lt. 3 ) - 1PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - if ( I .lt. 3 .and. J .ge. JM-1 ) - 1PRINT*,' MAKEOA: I j IST IEN ',I,j,IST(I,j),IEN(I,j) - ENDDO - ENDDO - print *,'MAKEOA: DELXN,DELX,FACLON',DELXN,DELX,FACLON - print *, ' ***** ready to start JST JEN section ' - DO J=1,JM-1 - FLAG=.TRUE. - DO J1=1,JMN -! --- XXLAT added as in MAKEMT and in next line as well - XXLAT = (XLAT(J)+XLAT(J+1))/2. - IF(FLAG.AND.GLAT(J1).GT.XXLAT) THEN - JST(J) = J1 -! --- JEN(J+1) = J1 - 1 - FLAG = .FALSE. - if ( J .eq. 1 ) - 1PRINT*,' MAKEOA: XX j JST JEN ',j,JST(j),JEN(j) - ENDIF - ENDDO - if ( J .lt. 3 ) - 1PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) - if ( J .ge. JM-2 ) - 1PRINT*,' MAKEOA: j JST JEN ',j,JST(j),JEN(j) -C FLAG=.TRUE. -C DO J1=JST(J),JMN -C IF(FLAG.AND.GLAT(J1).GT.XLAT(J)) THEN -C JEN(J) = J1 - 1 -C FLAG = .FALSE. -C ENDIF -C ENDDO - ENDDO - JST(JM) = MAX(JST(JM-1) - (JEN(JM-1)-JST(JM-1)),1) - JEN(1) = MIN(JEN(2) + (JEN(2)-JST(2)),JMN) - print *,' ***** JST(1) JEN(1) ',JST(1),JEN(1) - print *,' ***** JST(JM) JEN(JM) ',JST(JM),JEN(JM) -C - DO J=1,JM - DO I=1,numi(j) - XNSUM(I,J) = 0.0 - ELVMAX(I,J) = ORO(I,J) - ZMAX(I,J) = 0.0 - ENDDO - ENDDO -! -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -! --- to JM or to JM1 - DO J=1,JM - DO I=1,numi(j) - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 -! --- next line as in makemt (I1 not II1) (*j*) 20070701 - IF(I1.LE.0.) I1 = I1 + IMN - IF (I1 .GT. IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO(I,J) ) then - if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT - XNSUM(I,J) = XNSUM(I,J) + 1 - ENDIF - ENDDO - ENDDO - if ( I .lt. 5 .and. J .ge. JM-5 ) then - print *,' I,J,ORO(I,J),XNSUM(I,J),ZMAX(I,J):', - 1 I,J,ORO(I,J),XNSUM(I,J),ZMAX(I,J) - endif - ENDDO - ENDDO -! -C.... make ELVMAX ORO from MAKEMT sub -C -! --- this will make work1 array take on oro's values on return - DO J=1,JM - DO I=1,numi(j) - - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO -C........ -C The MAX elev peak (no averaging) -C........ -! DO J=1,JM -! DO I=1,numi(j) -! DO II1 = 1, IEN(I,J) - IST(I,J) + 1 -! I1 = IST(I,J) + II1 - 1 -! IF(I1.LE.0.) I1 = I1 + IMN -! IF(I1.GT.IMN) I1 = I1 - IMN -! DO J1=JST(J),JEN(J) -! if ( ELVMAX(I,J) .lt. ZMAX(I1,J1)) -! 1 ELVMAX(I,J) = ZMAX(I1,J1) -! ENDDO -! ENDDO -! ENDDO -! ENDDO -C -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX - DO J=1,JM - DO I=1,numi(j) - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ENDDO - ENDDO -! --- loop - DO J=1,JM1 - DO I=1,numi(j) - HC = 1116.2 - 0.878 * VAR(I,J) -! print *,' I,J,HC,VAR:',I,J,HC,VAR(I,J) - DO II1 = 1, IEN(I,J) - IST(I,J) + 1 - I1 = IST(I,J) + II1 - 1 -! IF (I1.LE.0.) print *,' I1 less than 0',I1,II1,IST(I,J),IEN(I,J) -! if ( J .lt. 3 .or. J .gt. JM-2 ) then -! IF(I1 .GT. IMN)print *,' I1 > IMN',J,I1,II1,IMN,IST(I,J),IEN(I,J) -! endif - IF(I1.GT.IMN) I1 = I1 - IMN - DO J1=JST(J),JEN(J) - IF(FLOAT(ZAVG(I1,J1)) .GT. HC) - 1 XNSUM1(I,J) = XNSUM1(I,J) + 1 - XNSUM2(I,J) = XNSUM2(I,J) + 1 - ENDDO - ENDDO -C - INCI = NINT((IEN(I,j)-IST(I,j)) * 0.5) - ISTTT = MIN(MAX(IST(I,j)-INCI,1),IMN) - IEDDD = MIN(MAX(IEN(I,j)-INCI,1),IMN) -C - INCJ = NINT((JEN(J)-JST(J)) * 0.5) - JSTTT = MIN(MAX(JST(J)-INCJ,1),JMN) - JEDDD = MIN(MAX(JEN(J)-INCJ,1),JMN) -! if ( J .lt. 3 .or. J .gt. JM-3 ) then -! if(I .lt. 3 .or. I .gt. IM-3) then -! print *,' INCI,ISTTT,IEDDD,INCJ,JSTTT,JEDDD:', -! 1 I,J,INCI,ISTTT,IEDDD,INCJ,JSTTT,JEDDD -! endif -! endif -C - DO I1=ISTTT,IEDDD - DO J1=JSTTT,JEDDD - IF(FLOAT(ZAVG(I1,J1)) .GT. HC) - 1 XNSUM3(I,J) = XNSUM3(I,J) + 1 - XNSUM4(I,J) = XNSUM4(I,J) + 1 - ENDDO - ENDDO -cx print*,' i j hc var ',i,j,hc,var(i,j) -cx print*,'xnsum12 ',xnsum1(i,j),xnsum2(i,j) -cx print*,'xnsum34 ',xnsum3(i,j),xnsum4(i,j) - ENDDO - ENDDO -C -C---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS -C---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION -C (KWD = 1 2 3 4) -C ( WD = W S SW NW) -C -C - DO KWD = 1, 4 - DO J=1,JM - DO I=1,numi(j) - OA4(I,J,KWD) = 0.0 - ENDDO - ENDDO - ENDDO -C - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J) + XNSUM(I,J+1) - XNPD = XNSUM(II,J) + XNSUM(II,J+1) - IF (XNPD .NE. XNPU) OA4(II,J+1,1) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,1) = (XNSUM3(I,J+1)+XNSUM3(II,J+1))/ - 1 (XNSUM4(I,J+1)+XNSUM4(II,J+1)) -! if ( I .lt. 20 .and. J .ge. JM-19 ) then -! PRINT*,' MAKEOA: I J IST IEN ',I,j,IST(I,J),IEN(I,J) -! PRINT*,' HC VAR ',HC,VAR(i,j) -! PRINT*,' MAKEOA: XNSUM(I,J)=',XNSUM(I,J),XNPU, XNPD -! PRINT*,' MAKEOA: XNSUM3(I,J+1),XNSUM3(II,J+1)', -! 1 XNSUM3(I,J+1),XNSUM3(II,J+1) -! PRINT*,' MAKEOA: II, OA4(II,J+1,1), OL(II,J+1,1):', -! 1 II, OA4(II,J+1,1), OL(II,J+1,1) -! endif - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J+1) + XNSUM(II,J+1) - XNPD = XNSUM(I,J) + XNSUM(II,J) - IF (XNPD .NE. XNPU) OA4(II,J+1,2) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,2) = (XNSUM3(II,J)+XNSUM3(II,J+1))/ - 1 (XNSUM4(II,J)+XNSUM4(II,J+1)) - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J+1) + ( XNSUM(I,J) + XNSUM(II,J+1) )*0.5 - XNPD = XNSUM(II,J) + ( XNSUM(I,J) + XNSUM(II,J+1) )*0.5 - IF (XNPD .NE. XNPU) OA4(II,J+1,3) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,3) = (XNSUM1(II,J)+XNSUM1(I,J+1))/ - 1 (XNSUM2(II,J)+XNSUM2(I,J+1)) - ENDDO - ENDDO - DO J=1,JM-2 - DO I=1,numi(j) - II = I + 1 - IF (II .GT. numi(j)) II = II - numi(j) - XNPU = XNSUM(I,J) + ( XNSUM(II,J) + XNSUM(I,J+1) )*0.5 - XNPD = XNSUM(II,J+1) + ( XNSUM(II,J) + XNSUM(I,J+1) )*0.5 - IF (XNPD .NE. XNPU) OA4(II,J+1,4) = 1. - XNPD / MAX(XNPU , 1.) - OL(II,J+1,4) = (XNSUM1(I,J)+XNSUM1(II,J+1))/ - 1 (XNSUM2(I,J)+XNSUM2(II,J+1)) - ENDDO - ENDDO -C - DO KWD = 1, 4 - DO I=1,numi(j) - OL(I,1,KWD) = OL(I,2,KWD) - OL(I,JM,KWD) = OL(I,JM-1,KWD) - ENDDO - ENDDO -C - DO KWD=1,4 - DO J=1,JM - DO I=1,numi(j) - T = OA4(I,J,KWD) - OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) - ENDDO - ENDDO - ENDDO -C - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,numi(j) - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO -C - WRITE(6,*) "! MAKEOA EXIT" -C - RETURN - END SUBROUTINE MAKEOA - -!> Convert the 'x' direction distance of a cubed-sphere grid -!! point to the corresponding distance in longitude. -!! -!! @param[in] dx Distance along the 'x' direction of a -!! cubed-sphere grid point. -!! @param[in] lat Latitude of the cubed-sphere point. -!! @param[in] degrad Conversion from radians to degrees. -!! @return get_lon_angle Corresponding distance in longitude. -!! @author GFDL programmer - function get_lon_angle(dx,lat, DEGRAD) - implicit none - real dx, lat, DEGRAD - - real get_lon_angle - real, parameter :: RADIUS = 6371200 - - get_lon_angle = 2*asin( sin(dx/RADIUS*0.5)/cos(lat) )*DEGRAD - - end function get_lon_angle - -!> Convert the 'y' direction distance of a cubed-sphere grid -!! point to the corresponding distance in latitude. -!! -!! @param[in] dy Distance along the 'y' direction of a cubed-sphere -!! point. -!! @param[in] degrad Conversion from radians to degrees. -!! @return get_lat_angle Corresponding distance in latitude. -!! @author GFDL programmer - function get_lat_angle(dy, DEGRAD) - implicit none - real dy, DEGRAD - - real get_lat_angle - real, parameter :: RADIUS = 6371200 - - get_lat_angle = dy/RADIUS*DEGRAD - - end function get_lat_angle - -!> Create orographic asymmetry and orographic length scale on -!! the model grid. This routine is used for the cubed-sphere -!! grid. -!! -!! @param[in] zavg High-resolution orography data. -!! @param[in] zslm High-resolution land-mask data. -!! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. -!! @param[out] oa4 Orographic asymmetry on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ol Orographic length scale on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. -!! @param[out] elvmax Maximum elevation within a model grid box. -!! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[out] xnsum Not used. -!! @param[out] xnsum1 Not used. -!! @param[out] xnsum2 Not used. -!! @param[out] xnsum3 Not used. -!! @param[out] xnsum4 Not used. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the high-resolution orography and -!! mask data. -!! @param[in] jmn "j" dimension of the high-resolution orography and -!! mask data. -!! @param[in] lon_c Corner point longitudes of the model grid points. -!! @param[in] lat_c Corner point latitudes of the model grid points. -!! @param[in] lon_t Center point longitudes of the model grid points. -!! @param[in] lat_t Center point latitudes of the model grid points. -!! @param[in] dx Length of model grid points in the 'x' direction. -!! @param[in] dy Length of model grid points in the 'y' direction. -!! @param[in] is_south_pole Is the model point at the south pole? -!! @param[in] is_north_pole is the model point at the north pole? -!! @author GFDL Programmer - SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,GLAT,OA4,OL,IOA4,ELVMAX, - 1 ORO,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, - 3 is_south_pole,is_north_pole ) - implicit none - real, parameter :: MISSING_VALUE = -9999. - real, parameter :: D2R = 3.14159265358979/180. - real, PARAMETER :: R2D=180./3.14159265358979 - integer IM,JM,IMN,JMN - real GLAT(JMN) - INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) - real ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - real OA4(IM,JM,4) - integer IOA4(IM,JM,4) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real lon_t(IM,JM), lat_t(IM,JM) - real dx(IM,JM), dy(IM,JM) - logical is_south_pole(IM,JM), is_north_pole(IM,JM) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - real XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) - integer i,j,ilist(IMN),numx,i1,j1,ii1 - integer KWD - real LONO(4),LATO(4),LONI,LATI - real DELXN,HC,HEIGHT,XNPU,XNPD,T - integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 - logical inside_a_polygon - real lon,lat,dlon,dlat,dlat_old - real lon1,lat1,lon2,lat2 - real xnsum11,xnsum12,xnsum21,xnsum22 - real HC_11, HC_12, HC_21, HC_22 - real xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 - real xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 - real get_lon_angle, get_lat_angle, get_xnsum - integer jst, jen -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C - DO J=1,JM - DO I=1,IM - XNSUM(I,J) = 0.0 - ELVMAX(I,J) = ORO(I,J) - ZMAX(I,J) = 0.0 -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -! --- to JM or to JM1 -!$omp parallel do -!$omp* private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, -!$omp* lati,height) - DO J=1,JM -! print*, "J=", J - DO I=1,IM - HC = 1116.2 - 0.878 * VAR(I,J) - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - do j1 = jst, jen; do ii1 = 1, numx - i1 = ilist(ii1) - LONI = i1*DELXN - LATI = -90 + j1*DELXN - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO(I,J) ) then - if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT - ENDIF - endif - ENDDO ; ENDDO - ENDDO - ENDDO -!$omp end parallel do -C -! --- this will make work1 array take on oro's values on return -! --- this will make work1 array take on oro's values on return - DO J=1,JM - DO I=1,IM - - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - - DO KWD = 1, 4 - DO J=1,JM - DO I=1,IM - OA4(I,J,KWD) = 0.0 - OL(I,J,KWD) = 0.0 - ENDDO - ENDDO - ENDDO - ! -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -C -C---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS -C---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION -C (KWD = 1 2 3 4) -C ( WD = W S SW NW) -C -C -!$omp parallel do -!$omp* private (j,i,lon,lat,kwd,dlon,dlat,lon1,lon2,lat1,lat2, -!$omp* xnsum11,xnsum12,xnsum21,xnsum22,xnpu,xnpd, -!$omp* xnsum1_11,xnsum2_11,hc_11, xnsum1_12,xnsum2_12, -!$omp* hc_12,xnsum1_21,xnsum2_21,hc_21, xnsum1_22, -!$omp* xnsum2_22,hc_22) - DO J=1,JM -! print*, "j = ", j - DO I=1,IM - lon = lon_t(i,j) - lat = lat_t(i,j) - !--- for around north pole, oa and ol are all 0 - - if(is_north_pole(i,j)) then - print*, "set oa1 = 0 and ol=0 at i,j=", i,j - do kwd = 1, 4 - oa4(i,j,kwd) = 0. - ol(i,j,kwd) = 0. - enddo - else if(is_south_pole(i,j)) then - print*, "set oa1 = 0 and ol=1 at i,j=", i,j - do kwd = 1, 4 - oa4(i,j,kwd) = 0. - ol(i,j,kwd) = 1. - enddo - else - - !--- for each point, find a lat-lon grid box with same dx and dy as the cubic grid box - dlon = get_lon_angle(dx(i,j), lat*D2R, R2D ) - dlat = get_lat_angle(dy(i,j), R2D) - !--- adjust dlat if the points are close to pole. - if( lat-dlat*0.5<-90.) then - print*, "at i,j =", i,j, lat, dlat, lat-dlat*0.5 - print*, "FATAL ERROR: lat-dlat*0.5<-90." - call ERREXIT(4) - endif - if( lat+dlat*2 > 90.) then - dlat_old = dlat - dlat = (90-lat)*0.5 - print*, "at i,j=",i,j," adjust dlat from ", - & dlat_old, " to ", dlat - endif - !--- lower left - lon1 = lon-dlon*1.5 - lon2 = lon-dlon*0.5 - lat1 = lat-dlat*0.5 - lat2 = lat+dlat*0.5 - - if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - xnsum11 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) - - !--- upper left - lon1 = lon-dlon*1.5 - lon2 = lon-dlon*0.5 - lat1 = lat+dlat*0.5 - lat2 = lat+dlat*1.5 - if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - xnsum12 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) - - !--- lower right - lon1 = lon-dlon*0.5 - lon2 = lon+dlon*0.5 - lat1 = lat-dlat*0.5 - lat2 = lat+dlat*0.5 - if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - xnsum21 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) - - !--- upper right - lon1 = lon-dlon*0.5 - lon2 = lon+dlon*0.5 - lat1 = lat+dlat*0.5 - lat2 = lat+dlat*1.5 - if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - - xnsum22 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,zslm,delxn) - - XNPU = xnsum11 + xnsum12 - XNPD = xnsum21 + xnsum22 - IF (XNPD .NE. XNPU) OA4(I,J,1) = 1. - XNPD / MAX(XNPU , 1.) - - XNPU = xnsum11 + xnsum21 - XNPD = xnsum12 + xnsum22 - IF (XNPD .NE. XNPU) OA4(I,J,2) = 1. - XNPD / MAX(XNPU , 1.) - - XNPU = xnsum11 + (xnsum12+xnsum21)*0.5 - XNPD = xnsum22 + (xnsum12+xnsum21)*0.5 - IF (XNPD .NE. XNPU) OA4(I,J,3) = 1. - XNPD / MAX(XNPU , 1.) - - XNPU = xnsum12 + (xnsum11+xnsum22)*0.5 - XNPD = xnsum21 + (xnsum11+xnsum22)*0.5 - IF (XNPD .NE. XNPU) OA4(I,J,4) = 1. - XNPD / MAX(XNPU , 1.) - - - !--- calculate OL3 and OL4 - !--- lower left - lon1 = lon-dlon*1.5 - lon2 = lon-dlon*0.5 - lat1 = lat-dlat*0.5 - lat2 = lat+dlat*0.5 - if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) - - !--- upper left - lon1 = lon-dlon*1.5 - lon2 = lon-dlon*0.5 - lat1 = lat+dlat*0.5 - lat2 = lat+dlat*1.5 - if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_12, xnsum2_12, HC_12) - - !--- lower right - lon1 = lon-dlon*0.5 - lon2 = lon+dlon*0.5 - lat1 = lat-dlat*0.5 - lat2 = lat+dlat*0.5 - if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) - - !--- upper right - lon1 = lon-dlon*0.5 - lon2 = lon+dlon*0.5 - lat1 = lat+dlat*0.5 - lat2 = lat+dlat*1.5 - if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_22, xnsum2_22, HC_22) - - OL(i,j,3) = (XNSUM1_22+XNSUM1_11)/(XNSUM2_22+XNSUM2_11) - OL(i,j,4) = (XNSUM1_12+XNSUM1_21)/(XNSUM2_12+XNSUM2_21) - - !--- calculate OL1 and OL2 - !--- lower left - lon1 = lon-dlon*2.0 - lon2 = lon-dlon - lat1 = lat - lat2 = lat+dlat - if(lat1<-90 .or. lat2>90) then - print*, "at upper left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_11, xnsum2_11, HC_11) - - !--- upper left - lon1 = lon-dlon*2.0 - lon2 = lon-dlon - lat1 = lat+dlat - lat2 = lat+dlat*2.0 - if(lat1<-90 .or. lat2>90) then - print*, "at lower left i=,j=", i, j, lat, dlat,lat1,lat2 - endif - - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_12, xnsum2_12, HC_12) - - !--- lower right - lon1 = lon-dlon - lon2 = lon - lat1 = lat - lat2 = lat+dlat - if(lat1<-90 .or. lat2>90) then - print*, "at upper right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_21, xnsum2_21, HC_21) - - !--- upper right - lon1 = lon-dlon - lon2 = lon - lat1 = lat+dlat - lat2 = lat+dlat*2.0 - if(lat1<-90 .or. lat2>90) then - print*, "at lower right i=,j=", i, j, lat, dlat,lat1,lat2 - endif - - call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, - & zavg,delxn, xnsum1_22, xnsum2_22, HC_22) - - OL(i,j,1) = (XNSUM1_11+XNSUM1_21)/(XNSUM2_11+XNSUM2_21) - OL(i,j,2) = (XNSUM1_21+XNSUM1_22)/(XNSUM2_21+XNSUM2_22) - ENDIF - ENDDO - ENDDO -!$omp end parallel do - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = OA4(I,J,KWD) - OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) - ENDDO - ENDDO - ENDDO -C - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO -C - WRITE(6,*) "! MAKEOA2 EXIT" -C - RETURN - - END SUBROUTINE MAKEOA2 - -!> Compute a great circle distance between two points. -!! -!! @param[in] theta1 Longitude of point 1. -!! @param[in] phi1 Latitude of point 1. -!! @param[in] theta2 Longitude of point 2. -!! @param[in] phi2 Latitude of point2. -!! @return spherical_distance Great circle distance. -!! @author GFDL programmer - function spherical_distance(theta1,phi1,theta2,phi2) - - real, intent(in) :: theta1, phi1, theta2, phi2 - real :: spherical_distance, dot - - if(theta1 == theta2 .and. phi1 == phi2) then - spherical_distance = 0.0 - return - endif - - dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) - if(dot > 1. ) dot = 1. - if(dot < -1.) dot = -1. - spherical_distance = acos(dot) - - return - - end function spherical_distance - -!> For unmapped land points, find the nearest land point -!! on the input data and pass back its i/j index. -!! -!! @param[in] im_in 'i' dimension of input data. -!! @param[in] jm_in 'j' dimension of input data. -!! @param[in] geolon_in Longitude of input data. -!! @param[in] geolat_in Latitude of input data. -!! @param[in] bitmap_in Bitmap (mask) of input data. -!! @param[in] num_out Number of unmapped points. -!! @param[in] lon_out Longitude of unmapped points. -!! @param[in] lat_out Latitude of unmapped points. -!! @param[out] iindx 'i' indices of nearest land points -!! on the input data. -!! @param[out] jindx 'j' indices of nearest land points -!! on the input data. -!! @author GFDL progammer - subroutine get_mismatch_index(im_in, jm_in, geolon_in,geolat_in, - & bitmap_in,num_out, lon_out,lat_out, iindx, jindx ) - integer, intent(in) :: im_in, jm_in, num_out - real, intent(in) :: geolon_in(im_in,jm_in) - real, intent(in) :: geolat_in(im_in,jm_in) - logical*1, intent(in) :: bitmap_in(im_in,jm_in) - real, intent(in) :: lon_out(num_out), lat_out(num_out) - integer, intent(out):: iindx(num_out), jindx(num_out) - real, parameter :: MAX_DIST = 1.e+20 - integer, parameter :: NUMNBR = 20 - integer :: i_c,j_c,jstart,jend - real :: lon,lat - - print*, "im_in,jm_in = ", im_in, jm_in - print*, "num_out = ", num_out - print*, "max and min of lon_in is", minval(geolon_in), - & maxval(geolon_in) - print*, "max and min of lat_in is", minval(geolat_in), - & maxval(geolat_in) - print*, "max and min of lon_out is", minval(lon_out), - & maxval(lon_out) - print*, "max and min of lat_out is", minval(lat_out), - & maxval(lat_out) - print*, "count(bitmap_in)= ", count(bitmap_in), MAX_DIST - - do n = 1, num_out - ! print*, "n = ", n - lon = lon_out(n) - lat = lat_out(n) - !--- find the j-index for the nearest point - i_c = 0; j_c = 0 - do j = 1, jm_in-1 - if(lat .LE. geolat_in(1,j) .and. - & lat .GE. geolat_in(1,j+1)) then - j_c = j - endif - enddo - if(lat > geolat_in(1,1)) j_c = 1 - if(lat < geolat_in(1,jm_in)) j_c = jm_in - ! print*, "lat =", lat, geolat_in(1,jm_in), geolat_in(1,jm_in-1) - ! The input is Gaussian grid. - jstart = max(j_c-NUMNBR,1) - jend = min(j_c+NUMNBR,jm_in) - dist = MAX_DIST - iindx(n) = 0 - jindx(n) = 0 - ! print*, "jstart, jend =", jstart, jend - do j = jstart, jend; do i = 1,im_in - if(bitmap_in(i,j) ) then - ! print*, "bitmap_in is true" - d = spherical_distance(lon_out(n),lat_out(n), - & geolon_in(i,j), geolat_in(i,j)) - if( dist > d ) then - iindx(n) = i; jindx(n) = j - dist = d - endif - endif - enddo; enddo - if(iindx(n) ==0) then - print*, "lon,lat=", lon,lat - print*, "jstart, jend=", jstart, jend, dist - print*, "FATAL ERROR in get mismatch_index: " - print*, "did not find nearest points." - call ERREXIT(4) - endif - enddo - - end subroutine get_mismatch_index - -!> Replace unmapped model land points with the nearest land point on the -!! input grid. -!! -!! @param[in] im_in 'i' dimension of input grid. -!! @param[in] jm_in 'j' dimension of input grid. -!! @param[in] data_in Input grid data. -!! @param[in] num_out Number of unmapped model points. -!! @param[out] data_out Data on the model tile. -!! @param[in] iindx 'i' indices of the nearest land points on -!! the input grid. -!! @param[in] jindx 'j' indices of the nearest land points on -!! the input grid. -!! @author GFDL programmer - subroutine interpolate_mismatch(im_in, jm_in, data_in, - & num_out, data_out, iindx, jindx) - integer, intent(in) :: im_in, jm_in, num_out - real, intent(in) :: data_in(im_in,jm_in) - real, intent(out):: data_out(num_out) - integer, intent(in) :: iindx(num_out), jindx(num_out) - - do n = 1, num_out - data_out(n) = data_in(iindx(n),jindx(n)) - enddo - - end subroutine interpolate_mismatch - -!> Create orographic asymmetry and orographic length scale on -!! the model grid. This routine is used for the cubed-sphere -!! grid. The asymmetry and length scales are interpolated -!! from an existing gfs orography file. The maximum elevation -!! is computed from the high-resolution orography data. -!! -!! @param[in] zavg High-resolution orography data. -!! @param[in] var Standard deviation of orography on the model grid. -!! @param[out] glat Latitude of each row of input terrain dataset. -!! @param[out] oa4 Orographic asymmetry on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ol Orographic length scale on the model grid. Four -!! directional components - W/S/SW/NW -!! @param[out] ioa4 Count of oa4 values between certain thresholds. -!! @param[out] elvmax Maximum elevation within a model grid box. -!! @param[in] slm Land-mask on model grid. -!! @param[in] oro Orography on the model grid. -!! @param[out] oro1 Save array for model grid orography. -!! @param[in] xnsum Not used. -!! @param[in] xnsum1 Not used. -!! @param[in] xnsum2 Not used. -!! @param[in] xnsum3 Not used. -!! @param[in] xnsum4 Not used. -!! @param[in] im "i" dimension of the model grid tile. -!! @param[in] jm "j" dimension of the model grid tile. -!! @param[in] imn "i" dimension of the high-resolution orography and -!! mask data. -!! @param[in] jmn "j" dimension of the high-resolution orography and -!! mask data. -!! @param[in] lon_c Corner point longitudes of the model grid points. -!! @param[in] lat_c Corner point latitudes of the model grid points. -!! @param[in] lon_t Center point longitudes of the model grid points. -!! @param[in] lat_t Center point latitudes of the model grid points. -!! @param[in] imi 'i' dimension of input gfs orography data. -!! @param[in] jmi 'j' dimension of input gfs orography data. -!! @param[in] oa_in Asymmetry on the input gfs orography data. -!! @param[in] ol_in Length scales on the input gfs orography data. -!! @param[in] slm_in Land-sea mask on the input gfs orography data. -!! @param[in] lon_in Longitude on the input gfs orography data. -!! @param[in] lat_in Latitude on the input gfs orography data. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE MAKEOA3(ZAVG,VAR,GLAT,OA4,OL,IOA4,ELVMAX, - 1 ORO,SLM,oro1,XNSUM,XNSUM1,XNSUM2,XNSUM3,XNSUM4, - 2 IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t, - 3 IMI,JMI,OA_IN,OL_IN, - 4 slm_in,lon_in,lat_in) - -! Required when using iplib v4.0 or higher. -#ifdef IP_V4 - use ipolates_mod -#endif - - implicit none - real, parameter :: MISSING_VALUE = -9999. - real, parameter :: D2R = 3.14159265358979/180. - real, PARAMETER :: R2D=180./3.14159265358979 - integer IM,JM,IMN,JMN,IMI,JMI - real GLAT(JMN) - INTEGER ZAVG(IMN,JMN) - real SLM(IM,JM) - real ORO(IM,JM),ORO1(IM,JM),ELVMAX(IM,JM),ZMAX(IM,JM) - real OA4(IM,JM,4) - integer IOA4(IM,JM,4) - real OA_IN(IMI,JMI,4), OL_IN(IMI,JMI,4) - real slm_in(IMI,JMI) - real lon_in(IMI,JMI), lat_in(IMI,JMI) - real lon_c(IM+1,JM+1), lat_c(IM+1,JM+1) - real lon_t(IM,JM), lat_t(IM,JM) - real XNSUM(IM,JM),XNSUM1(IM,JM),XNSUM2(IM,JM) - real XNSUM3(IM,JM),XNSUM4(IM,JM) - real VAR(IM,JM),OL(IM,JM,4) - integer i,j,ilist(IMN),numx,i1,j1,ii1 - integer KWD - real LONO(4),LATO(4),LONI,LATI - real DELXN,HC,HEIGHT,T - integer NS0,NS1,NS2,NS3,NS4,NS5,NS6 - logical inside_a_polygon - integer jst, jen - integer int_opt, ipopt(20), kgds_input(200), kgds_output(200) - integer count_land_output - integer ij, ijmdl_output, iret, num_mismatch_land, num - integer ibo(1), ibi(1) - logical*1, allocatable :: bitmap_input(:,:) - logical*1, allocatable :: bitmap_output(:,:) - integer, allocatable :: ijsav_land_output(:) - real, allocatable :: lats_land_output(:) - real, allocatable :: lons_land_output(:) - real, allocatable :: output_data_land(:,:) - real, allocatable :: lons_mismatch_output(:) - real, allocatable :: lats_mismatch_output(:) - real, allocatable :: data_mismatch_output(:) - integer, allocatable :: iindx(:), jindx(:) -C -C---- GLOBAL XLAT AND XLON ( DEGREE ) -C - DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION -C - ijmdl_output = IM*JM - - DO J=1,JMN - GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 - ENDDO - print *,' IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN -C -C---- FIND THE AVERAGE OF THE MODES IN A GRID BOX -C -C - DO J=1,JM - DO I=1,IM - XNSUM(I,J) = 0.0 - ELVMAX(I,J) = ORO(I,J) - ZMAX(I,J) = 0.0 -C---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT -C IN A GRID BOX - XNSUM1(I,J) = 0.0 - XNSUM2(I,J) = 0.0 - XNSUM3(I,J) = 0.0 - XNSUM4(I,J) = 0.0 - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - -! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. -! --- to JM or to JM1 - DO J=1,JM -! print*, "J=", J - DO I=1,IM - HC = 1116.2 - 0.878 * VAR(I,J) - LONO(1) = lon_c(i,j) - LONO(2) = lon_c(i+1,j) - LONO(3) = lon_c(i+1,j+1) - LONO(4) = lon_c(i,j+1) - LATO(1) = lat_c(i,j) - LATO(2) = lat_c(i+1,j) - LATO(3) = lat_c(i+1,j+1) - LATO(4) = lat_c(i,j+1) - call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) - do j1 = jst, jen; do ii1 = 1, numx - i1 = ilist(ii1) - LONI = i1*DELXN - LATI = -90 + j1*DELXN - if(inside_a_polygon(LONI*D2R,LATI*D2R,4, - & LONO*D2R,LATO*D2R))then - - HEIGHT = FLOAT(ZAVG(I1,J1)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO(I,J) ) then - if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT - ENDIF - endif - ENDDO ; ENDDO - ENDDO - ENDDO - -C -! --- this will make work1 array take on oro's values on return -! --- this will make work1 array take on oro's values on return - DO J=1,JM - DO I=1,IM - - ORO1(I,J) = ORO(I,J) - ELVMAX(I,J) = ZMAX(I,J) - ENDDO - ENDDO - - DO KWD = 1, 4 - DO J=1,JM - DO I=1,IM - OA4(I,J,KWD) = 0.0 - OL(I,J,KWD) = 0.0 - ENDDO - ENDDO - ENDDO - - !--- use the nearest point to do remapping. - int_opt = 2 - ipopt=0 - KGDS_INPUT = 0 - KGDS_INPUT(1) = 4 ! OCT 6 - TYPE OF GRID (GAUSSIAN) - KGDS_INPUT(2) = IMI ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - KGDS_INPUT(3) = JMI ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - KGDS_INPUT(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - KGDS_INPUT(5) = 0 ! OCT 14-16 - LON OF ORIGIN - KGDS_INPUT(6) = 128 ! OCT 17 - RESOLUTION FLAG - KGDS_INPUT(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - KGDS_INPUT(8) = NINT(-360000./IMI) ! OCT 21-23 - LON OF EXTREME POINT - KGDS_INPUT(9) = NINT((360.0 / FLOAT(IMI))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - KGDS_INPUT(10) = JMI /2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - KGDS_INPUT(12) = 255 ! OCT 29 - RESERVED - KGDS_INPUT(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - - KGDS_OUTPUT = -1 -! KGDS_OUTPUT(1) = IDRT ! OCT 6 - TYPE OF GRID (GAUSSIAN) - KGDS_OUTPUT(2) = IM ! OCT 7-8 - # PTS ON LATITUDE CIRCLE - KGDS_OUTPUT(3) = JM ! OCT 9-10 - # PTS ON LONGITUDE CIRCLE - KGDS_OUTPUT(4) = 90000 ! OCT 11-13 - LAT OF ORIGIN - KGDS_OUTPUT(5) = 0 ! OCT 14-16 - LON OF ORIGIN - KGDS_OUTPUT(6) = 128 ! OCT 17 - RESOLUTION FLAG - KGDS_OUTPUT(7) = -90000 ! OCT 18-20 - LAT OF EXTREME POINT - KGDS_OUTPUT(8) = NINT(-360000./IM) ! OCT 21-23 - LON OF EXTREME POINT - KGDS_OUTPUT(9) = NINT((360.0 / FLOAT(IM))*1000.0) - ! OCT 24-25 - LONGITUDE DIRECTION INCR. - KGDS_OUTPUT(10) = JM /2 ! OCT 26-27 - NUMBER OF CIRCLES POLE TO EQUATOR - KGDS_OUTPUT(12) = 255 ! OCT 29 - RESERVED - KGDS_OUTPUT(20) = 255 ! OCT 5 - NOT USED, SET TO 255 - - count_land_output=0 - print*, "sum(slm) = ", sum(slm) - do ij = 1, ijmdl_output - j = (ij-1)/IM + 1 - i = mod(ij-1,IM) + 1 - if (slm(i,j) > 0.0) then - count_land_output=count_land_output+1 - endif - enddo - allocate(bitmap_input(imi,jmi)) - bitmap_input=.false. - print*, "number of land input=", sum(slm_in) - where(slm_in > 0.0) bitmap_input=.true. - print*, "count(bitmap_input)", count(bitmap_input) - - allocate(bitmap_output(count_land_output,1)) - allocate(output_data_land(count_land_output,1)) - allocate(ijsav_land_output(count_land_output)) - allocate(lats_land_output(count_land_output)) - allocate(lons_land_output(count_land_output)) - - - - count_land_output=0 - do ij = 1, ijmdl_output - j = (ij-1)/IM + 1 - i = mod(ij-1,IM) + 1 - if (slm(i,j) > 0.0) then - count_land_output=count_land_output+1 - ijsav_land_output(count_land_output)=ij - lats_land_output(count_land_output)=lat_t(i,j) - lons_land_output(count_land_output)=lon_t(i,j) - endif - enddo - - oa4 = 0.0 - ol = 0.0 - ibi = 1 - - do KWD=1,4 - bitmap_output = .false. - output_data_land = 0.0 - call ipolates(int_opt, ipopt, kgds_input, kgds_output, - & (IMI*JMI), count_land_output, - & 1, ibi, bitmap_input, oa_in(:,:,KWD), - & count_land_output, lats_land_output, - & lons_land_output, ibo, - & bitmap_output, output_data_land, iret) - if (iret /= 0) then - print*,'- FATAL ERROR IN IPOLATES ',iret - call ERREXIT(4) - endif - - num_mismatch_land = 0 - do ij = 1, count_land_output - if (bitmap_output(ij,1)) then - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - oa4(i,j,KWD)=output_data_land(ij,1) - else ! default value - num_mismatch_land = num_mismatch_land + 1 - endif - enddo - print*, "num_mismatch_land = ", num_mismatch_land - - if(.not. allocated(data_mismatch_output)) then - allocate(lons_mismatch_output(num_mismatch_land)) - allocate(lats_mismatch_output(num_mismatch_land)) - allocate(data_mismatch_output(num_mismatch_land)) - allocate(iindx(num_mismatch_land)) - allocate(jindx(num_mismatch_land)) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - lons_mismatch_output(num) = lons_land_output(ij) - lats_mismatch_output(num) = lats_land_output(ij) - endif - enddo - - ! For those land points that with bitmap_output=.false. use - ! the nearest land points to interpolate. - print*,"before get_mismatch_index", count(bitmap_input) - call get_mismatch_index(imi,jmi,lon_in*D2R, - & lat_in*D2R,bitmap_input,num_mismatch_land, - & lons_mismatch_output*D2R,lats_mismatch_output*D2R, - & iindx, jindx ) - endif - - data_mismatch_output = 0 - call interpolate_mismatch(imi,jmi,oa_in(:,:,KWD), - & num_mismatch_land,data_mismatch_output,iindx,jindx) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - oa4(i,j,KWD) = data_mismatch_output(num) - if(i==372 .and. j== 611) then - print*, "ij=",ij, num, oa4(i,j,KWD),iindx(num),jindx(num) - endif - endif - enddo - - - enddo - - !OL - do KWD=1,4 - bitmap_output = .false. - output_data_land = 0.0 - call ipolates(int_opt, ipopt, kgds_input, kgds_output, - & (IMI*JMI), count_land_output, - & 1, ibi, bitmap_input, ol_in(:,:,KWD), - & count_land_output, lats_land_output, - & lons_land_output, ibo, - & bitmap_output, output_data_land, iret) - if (iret /= 0) then - print*,'- FATAL ERROR IN IPOLATES ',iret - call ERREXIT(4) - endif - - num_mismatch_land = 0 - do ij = 1, count_land_output - if (bitmap_output(ij,1)) then - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - ol(i,j,KWD)=output_data_land(ij,1) - else ! default value - num_mismatch_land = num_mismatch_land + 1 - endif - enddo - print*, "num_mismatch_land = ", num_mismatch_land - - data_mismatch_output = 0 - call interpolate_mismatch(imi,jmi,ol_in(:,:,KWD), - & num_mismatch_land,data_mismatch_output,iindx,jindx) - - num = 0 - do ij = 1, count_land_output - if (.not. bitmap_output(ij,1)) then - num = num+1 - j = (ijsav_land_output(ij)-1)/IM + 1 - i = mod(ijsav_land_output(ij)-1,IM) + 1 - ol(i,j,KWD) = data_mismatch_output(num) - if(i==372 .and. j== 611) then - print*, "ij=",ij, num, ol(i,j,KWD),iindx(num),jindx(num) - endif - endif - enddo - - - enddo - - deallocate(lons_mismatch_output,lats_mismatch_output) - deallocate(data_mismatch_output,iindx,jindx) - deallocate(bitmap_output,output_data_land) - deallocate(ijsav_land_output,lats_land_output) - deallocate(lons_land_output) - - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = OA4(I,J,KWD) - OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) - ENDDO - ENDDO - ENDDO -C - NS0 = 0 - NS1 = 0 - NS2 = 0 - NS3 = 0 - NS4 = 0 - NS5 = 0 - NS6 = 0 - DO KWD=1,4 - DO J=1,JM - DO I=1,IM - T = ABS( OA4(I,J,KWD) ) - IF(T .EQ. 0.) THEN - IOA4(I,J,KWD) = 0 - NS0 = NS0 + 1 - ELSE IF(T .GT. 0. .AND. T .LE. 1.) THEN - IOA4(I,J,KWD) = 1 - NS1 = NS1 + 1 - ELSE IF(T .GT. 1. .AND. T .LE. 10.) THEN - IOA4(I,J,KWD) = 2 - NS2 = NS2 + 1 - ELSE IF(T .GT. 10. .AND. T .LE. 100.) THEN - IOA4(I,J,KWD) = 3 - NS3 = NS3 + 1 - ELSE IF(T .GT. 100. .AND. T .LE. 1000.) THEN - IOA4(I,J,KWD) = 4 - NS4 = NS4 + 1 - ELSE IF(T .GT. 1000. .AND. T .LE. 10000.) THEN - IOA4(I,J,KWD) = 5 - NS5 = NS5 + 1 - ELSE IF(T .GT. 10000.) THEN - IOA4(I,J,KWD) = 6 - NS6 = NS6 + 1 - ENDIF - ENDDO - ENDDO - ENDDO -C - WRITE(6,*) "! MAKEOA3 EXIT" -C - RETURN - END SUBROUTINE MAKEOA3 - -!> Print out the maximum and minimum values of -!! an array. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE minmxj(IM,JM,A,title) - implicit none - - real A(IM,JM),rmin,rmax - integer i,j,IM,JM - character*8 title - - rmin=1.e+10 - rmax=-rmin -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)rmax=A(i,j) - if(A(i,j).le.rmin)rmin=A(i,j) - ENDDO - ENDDO - write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -C - RETURN - END - -!> Print out the maximum and minimum values of -!! an array. Pass back the i/j location of the -!! maximum value. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[out] imax 'i' location of maximum -!! @param[out] jmax 'j' location of maximum -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE mnmxja(IM,JM,A,imax,jmax,title) - implicit none - - real A(IM,JM),rmin,rmax - integer i,j,IM,JM,imax,jmax - character*8 title - - rmin=1.e+10 - rmax=-rmin -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)then - rmax=A(i,j) - imax=i - jmax=j - endif - if(A(i,j).le.rmin)rmin=A(i,j) - ENDDO - ENDDO - write(6,150)rmin,rmax,title -150 format('rmin=',e13.4,2x,'rmax=',e13.4,2x,a8,' ') -C - RETURN - END - -!> Read input global 30-arc second orography data. -!! -!! @param[out] glob The orography data. -!! @author Jordan Alpert NOAA/EMC - subroutine read_g(glob) - implicit none - - include 'netcdf.inc' - - integer*2, intent(out) :: glob(360*120,180*120) - - integer :: ncid, error, id_var, fsize - - fsize=65536 - - error=NF__OPEN("./topography.gmted2010.30s.nc", - & NF_NOWRITE,fsize,ncid) - call netcdf_err(error, 'Open file topography.gmted2010.30s.nc' ) - error=nf_inq_varid(ncid, 'topo', id_var) - call netcdf_err(error, 'Inquire varid of topo') - error=nf_get_var_int2(ncid, id_var, glob) - call netcdf_err(error, 'Read topo') - error = nf_close(ncid) - - print*,' ' - call maxmin (glob,360*120*180*120,'global0') - - return - end subroutine read_g - -!> Print the maximum, mininum, mean and -!! standard deviation of an array. -!! -!! @param [in] ia The array to be checked. -!! @param [in] len The number of points to be checked. -!! @param [in] tile A name associated with the array. -!! @author Jordan Alpert NOAA/EMC - subroutine maxmin(ia,len,tile) -ccmr - implicit none -ccmr - integer*2 ia(len) - character*7 tile - integer iaamax, iaamin, len, m, ja, kount - integer(8) sum2,std,mean,isum - integer i_count_notset,kount_9 -! --- missing is -9999 -c - isum = 0 - sum2 = 0 - kount = 0 - kount_9 = 0 - iaamax = -9999999 -ccmr iaamin = 1 - iaamin = 9999999 - i_count_notset=0 - do 10 m=1,len - ja=ia(m) -ccmr if ( ja .lt. 0 ) print *,' ja < 0:',ja -ccmr if ( ja .eq. -9999 ) goto 10 - if ( ja .eq. -9999 ) then - kount_9=kount_9+1 - goto 10 - endif - if ( ja .eq. -12345 ) i_count_notset=i_count_notset+1 -ccmr if ( ja .eq. 0 ) goto 11 - iaamax = max0( iaamax, ja ) - iaamin = min0( iaamin, ja ) -! iaamax = max0( iaamax, ia(m,j) ) -! iaamin = min0( iaamin, ia(m,j) ) - 11 continue - kount = kount + 1 - isum = isum + ja -ccmr sum2 = sum2 + ifix( float(ja) * float(ja) ) - sum2 = sum2 + ja*ja - 10 continue -! - mean = isum/kount - std = ifix(sqrt(float((sum2/(kount))-mean**2))) - print*,tile,' max=',iaamax,' min=',iaamin,' sum=',isum, - & ' i_count_notset=',i_count_notset - print*,tile,' mean=',mean,' std.dev=',std, - & ' ko9s=',kount,kount_9,kount+kount_9 - return - end - -!> Print out the maximum and minimum values of -!! an array and their i/j location. Also print out -!! the number of undefined points. -!! -!! @param[in] im The 'i' dimension of the array. -!! @param[in] jm The 'i' dimension of the array. -!! @param[in] a The array to check. -!! @param[in] title Name of the data to be checked. -!! @author Jordan Alpert NOAA/EMC - SUBROUTINE minmaxj(IM,JM,A,title) - implicit none - - real(kind=4) A(IM,JM),rmin,rmax,undef - integer i,j,IM,JM,imax,jmax,imin,jmin,iundef - character*8 title,chara - data chara/' '/ - chara=title - rmin=1.e+10 - rmax=-rmin - imax=0 - imin=0 - jmax=0 - jmin=0 - iundef=0 - undef=-9999. -csela.................................................... -csela if(rmin.eq.1.e+10)return -csela.................................................... - DO j=1,JM - DO i=1,IM - if(A(i,j).ge.rmax)then - rmax=A(i,j) - imax=i - jmax=j - endif - if(A(i,j).le.rmin)then - if ( A(i,j) .eq. undef ) then - iundef = iundef + 1 - else - rmin=A(i,j) - imin=i - jmin=j - endif - endif - ENDDO - ENDDO - write(6,150)chara,rmin,imin,jmin,rmax,imax,jmax,iundef -150 format(1x,a8,2x,'rmin=',e13.4,2i6,2x,'rmax=',e13.4,3i6) -C - RETURN - END - -!> Convert from latitude and longitude to x,y,z coordinates. -!! -!! @param[in] siz Number of points to convert. -!! @param[in] lon Longitude of points to convert. -!! @param[in] lat Latitude of points to convert. -!! @param[out] x 'x' coordinate of the converted points. -!! @param[out] y 'y' coordinate of the converted points. -!! @param[out] z 'z' coordinate of the converted points. -!! @author GFDL programmer - subroutine latlon2xyz(siz,lon, lat, x, y, z) - implicit none - integer, intent(in) :: siz - real, intent(in) :: lon(siz), lat(siz) - real, intent(out) :: x(siz), y(siz), z(siz) - - integer n - - do n = 1, siz - x(n) = cos(lat(n))*cos(lon(n)) - y(n) = cos(lat(n))*sin(lon(n)) - z(n) = sin(lat(n)) - enddo - end - -!> Compute spherical angle. -!! -!! @param[in] v1 Vector 1. -!! @param[in] v2 Vector 2. -!! @param[in] v3 Vector 3. -!! @return spherical_angle Spherical Angle. -!! @author GFDL programmer - FUNCTION spherical_angle(v1, v2, v3) - implicit none - real, parameter :: EPSLN30 = 1.e-30 - real, parameter :: PI=3.1415926535897931 - real v1(3), v2(3), v3(3) - real spherical_angle - - real px, py, pz, qx, qy, qz, ddd; - - ! vector product between v1 and v2 - px = v1(2)*v2(3) - v1(3)*v2(2) - py = v1(3)*v2(1) - v1(1)*v2(3) - pz = v1(1)*v2(2) - v1(2)*v2(1) - ! vector product between v1 and v3 - qx = v1(2)*v3(3) - v1(3)*v3(2); - qy = v1(3)*v3(1) - v1(1)*v3(3); - qz = v1(1)*v3(2) - v1(2)*v3(1); - - ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); - if ( ddd <= 0.0 ) then - spherical_angle = 0. - else - ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd); - if( abs(ddd-1) < EPSLN30 ) ddd = 1; - if( abs(ddd+1) < EPSLN30 ) ddd = -1; - if ( ddd>1. .or. ddd<-1. ) then - !FIX to correctly handle co-linear points (angle near pi or 0) */ - if (ddd < 0.) then - spherical_angle = PI - else - spherical_angle = 0. - endif - else - spherical_angle = acos( ddd ) - endif - endif - - return - END - -!> Check if a point is inside a polygon. -!! -!! @param[in] lon1 Longitude of the point to check. -!! @param[in] lat1 Latitude of the point to check. -!! @param[in] npts Number of polygon vertices. -!! @param[in] lon2 Longitude of the polygon vertices. -!! @param[in] lat2 Latitude of the polygon vertices. -!! @return inside_a_polygon When true, point is within -!! the polygon. -!! @author GFDL programmer - FUNCTION inside_a_polygon(lon1, lat1, npts, lon2, lat2) - implicit none - real, parameter :: EPSLN10 = 1.e-10 - real, parameter :: EPSLN8 = 1.e-8 - real, parameter :: PI=3.1415926535897931 - real, parameter :: RANGE_CHECK_CRITERIA=0.05 - real :: anglesum, angle, spherical_angle - integer i, ip1 - real lon1, lat1 - integer npts - real lon2(npts), lat2(npts) - real x2(npts), y2(npts), z2(npts) - real lon1_1d(1), lat1_1d(1) - real x1(1), y1(1), z1(1) - real pnt0(3),pnt1(3),pnt2(3) - logical inside_a_polygon - real max_x2,min_x2,max_y2,min_y2,max_z2,min_z2 - !first convert to cartesian grid */ - call latlon2xyz(npts,lon2, lat2, x2, y2, z2); - lon1_1d(1) = lon1 - lat1_1d(1) = lat1 - call latlon2xyz(1,lon1_1d, lat1_1d, x1, y1, z1); - inside_a_polygon = .false. - max_x2 = maxval(x2) - if( x1(1) > max_x2+RANGE_CHECK_CRITERIA ) return - min_x2 = minval(x2) - if( x1(1)+RANGE_CHECK_CRITERIA < min_x2 ) return - max_y2 = maxval(y2) - if( y1(1) > max_y2+RANGE_CHECK_CRITERIA ) return - min_y2 = minval(y2) - if( y1(1)+RANGE_CHECK_CRITERIA < min_y2 ) return - max_z2 = maxval(z2) - if( z1(1) > max_z2+RANGE_CHECK_CRITERIA ) return - min_z2 = minval(z2) - if( z1(1)+RANGE_CHECK_CRITERIA < min_z2 ) return - - pnt0(1) = x1(1) - pnt0(2) = y1(1) - pnt0(3) = z1(1) - - anglesum = 0; - do i = 1, npts - if(abs(x1(1)-x2(i)) < EPSLN10 .and. - & abs(y1(1)-y2(i)) < EPSLN10 .and. - & abs(z1(1)-z2(i)) < EPSLN10 ) then ! same as the corner point - inside_a_polygon = .true. - return - endif - ip1 = i+1 - if(ip1>npts) ip1 = 1 - pnt1(1) = x2(i) - pnt1(2) = y2(i) - pnt1(3) = z2(i) - pnt2(1) = x2(ip1) - pnt2(2) = y2(ip1) - pnt2(3) = z2(ip1) - - angle = spherical_angle(pnt0, pnt2, pnt1); -! anglesum = anglesum + spherical_angle(pnt0, pnt2, pnt1); - anglesum = anglesum + angle - enddo - - if(abs(anglesum-2*PI) < EPSLN8) then - inside_a_polygon = .true. - else - inside_a_polygon = .false. - endif - - return - - end - -!> Count the number of high-resolution orography points that -!! are higher than the model grid box average orography height. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] zslm The high-resolution land mask. -!! @param[in] delxn Resolution of the high-res orography data. -!! @return get_xnsum The number of high-res points above the -!! mean orography. -!! @author GFDL Programmer - function get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,zslm,delxn) - implicit none - - real get_xnsum - real, intent(in) :: lon1,lat1,lon2,lat2,delxn - integer, intent(in) :: IMN,JMN - real, intent(in) :: glat(JMN) - integer, intent(in) :: zavg(IMN,JMN),zslm(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real oro, HEIGHT - real xland,xwatr,xl1,xs1,slm,xnsum - !---figure out ist,ien,jst,jen - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - !--- compute average oro - oro = 0.0 - xnsum = 0 - xland = 0 - xwatr = 0 - xl1 = 0 - xs1 = 0 - do j = jst,jen - do i1 = 1, ien - ist + 1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - XLAND = XLAND + FLOAT(ZSLM(I,J)) - XWATR = XWATR + FLOAT(1-ZSLM(I,J)) - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XL1 = XL1 + HEIGHT * FLOAT(ZSLM(I,J)) - XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(I,J)) - enddo - enddo - if( XNSUM > 1.) THEN - SLM = FLOAT(NINT(XLAND/XNSUM)) - IF(SLM.NE.0.) THEN - ORO= XL1 / XLAND - ELSE - ORO = XS1 / XWATR - ENDIF - ENDIF - - get_xnsum = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - IF ( HEIGHT .gt. ORO ) get_xnsum = get_xnsum + 1 - enddo - enddo - - end function get_xnsum - -!> Count the number of high-resolution orography points that -!! are higher than a critical value inside a model grid box -!! (or a portion of a model grid box). The critical value is a -!! function of the standard deviation of orography. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] delxn Resolution of the high-res orography data. -!! @param[out] xnsum1 The number of high-resolution orography -!! above the critical value inside a model grid box. -!! @param[out] xnsum2 The number of high-resolution orography -!! points inside a model grid box. -!! @param[out] hc Critical height. -!! @author GFDL Programmer - subroutine get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,delxn,xnsum1,xnsum2,HC) - implicit none - - real, intent(out) :: xnsum1,xnsum2,HC - real lon1,lat1,lon2,lat2,delxn - integer IMN,JMN - real glat(JMN) - integer zavg(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real HEIGHT, var - real XW1,XW2,xnsum - !---figure out ist,ien,jst,jen - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - !--- compute average oro - xnsum = 0 - XW1 = 0 - XW2 = 0 - do j = jst,jen - do i1 = 1, ien - ist + 1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - XNSUM = XNSUM + 1. - HEIGHT = FLOAT(ZAVG(I,J)) - IF(HEIGHT.LT.-990.) HEIGHT = 0.0 - XW1 = XW1 + HEIGHT - XW2 = XW2 + HEIGHT ** 2 - enddo - enddo - var = SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) - HC = 1116.2 - 0.878 * VAR - xnsum1 = 0 - xnsum2 = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF ( HEIGHT .gt. HC ) xnsum1 = xnsum1 + 1 - xnsum2 = xnsum2 + 1 - enddo - enddo - - end subroutine get_xnsum2 - -!> Count the number of high-resolution orography points that -!! are higher than a critical value inside a model grid box -!! (or a portion of a model grid box). Unlike routine -!! get_xnsum2(), this routine does not compute the critical -!! value. Rather, it is passed in. -!! -!! @param[in] lon1 Longitude of corner point 1 of the model -!! grid box. -!! @param[in] lat1 Latitude of corner point 1 of the model -!! grid box. -!! @param[in] lon2 Longitude of corner point 2 of the model -!! grid box. -!! @param[in] lat2 Latitude of corner point 2 of the model -!! grid box. -!! @param[in] imn 'i' dimension of the high-resolution orography -!! data. -!! @param[in] jmn 'j' dimension of the high-resolution orography -!! data. -!! @param[in] glat Latitude of each row of the high-resolution -!! orography data. -!! @param[in] zavg The high-resolution orography. -!! @param[in] delxn Resolution of the high-res orography data. -!! @param[out] xnsum1 The number of high-resolution orography -!! above the critical value inside a model grid box. -!! @param[out] xnsum2 The number of high-resolution orography -!! points inside a model grid box. -!! @param[in] hc Critical height. -!! @author GFDL Programmer - subroutine get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN, - & glat,zavg,delxn,xnsum1,xnsum2,HC) - implicit none - - real, intent(out) :: xnsum1,xnsum2 - real lon1,lat1,lon2,lat2,delxn - integer IMN,JMN - real glat(JMN) - integer zavg(IMN,JMN) - integer i, j, ist, ien, jst, jen, i1 - real HEIGHT, HC - !---figure out ist,ien,jst,jen - ! if lat1 or lat 2 is 90 degree. set jst = JMN - jst = JMN - jen = JMN - do j = 1, JMN - if( GLAT(J) .GT. lat1 ) then - jst = j - exit - endif - enddo - do j = 1, JMN - if( GLAT(J) .GT. lat2 ) then - jen = j - exit - endif - enddo - - - ist = lon1/delxn + 1 - ien = lon2/delxn - if(ist .le.0) ist = ist + IMN - if(ien < ist) ien = ien + IMN - - xnsum1 = 0 - xnsum2 = 0 - do j = jst, jen - do i1= 1, ien-ist+1 - i = ist + i1 -1 - if( i .LE. 0) i = i + imn - if( i .GT. IMN) i = i - imn - HEIGHT = FLOAT(ZAVG(I,J)) - IF ( HEIGHT .gt. HC ) xnsum1 = xnsum1 + 1 - xnsum2 = xnsum2 + 1 - enddo - enddo - - end subroutine get_xnsum3 -!> Get the date/time for the system clock. -!! -!! @author Mark Iredell -!! @return timef - real function timef() - character(8) :: date - character(10) :: time - character(5) :: zone - integer,dimension(8) :: values - integer :: total - real :: elapsed - call date_and_time(date,time,zone,values) - total=(3600*values(5))+(60*values(6)) - * +values(7) - elapsed=float(total) + (1.0e-3*float(values(8))) - timef=elapsed - return - end diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 new file mode 100644 index 000000000..d8e55c96a --- /dev/null +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.F90 @@ -0,0 +1,1365 @@ +!> @file +!! Terrain maker for the ufs weather model. +!! @author Mark Iredell @date 92-04-16 + +!> This program creates landmask, land fraction, terrain and +!! and fields required for the model's gravity wave drag +!! (GWD) scheme. +!! +!! Specifically: +!! +!! - Land mask (yes/no flag) +!! - Land fraction +!! - Terrain (orography) +!! - Maximum elevation +!! - Standard deviation of terrain +!! - Convexity +!! - Orographic Asymetry - W/S/SW/NW directional components. +!! - Orographic Length Scale - W/S/SW/NW directional components. +!! - Anisotropy +!! - Slope of terrain +!! - Angle of mountain range with respect to East. +!! +!! This program operates on a single cubed-sphere tile. +!! +!! Optionally, the program can compute and output only the +!! land mask and land fraction. Or, it can read in the mask +!! and fraction from an external file, then compute the +!! terrain and GWD fields using that mask. These options +!! are used to support coupled (atm/oceann) runs of the UFS. +!! The process is: +!! - Run this program and output the mask/fraction only. +!! - Adjust or merge the mask/fraction with the ocean +!! mask (using another program). +!! - Read in this 'merged' mask/fraction and compute the +!! terrain and GWD fields. +!! +!! PROGRAM HISTORY LOG: +!! - 92-04-16 IREDELL +!! - 98-02-02 IREDELL FILTER +!! - 98-05-31 HONG Modified for subgrid orography used in Kim's scheme +!! - 98-12-31 HONG Modified for high-resolution GTOPO orography +!! - 99-05-31 HONG Modified for getting OL4 (mountain fraction) +!! - 00-02-10 Moorthi's modifications +!! - 00-04-11 HONG Modified for reduced grids +!! - 00-04-12 Iredell Modified for reduced grids +!! - 02-01-07 (*j*) modified for principal axes of orography +!! There are now 14 files, 4 additional for lm mb +!! - 04-04-04 (*j*) re-Test on IST/ilen calc for sea-land mask(*j*) +!! - 04-09-04 minus sign here in MAKEOA IST and IEN as in MAKEMT! +!! - 05-09-05 if test on HK and HLPRIM for GAMMA SQRT +!! - 07-08-07 replace 8' with 30" incl GICE, conintue w/ S-Y. lake slm +!! - 08-08-07 All input 30", UMD option, and filter as described below +!! - 24-08-15 Remove old code used by spectral GFS. +!! +!! INPUT FILES: +!! - UNIT5 - PROGRAM CONTROL NAMELIST. +!! - NCID - MODEL 'GRID' FILE +!! - NCID - GMTED2010 USGS orography (NetCDF) +!! - NCID - 30" UMD land cover mask. (NetCDF) +!! - NCID - GICE Grumbine 30" RAMP Antarctica orog. (NetCDF) +!! - NCID - MERGE FILE. CONTAINS LAND MASK, FRACTION AND +!! LAKE FRACTION THAT HAS BEEN MERGED WITH AN +!! OCEAN GRID. (NetCDF) +!! +!! OUTPUT FILES (ALL ON A SINGLE CUBED-SPHERE TILE) : +!! - NCID - OROGRAPHY FILE (NetCDF) IF MASK_ONLY=FALSE +!! - NCID - MASK FILE (NetCDF) IF MASK_ONLY=TRUE +!! - CONTAINS ONLY LAND MASK AND FRACTION. +!! +!! @return 0 for success, error code otherwise. + + use io_utils, only : read_mdl_dims + implicit none + + character(len=256) :: mdl_grid_file = "none" + character(len=256) :: external_mask_file = "none" + integer :: im, jm, efac + logical :: mask_only = .false. + + print*,"- BEGIN OROGRAPHY PROGRAM." + + read(5,*) mdl_grid_file + read(5,*) mask_only + read(5,*) external_mask_file + + efac = 0 + + if (mask_only) then + print*,"- WILL COMPUTE LANDMASK ONLY." + endif + + if (trim(external_mask_file) /= "none") then + print*,"- WILL USE EXTERNAL LANDMASK FROM FILE: ", trim(external_mask_file) + endif + + call read_mdl_dims(mdl_grid_file, im, jm) + + call tersub(im,jm,efac,mdl_grid_file,mask_only,external_mask_file) + + print*,"- NORMAL TERMINATION." + + stop + end + +!> Driver routine to compute terrain. +!! +!! @param[in] IM "i" dimension of the model grid tile. +!! @param[in] JM "j" dimension of the model grid tile. +!! @param[in] EFAC Factor to adjust orography by its variance. +!! @param[in] OUTGRID The 'grid' file for the model tile. +!! grid. When specified, will be interpolated to model tile. +!! When not specified, program will create fields from +!! raw high-resolution topography data. +!! @param[in] MASK_ONLY Flag to generate the Land Mask only +!! @param[in] EXTERNAL_MASK_FILE File containing an externally +!! generated land mask/fraction. +!! @author Jordan Alpert NOAA/EMC + SUBROUTINE TERSUB(IM,JM,EFAC,OUTGRID,MASK_ONLY,EXTERNAL_MASK_FILE) + + use io_utils, only : qc_orog_by_ramp, write_mask_netcdf, & + read_global_mask, read_global_orog, & + read_mask, write_netcdf, & + read_mdl_grid_file + use orog_utils, only : minmax, timef, remove_isolated_pts + + implicit none + + integer, parameter :: imn = 360*120 + integer, parameter :: jmn = 180*120 + + integer, intent(in) :: IM,JM,efac + character(len=*), intent(in) :: OUTGRID + character(len=*), intent(in) :: EXTERNAL_MASK_FILE + + logical, intent(in) :: mask_only + + integer :: i,j + integer :: itest,jtest + + integer, allocatable :: ZAVG(:,:),ZSLM(:,:) + integer(1), allocatable :: UMD(:,:) + integer(2), allocatable :: glob(:,:) + + real :: tbeg,tend,tbeg1 + + real, allocatable :: XLAT(:),XLON(:) + real, allocatable :: GEOLON(:,:),GEOLON_C(:,:),DX(:,:) + real, allocatable :: GEOLAT(:,:),GEOLAT_C(:,:),DY(:,:) + real, allocatable :: SLM(:,:),ORO(:,:),VAR(:,:) + real, allocatable :: land_frac(:,:),lake_frac(:,:) + real, allocatable :: THETA(:,:),GAMMA(:,:),SIGMA(:,:),ELVMAX(:,:) + real, allocatable :: VAR4(:,:) + real, allocatable :: OA(:,:,:),OL(:,:,:),HPRIME(:,:,:) + + logical :: is_south_pole(IM,JM), is_north_pole(IM,JM) + + tbeg1=timef() + tbeg=timef() + + allocate (glob(IMN,JMN)) + allocate (ZAVG(IMN,JMN)) + allocate (ZSLM(IMN,JMN)) + allocate (UMD(IMN,JMN)) + +! Read global mask data. + + call read_global_mask(imn,jmn,umd) + +! Read global orography data. + + call read_global_orog(imn,jmn,glob) + +! ZSLM initialize with all land (1). Ocean is '0'. + + ZSLM=1 + +! ZAVG initialize from glob + + ZAVG=glob + + do j=1,jmn + do i=1,imn + if ( UMD(i,j) .eq. 0 ) ZSLM(i,j) = 0 + enddo + enddo + + deallocate (UMD,glob) + +! Fixing an error in the topo 30" data set at pole (-9999). + + do i=1,imn + ZSLM(i,1)=0 + ZSLM(i,JMN)=1 + enddo + +! Quality control the global topography data over Antarctica +! using RAMP data. + + call qc_orog_by_ramp(imn, jmn, zavg, zslm) + + allocate (GEOLON(IM,JM),GEOLON_C(IM+1,JM+1),DX(IM,JM)) + allocate (GEOLAT(IM,JM),GEOLAT_C(IM+1,JM+1),DY(IM,JM)) + allocate (SLM(IM,JM)) + allocate (land_frac(IM,JM),lake_frac(IM,JM)) + +! Reading grid file. + + call read_mdl_grid_file(outgrid,im,jm,geolon,geolon_c, & + geolat,geolat_c,dx,dy,is_north_pole,is_south_pole) + + tend=timef() + print*,"- TIMING: READING INPUT DATA ",tend-tbeg + ! + tbeg=timef() + + IF (EXTERNAL_MASK_FILE == 'none') then + CALL MAKE_MASK(ZSLM,SLM,land_frac, & + IM,JM,IMN,JMN,geolon_c,geolat_c) + lake_frac=9999.9 + ELSE + CALL READ_MASK(EXTERNAL_MASK_FILE,SLM,land_frac, & + lake_frac,im,jm) + ENDIF + + IF (MASK_ONLY) THEN + print*,'- WILL COMPUTE LANDMASK ONLY.' + CALL WRITE_MASK_NETCDF(IM,JM,SLM,land_frac, & + 1,1,GEOLON,GEOLAT) + + DEALLOCATE(ZAVG, ZSLM, SLM, LAND_FRAC, LAKE_FRAC) + DEALLOCATE(GEOLON, GEOLON_C, GEOLAT, GEOLAT_C) + print*,'- NORMAL TERMINATION.' + STOP + END IF + + allocate (VAR(IM,JM),VAR4(IM,JM),ORO(IM,JM)) + + CALL MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & + IM,JM,IMN,JMN,geolon_c,geolat_c,lake_frac,land_frac) + + tend=timef() + print*,"- TIMING: MASK AND OROG CREATION ", tend-tbeg + + call minmax(IM,JM,ORO,'ORO ') + call minmax(IM,JM,SLM,'SLM ') + call minmax(IM,JM,VAR,'VAR ') + call minmax(IM,JM,VAR4,'VAR4 ') + +! Compute mtn principal coord HTENSR: THETA,GAMMA,SIGMA + + allocate (THETA(IM,JM),GAMMA(IM,JM),SIGMA(IM,JM),ELVMAX(IM,JM)) + + tbeg=timef() + CALL MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, & + IM,JM,IMN,JMN,geolon_c,geolat_c,SLM) + tend=timef() + + print*,"- TIMING: CREATE PRINCIPLE COORDINATE ",tend-tbeg + + call minmax(IM,JM,THETA,'THETA ') + call minmax(IM,JM,GAMMA,'GAMMA ') + call minmax(IM,JM,SIGMA,'SIGMA ') + +! COMPUTE MOUNTAIN DATA : OA OL + + allocate (OA(IM,JM,4),OL(IM,JM,4)) + + tbeg=timef() + CALL MAKEOA2(ZAVG,zslm,VAR,OA,OL,ELVMAX,ORO, & + IM,JM,IMN,JMN,geolon_c,geolat_c, & + geolon,geolat,dx,dy,is_south_pole,is_north_pole) + + tend=timef() + + print*,"- TIMING: CREATE ASYMETRY AND LENGTH SCALE ",tend-tbeg + + deallocate (ZSLM,ZAVG) + deallocate (dx,dy) + + tbeg=timef() + call minmax(IM,JM,OA,'OA ') + call minmax(IM,JM,OL,'OL ') + call minmax(IM,JM,ELVMAX,'ELVMAX ') + call minmax(IM,JM,ORO,'ORO ') + +! Replace maximum elevation with max elevation minus orography. +! If maximum elevation is less than the orography, replace with +! a proxy. + + print*,"- QC MAXIMUM ELEVATION." + DO J = 1,JM + DO I = 1,IM + if (ELVMAX(I,J) .lt. ORO(I,J) ) then + ELVMAX(I,J) = MAX( 3. * VAR(I,J),0.) + else + ELVMAX(I,J) = MAX( ELVMAX(I,J) - ORO(I,J),0.) + endif + ENDDO + ENDDO + + call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) + + print*,"- ZERO FIELDS OVER OCEAN." + + DO J = 1,JM + DO I = 1,IM + IF(SLM(I,J).EQ.0.) THEN +! VAR(I,J) = 0. + VAR4(I,J) = 0. + OA(I,J,1) = 0. + OA(I,J,2) = 0. + OA(I,J,3) = 0. + OA(I,J,4) = 0. + OL(I,J,1) = 0. + OL(I,J,2) = 0. + OL(I,J,3) = 0. + OL(I,J,4) = 0. +! THETA(I,J) =0. +! GAMMA(I,J) =0. +! SIGMA(I,J) =0. +! ELVMAX(I,J)=0. +! --- the sub-grid scale parameters for mtn blocking and gwd retain +! --- properties even if over ocean but there is elevation within the +! --- gaussian grid box. + ENDIF + ENDDO + ENDDO + + IF (EXTERNAL_MASK_FILE == 'none') then + + call remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) + + endif + + allocate(hprime(im,jm,14)) + + DO J=1,JM + DO I=1,IM + ORO(I,J) = ORO(I,J) + EFAC*VAR(I,J) + HPRIME(I,J,1) = VAR(I,J) + HPRIME(I,J,2) = VAR4(I,J) + HPRIME(I,J,3) = oa(I,J,1) + HPRIME(I,J,4) = oa(I,J,2) + HPRIME(I,J,5) = oa(I,J,3) + HPRIME(I,J,6) = oa(I,J,4) + HPRIME(I,J,7) = ol(I,J,1) + HPRIME(I,J,8) = ol(I,J,2) + HPRIME(I,J,9) = ol(I,J,3) + HPRIME(I,J,10)= ol(I,J,4) + HPRIME(I,J,11)= THETA(I,J) + HPRIME(I,J,12)= GAMMA(I,J) + HPRIME(I,J,13)= SIGMA(I,J) + HPRIME(I,J,14)= ELVMAX(I,J) + ENDDO + ENDDO + + deallocate(VAR4) + + call minmax(IM,JM,ELVMAX,'ELVMAX ',itest,jtest) + call minmax(IM,JM,ORO,'ORO ') + + print *,'- ORO(itest,jtest),itest,jtest:', & + ORO(itest,jtest),itest,jtest + print *,'- ELVMAX(',itest,jtest,')=',ELVMAX(itest,jtest) + + tend=timef() + print*,"- TIMING: FINAL QUALITY CONTROL ", tend-tbeg + + allocate(xlat(jm), xlon(im)) + do j = 1, jm + xlat(j) = geolat(1,j) + enddo + do i = 1, im + xlon(i) = geolon(i,1) + enddo + + tbeg=timef() + CALL WRITE_NETCDF(IM,JM,SLM,land_frac,ORO,HPRIME,1,1, & + GEOLON(1:IM,1:JM),GEOLAT(1:IM,1:JM), XLON,XLAT) + tend=timef() + print*,"- TIMING: WRITE OUTPUT FILE ", tend-tbeg + + deallocate(XLAT,XLON) + deallocate (GEOLON,GEOLON_C,GEOLAT,GEOLAT_C) + deallocate (SLM,ORO,VAR,land_frac) + deallocate (THETA,GAMMA,SIGMA,ELVMAX,HPRIME) + + tend=timef() + print*,"- TIMING: TOTAL RUNTIME ", tend-tbeg1 + + return + END SUBROUTINE TERSUB + +!> Create the land-mask, land fraction. +!! This routine is used for the FV3GFS model. +!! +!! @param[in] zslm The high-resolution input land-mask dataset. +!! @param[out] slm Land-mask on the model tile. +!! @param[out] land_frac Land fraction on the model tile. +!! @param[in] im "i" dimension of the model grid. +!! @param[in] jm "j" dimension of the model grid. +!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. +!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. +!! @param[in] lon_c Longitude of the model grid corner points. +!! @param[in] lat_c Latitude on the model grid corner points. +!! @author GFDL Programmer + SUBROUTINE MAKE_MASK(zslm,slm,land_frac, & + im,jm,imn,jmn,lon_c,lat_c) + + use orog_utils, only : inside_a_polygon, get_index + + implicit none + + integer, intent(in) :: zslm(imn,jmn) + integer, intent(in) :: im, jm, imn, jmn + + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + + real, intent(out) :: slm(im,jm) + real, intent(out) :: land_frac(im,jm) + + integer, parameter :: MAXSUM=20000000 + + real, parameter :: D2R = 3.14159265358979/180. + + integer jst, jen + real GLAT(JMN), GLON(IMN) + real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) + integer JM1,i,j,nsum,nsum_all,ii,jj,numx,i2 + integer ilist(IMN) + real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1 + real XNSUM_ALL,XLAND_ALL,XWATR_ALL + + print *,'- CREATE LANDMASK AND LAND FRACTION.' +!---- GLOBAL XLAT AND XLON ( DEGREE ) + + JM1 = JM - 1 + DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION + + DO J=1,JMN + GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 + ENDDO + DO I=1,IMN + GLON(I) = 0. + (I-1) * DELXN + DELXN * 0.5 + ENDDO + + land_frac(:,:) = 0.0 +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! +! (*j*) for hard wired zero offset (lambda s =0) for terr05 +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,lono, & +!$omp lato,lono_rad,lato_rad,jst,jen,ilist,numx,jj,i2,ii,loni,lati, & +!$omp xnsum_all,xland_all,xwatr_all,nsum_all) +! + DO J=1,JM + DO I=1,IM + XNSUM = 0.0 + XLAND = 0.0 + XWATR = 0.0 + nsum = 0 + XNSUM_ALL = 0.0 + XLAND_ALL = 0.0 + XWATR_ALL = 0.0 + nsum_all = 0 + + LONO(1) = lon_c(i,j) + LONO(2) = lon_c(i+1,j) + LONO(3) = lon_c(i+1,j+1) + LONO(4) = lon_c(i,j+1) + LATO(1) = lat_c(i,j) + LATO(2) = lat_c(i+1,j) + LATO(3) = lat_c(i+1,j+1) + LATO(4) = lat_c(i,j+1) + LONO_RAD=LONO*D2R + LATO_RAD=LATO*D2R + call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) + do jj = jst, jen; do i2 = 1, numx + ii = ilist(i2) + LONI = ii*DELXN + LATI = -90 + jj*DELXN + + XLAND_ALL = XLAND_ALL + FLOAT(ZSLM(ii,jj)) + XWATR_ALL = XWATR_ALL + FLOAT(1-ZSLM(ii,jj)) + XNSUM_ALL = XNSUM_ALL + 1. + nsum_all = nsum_all+1 + if(nsum_all > MAXSUM) then + print*, "FATAL ERROR: nsum_all is greater than MAXSUM," + print*, "increase MAXSUM." + call ABORT() + endif + + if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then + + XLAND = XLAND + FLOAT(ZSLM(ii,jj)) + XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) + XNSUM = XNSUM + 1. + nsum = nsum+1 + if(nsum > MAXSUM) then + print*, "FATAL ERROR: nsum is greater than MAXSUM," + print*, "increase MAXSUM." + call ABORT() + endif + endif + enddo ; enddo + + + IF(XNSUM.GT.1.) THEN + land_frac(i,j) = XLAND/XNSUM + SLM(I,J) = FLOAT(NINT(XLAND/XNSUM)) + ELSEIF(XNSUM_ALL.GT.1.) THEN + land_frac(i,j) = XLAND_ALL/XNSUM_ALL + SLM(I,J) = FLOAT(NINT(XLAND_ALL/XNSUM_ALL)) + ELSE + print*, "FATAL ERROR: no source points in MAKE_MASK." + call ABORT() + ENDIF + ENDDO + ENDDO +!$omp end parallel do + + RETURN + END SUBROUTINE MAKE_MASK +!> Create the orography, standard deviation of orography +!! and the convexity on a model tile. +!! +!! @param[in] zavg The high-resolution input orography dataset. +!! @param[in] zslm The high-resolution input land-mask dataset. +!! @param[out] oro Orography on the model tile. +!! @param[in] slm Land-mask on the model tile. +!! @param[out] var Standard deviation of orography on the model tile. +!! @param[out] var4 Convexity on the model tile. +!! @param[in] im "i" dimension of the model grid. +!! @param[in] jm "j" dimension of the model grid. +!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. +!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. +!! @param[in] lon_c Longitude of the model grid corner points. +!! @param[in] lat_c Latitude on the model grid corner points. +!! @param[in] lake_frac Fractional lake within the grid +!! @param[in] land_frac Fractional land within the grid +!! @author GFDL Programmer + SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,VAR,VAR4, & + IM,JM,IMN,JMN,lon_c,lat_c,lake_frac,land_frac) + + use orog_utils, only : inside_a_polygon, get_index + + implicit none + + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + integer, intent(in) :: im, jm, imn, jmn + + real, intent(in) :: slm(im,jm) + real, intent(in) :: lake_frac(im,jm),land_frac(im,jm) + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + + real, intent(out) :: oro(im,jm) + real, intent(out) :: var(im,jm),var4(im,jm) + + integer, parameter :: MAXSUM=20000000 + real, parameter :: D2R = 3.14159265358979/180. + + real, dimension(:), allocatable :: hgt_1d, hgt_1d_all + + real GLAT(JMN), GLON(IMN) + integer JST, JEN + real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) + real HEIGHT + integer JM1,i,j,nsum,nsum_all,ii,jj,i1,numx,i2 + integer ilist(IMN) + real DELXN,XNSUM,XLAND,XWATR,XL1,XS1,XW1,XW2,XW4 + real XNSUM_ALL,XLAND_ALL,XWATR_ALL,HEIGHT_ALL + real XL1_ALL,XS1_ALL,XW1_ALL,XW2_ALL,XW4_ALL + + print*,'- CREATE OROGRAPHY AND CONVEXITY.' + allocate(hgt_1d(MAXSUM)) + allocate(hgt_1d_all(MAXSUM)) +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! + JM1 = JM - 1 + DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION + + DO J=1,JMN + GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 + ENDDO + DO I=1,IMN + GLON(I) = 0. + (I-1) * DELXN + DELXN * 0.5 + ENDDO + +! land_frac(:,:) = 0.0 +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! +! (*j*) for hard wired zero offset (lambda s =0) for terr05 +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xwatr,nsum,xl1,xs1,xw1,xw2,xw4,lono, & +!$omp lato,jst,jen,ilist,numx,jj,i2,ii,loni,lati,height, & +!$omp lato_rad,lono_rad,hgt_1d, & +!$omp xnsum_all,xland_all,xwatr_all,nsum_all, & +!$omp xl1_all,xs1_all,xw1_all,xw2_all,xw4_all, & +!$omp height_all,hgt_1d_all) + DO J=1,JM + DO I=1,IM + ORO(I,J) = 0.0 + VAR(I,J) = 0.0 + VAR4(I,J) = 0.0 + XNSUM = 0.0 + XLAND = 0.0 + XWATR = 0.0 + nsum = 0 + XL1 = 0.0 + XS1 = 0.0 + XW1 = 0.0 + XW2 = 0.0 + XW4 = 0.0 + XNSUM_ALL = 0.0 + XLAND_ALL = 0.0 + XWATR_ALL = 0.0 + nsum_all = 0 + XL1_ALL = 0.0 + XS1_ALL = 0.0 + XW1_ALL = 0.0 + XW2_ALL = 0.0 + XW4_ALL = 0.0 + + LONO(1) = lon_c(i,j) + LONO(2) = lon_c(i+1,j) + LONO(3) = lon_c(i+1,j+1) + LONO(4) = lon_c(i,j+1) + LATO(1) = lat_c(i,j) + LATO(2) = lat_c(i+1,j) + LATO(3) = lat_c(i+1,j+1) + LATO(4) = lat_c(i,j+1) + LONO_RAD = LONO*D2R + LATO_RAD = LATO*D2R + call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) + do jj = jst, jen; do i2 = 1, numx + ii = ilist(i2) + LONI = ii*DELXN + LATI = -90 + jj*DELXN + + XLAND_ALL = XLAND_ALL + FLOAT(ZSLM(ii,jj)) + XWATR_ALL = XWATR_ALL + FLOAT(1-ZSLM(ii,jj)) + XNSUM_ALL = XNSUM_ALL + 1. + HEIGHT_ALL = FLOAT(ZAVG(ii,jj)) + nsum_all = nsum_all+1 + if(nsum_all > MAXSUM) then + print*, "FATAL ERROR: nsum_all is greater than MAXSUM," + print*, "increase MAXSUM." + call ABORT() + endif + hgt_1d_all(nsum_all) = HEIGHT_ALL + IF(HEIGHT_ALL.LT.-990.) HEIGHT_ALL = 0.0 + XL1_ALL = XL1_ALL + HEIGHT_ALL * FLOAT(ZSLM(ii,jj)) + XS1_ALL = XS1_ALL + HEIGHT_ALL * FLOAT(1-ZSLM(ii,jj)) + XW1_ALL = XW1_ALL + HEIGHT_ALL + XW2_ALL = XW2_ALL + HEIGHT_ALL ** 2 + + if(inside_a_polygon(LONI*D2R,LATI*D2R,4,LONO_RAD,LATO_RAD))then + + XLAND = XLAND + FLOAT(ZSLM(ii,jj)) + XWATR = XWATR + FLOAT(1-ZSLM(ii,jj)) + XNSUM = XNSUM + 1. + HEIGHT = FLOAT(ZAVG(ii,jj)) + nsum = nsum+1 + if(nsum > MAXSUM) then + print*, "FATAL ERROR: nsum is greater than MAXSUM," + print*, "increase MAXSUM." + call ABORT() + endif + hgt_1d(nsum) = HEIGHT + IF(HEIGHT.LT.-990.) HEIGHT = 0.0 + XL1 = XL1 + HEIGHT * FLOAT(ZSLM(ii,jj)) + XS1 = XS1 + HEIGHT * FLOAT(1-ZSLM(ii,jj)) + XW1 = XW1 + HEIGHT + XW2 = XW2 + HEIGHT ** 2 + endif + enddo ; enddo + + IF(XNSUM.GT.1.) THEN + IF(SLM(I,J) .NE. 0. .OR. LAND_FRAC(I,J) > 0.) THEN + IF (XLAND > 0) THEN + ORO(I,J)= XL1 / XLAND + ELSE + ORO(I,J)= XS1 / XWATR + ENDIF + ELSE + IF (XWATR > 0) THEN + ORO(I,J)= XS1 / XWATR + ELSE + ORO(I,J)= XL1 / XLAND + ENDIF + ENDIF + + VAR(I,J)=SQRT(MAX(XW2/XNSUM-(XW1/XNSUM)**2,0.)) + do I1 = 1, NSUM + XW4 = XW4 + (hgt_1d(I1) - ORO(i,j)) ** 4 + enddo + + IF(VAR(I,J).GT.1.) THEN + VAR4(I,J) = MIN(XW4/XNSUM/VAR(I,J) **4,10.) + ENDIF + + ELSEIF(XNSUM_ALL.GT.1.) THEN + + !IF(SLM(I,J).NE.0.) THEN + IF(SLM(I,J) .NE. 0. .OR. LAND_FRAC(I,J) > 0.) THEN + IF (XLAND_ALL > 0) THEN + ORO(I,J)= XL1_ALL / XLAND_ALL + ELSE + ORO(I,J)= XS1_ALL / XWATR_ALL + ENDIF + ELSE + IF (XWATR_ALL > 0) THEN + ORO(I,J)= XS1_ALL / XWATR_ALL + ELSE + ORO(I,J)= XL1_ALL / XLAND_ALL + ENDIF + ENDIF + + VAR(I,J)=SQRT(MAX(XW2_ALL/XNSUM_ALL-(XW1_ALL/XNSUM_ALL)**2,0.)) + do I1 = 1, NSUM_ALL + XW4_ALL = XW4_ALL + (hgt_1d_all(I1) - ORO(i,j)) ** 4 + enddo + + IF(VAR(I,J).GT.1.) THEN + VAR4(I,J) = MIN(XW4_ALL/XNSUM_ALL/VAR(I,J) **4,10.) + ENDIF + ELSE + print*, "FATAL ERROR: no source points in MAKEMT2." + call ABORT() + ENDIF + +! set orog to 0 meters at ocean. +! IF (LAKE_FRAC(I,J) .EQ. 0. .AND. SLM(I,J) .EQ. 0.)THEN + IF (LAKE_FRAC(I,J) .EQ. 0. .AND. LAND_FRAC(I,J) .EQ. 0.)THEN + ORO(I,J) = 0.0 + ENDIF + + ENDDO + ENDDO +!$omp end parallel do + + deallocate(hgt_1d) + deallocate(hgt_1d_all) + RETURN + END SUBROUTINE MAKEMT2 + +!> Make the principle coordinates - slope of orography, +!! anisotropy, angle of mountain range with respect to east. +!! This routine is used for the FV3GFS cubed-sphere grid. +!! +!! @param[in] zavg The high-resolution input orography dataset. +!! @param[in] zslm The high-resolution input land-mask dataset. +!! @param[out] theta Angle of mountain range with respect to +!! east for each model point. +!! @param[out] gamma Anisotropy for each model point. +!! @param[out] sigma Slope of orography for each model point. +!! @param[in] im "i" dimension of the model grid tile. +!! @param[in] jm "j" dimension of the model grid tile. +!! @param[in] imn "i" dimension of the hi-res input orog/mask datasets. +!! @param[in] jmn "j" dimension of the hi-res input orog/mask datasets. +!! @param[in] lon_c Longitude of model grid corner points. +!! @param[in] lat_c Latitude of the model grid corner points. +!! @param[in] SLM mask +!! @author GFDL Programmer + SUBROUTINE MAKEPC2(ZAVG,ZSLM,THETA,GAMMA,SIGMA, & + IM,JM,IMN,JMN,lon_c,lat_c,SLM) +! +!=== PC: principal coordinates of each Z avg orog box for L&M +! + use orog_utils, only : get_index, inside_a_polygon + + implicit none + + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + integer, intent(in) :: im,jm,imn,jmn + + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + real, intent(in) :: slm(im,jm) + + real, intent(out) :: theta(im,jm), gamma(im,jm), sigma(im,jm) + + real, parameter :: REARTH=6.3712E+6 + real, parameter :: D2R = 3.14159265358979/180. + + real GLAT(JMN),DELTAX(JMN) + real HL(IM,JM),HK(IM,JM) + real HX2(IM,JM),HY2(IM,JM),HXY(IM,JM),HLPRIM(IM,JM) + real SIGMA2(IM,JM) + real PI,CERTH,DELXN,DELTAY,XNSUM,XLAND + real xfp,yfp,xfpyfp,xfp2,yfp2 + real hi0,hip1,hj0,hjp1,hijax,hi1j1 + real LONO(4),LATO(4),LONI,LATI + real LONO_RAD(4), LATO_RAD(4) + integer i,j,i1,j1,i2,jst,jen,numx,i0,ip1,ijax + integer ilist(IMN) + LOGICAL DEBUG +!=== DATA DEBUG/.TRUE./ + DATA DEBUG/.FALSE./ + + print*,"- CREATE PRINCIPLE COORDINATES." + PI = 4.0 * ATAN(1.0) + CERTH = PI * REARTH +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! + DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION + DELTAY = CERTH / FLOAT(JMN) + + DO J=1,JMN + GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 + DELTAX(J) = DELTAY * COS(GLAT(J)*D2R) + ENDDO +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! + +!... DERIVITIVE TENSOR OF HEIGHT +! +!$omp parallel do & +!$omp private (j,i,xnsum,xland,xfp,yfp,xfpyfp, & +!$omp xfp2,yfp2,lono,lato,jst,jen,ilist,numx,j1,i2,i1, & +!$omp loni,lati,i0,ip1,hi0,hip1,hj0,hjp1,ijax, & +!$omp hijax,hi1j1,lono_rad,lato_rad) + JLOOP : DO J=1,JM + ILOOP : DO I=1,IM + HX2(I,J) = 0.0 + HY2(I,J) = 0.0 + HXY(I,J) = 0.0 + XNSUM = 0.0 + XLAND = 0.0 + xfp = 0.0 + yfp = 0.0 + xfpyfp = 0.0 + xfp2 = 0.0 + yfp2 = 0.0 + HL(I,J) = 0.0 + HK(I,J) = 0.0 + HLPRIM(I,J) = 0.0 + THETA(I,J) = 0.0 + GAMMA(I,J) = 0. + SIGMA2(I,J) = 0. + SIGMA(I,J) = 0. + + LONO(1) = lon_c(i,j) + LONO(2) = lon_c(i+1,j) + LONO(3) = lon_c(i+1,j+1) + LONO(4) = lon_c(i,j+1) + LATO(1) = lat_c(i,j) + LATO(2) = lat_c(i+1,j) + LATO(3) = lat_c(i+1,j+1) + LATO(4) = lat_c(i,j+1) + LATO_RAD = LATO *D2R + LONO_RAD = LONO *D2R + call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) + + do j1 = jst, jen; do i2 = 1, numx + i1 = ilist(i2) + LONI = i1*DELXN + LATI = -90 + j1*DELXN + INSIDE : if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then + +!=== set the rest of the indexs for ave: 2pt staggered derivitive +! + i0 = i1 - 1 + if (i1 - 1 .le. 0 ) i0 = i0 + imn + if (i1 - 1 .gt. imn) i0 = i0 - imn + + ip1 = i1 + 1 + if (i1 + 1 .le. 0 ) ip1 = ip1 + imn + if (i1 + 1 .gt. imn) ip1 = ip1 - imn + + XLAND = XLAND + FLOAT(ZSLM(I1,J1)) + XNSUM = XNSUM + 1. + + hi0 = float(zavg(i0,j1)) + hip1 = float(zavg(ip1,j1)) + + if(hi0 .lt. -990.) hi0 = 0.0 + if(hip1 .lt. -990.) hip1 = 0.0 +!........ xfp = xfp + 0.5 * ( hip1 - hi0 ) / DELTAX(J1) + xfp = 0.5 * ( hip1 - hi0 ) / DELTAX(J1) + xfp2 = xfp2 + 0.25 * ( ( hip1 - hi0 )/DELTAX(J1) )** 2 + +! --- not at boundaries +!RAB if ( J1 .ne. JST(1) .and. J1 .ne. JEN(JM) ) then + if ( J1 .ne. 1 .and. J1 .ne. JMN ) then + hj0 = float(zavg(i1,j1-1)) + hjp1 = float(zavg(i1,j1+1)) + if(hj0 .lt. -990.) hj0 = 0.0 + if(hjp1 .lt. -990.) hjp1 = 0.0 +!....... yfp = yfp + 0.5 * ( hjp1 - hj0 ) / DELTAY + yfp = 0.5 * ( hjp1 - hj0 ) / DELTAY + yfp2 = yfp2 + 0.25 * ( ( hjp1 - hj0 )/DELTAY )**2 +! +!..............elseif ( J1 .eq. JST(J) .or. J1 .eq. JEN(JM) ) then +! === the NH pole: NB J1 goes from High at NP to Low toward SP +! +!RAB elseif ( J1 .eq. JST(1) ) then + elseif ( J1 .eq. 1 ) then + ijax = i1 + imn/2 + if (ijax .le. 0 ) ijax = ijax + imn + if (ijax .gt. imn) ijax = ijax - imn +!..... at N pole we stay at the same latitude j1 but cross to opp side + hijax = float(zavg(ijax,j1)) + hi1j1 = float(zavg(i1,j1)) + if(hijax .lt. -990.) hijax = 0.0 + if(hi1j1 .lt. -990.) hi1j1 = 0.0 +!....... yfp = yfp + 0.5 * ( ( 0.5 * ( hijax + hi1j1) ) - hi1j1 )/DELTAY + yfp = 0.5 * ( ( 0.5 * ( hijax - hi1j1 ) ) )/DELTAY + yfp2 = yfp2 + 0.25 * ( ( 0.5 * ( hijax - hi1j1) ) / DELTAY )**2 +! +! === the SH pole: NB J1 goes from High at NP to Low toward SP +! + elseif ( J1 .eq. JMN ) then + ijax = i1 + imn/2 + if (ijax .le. 0 ) ijax = ijax + imn + if (ijax .gt. imn) ijax = ijax - imn + hijax = float(zavg(ijax,j1)) + hi1j1 = float(zavg(i1,j1)) + if(hijax .lt. -990.) hijax = 0.0 + if(hi1j1 .lt. -990.) hi1j1 = 0.0 +!..... yfp = yfp + 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY + yfp = 0.5 * (0.5 * ( hijax - hi1j1) )/DELTAY + yfp2 = yfp2 + 0.25 * ( (0.5 * (hijax - hi1j1) ) / DELTAY )**2 + endif +! +! === The above does an average across the pole for the bndry in j. +! + xfpyfp = xfpyfp + xfp * yfp + ENDIF INSIDE +! +! === average the HX2, HY2 and HXY +! === This will be done over all land +! + ENDDO + ENDDO +! +! === HTENSR +! + XNSUM_GT_1 : IF(XNSUM.GT.1.) THEN + IF(SLM(I,J).NE.0.) THEN + IF (XLAND > 0) THEN + HX2(I,J) = xfp2 / XLAND + HY2(I,J) = yfp2 / XLAND + HXY(I,J) = xfpyfp / XLAND + ELSE + HX2(I,J) = xfp2 / XNSUM + HY2(I,J) = yfp2 / XNSUM + HXY(I,J) = xfpyfp / XNSUM + ENDIF + ENDIF +!=== degub testing + if (debug) then + print *," I,J,i1,j1:", I,J,i1,j1,XLAND,SLM(i,j) + print *," xfpyfp,xfp2,yfp2:",xfpyfp,xfp2,yfp2 + print *," HX2,HY2,HXY:",HX2(I,J),HY2(I,J),HXY(I,J) + ENDIF +! +! === make the principal axes, theta, and the degree of anisotropy, +! === and sigma2, the slope parameter +! + HK(I,J) = 0.5 * ( HX2(I,J) + HY2(I,J) ) + HL(I,J) = 0.5 * ( HX2(I,J) - HY2(I,J) ) + HLPRIM(I,J) = SQRT(HL(I,J)*HL(I,J) + HXY(I,J)*HXY(I,J)) + IF( HL(I,J).NE. 0. .AND. SLM(I,J) .NE. 0. ) THEN + + THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) / D2R +! === for testing print out in degrees +! THETA(I,J) = 0.5 * ATAN2(HXY(I,J),HL(I,J)) + ENDIF + SIGMA2(I,J) = ( HK(I,J) + HLPRIM(I,J) ) + if ( SIGMA2(I,J) .GE. 0. ) then + SIGMA(I,J) = SQRT(SIGMA2(I,J) ) + if (sigma2(i,j) .ne. 0. .and. & + HK(I,J) .GE. HLPRIM(I,J) ) & + GAMMA(I,J) = sqrt( (HK(I,J) - HLPRIM(I,J)) / SIGMA2(I,J) ) + else + SIGMA(I,J)=0. + endif + ENDIF XNSUM_GT_1 + if (debug) then + print *," I,J,THETA,SIGMA,GAMMA,",I,J,THETA(I,J),SIGMA(I,J),GAMMA(I,J) + print *," HK,HL,HLPRIM:",HK(I,J),HL(I,J),HLPRIM(I,J) + endif + ENDDO ILOOP + ENDDO JLOOP +!$omp end parallel do + + RETURN + END SUBROUTINE MAKEPC2 + +!> Create orographic asymmetry and orographic length scale on +!! the model grid. This routine is used for the cubed-sphere +!! grid. +!! +!! @param[in] zavg High-resolution orography data. +!! @param[in] zslm High-resolution land-mask data. +!! @param[in] var Standard deviation of orography on the model grid. +!! @param[out] oa4 Orographic asymmetry on the model grid. Four +!! directional components - W/S/SW/NW +!! @param[out] ol Orographic length scale on the model grid. Four +!! directional components - W/S/SW/NW +!! @param[out] elvmax Maximum elevation within a model grid box. +!! @param[in] oro Orography on the model grid. +!! @param[in] im "i" dimension of the model grid tile. +!! @param[in] jm "j" dimension of the model grid tile. +!! @param[in] imn "i" dimension of the high-resolution orography and +!! mask data. +!! @param[in] jmn "j" dimension of the high-resolution orography and +!! mask data. +!! @param[in] lon_c Corner point longitudes of the model grid points. +!! @param[in] lat_c Corner point latitudes of the model grid points. +!! @param[in] lon_t Center point longitudes of the model grid points. +!! @param[in] lat_t Center point latitudes of the model grid points. +!! @param[in] dx Length of model grid points in the 'x' direction. +!! @param[in] dy Length of model grid points in the 'y' direction. +!! @param[in] is_south_pole Is the model point at the south pole? +!! @param[in] is_north_pole is the model point at the north pole? +!! @author GFDL Programmer + SUBROUTINE MAKEOA2(ZAVG,zslm,VAR,OA4,OL,ELVMAX,ORO,& + IM,JM,IMN,JMN,lon_c,lat_c,lon_t,lat_t,dx,dy, & + is_south_pole,is_north_pole ) + + use orog_utils, only : get_lat_angle, get_lon_angle, & + get_index, inside_a_polygon, & + get_xnsum, get_xnsum2, & + get_xnsum3 + + implicit none + + integer, intent(in) :: im,jm,imn,jmn + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + + logical, intent(in) :: is_south_pole(im,jm), is_north_pole(im,jm) + + real, intent(in) :: dx(im,jm), dy(im,jm) + real, intent(in) :: lon_c(im+1,jm+1), lat_c(im+1,jm+1) + real, intent(in) :: lon_t(im,jm), lat_t(im,jm) + real, intent(in) :: oro(im,jm), var(im,jm) + + real, intent(out) :: ol(im,jm,4),oa4(im,jm,4) + real, intent(out) :: elvmax(im,jm) + + real, parameter :: MISSING_VALUE = -9999. + real, parameter :: D2R = 3.14159265358979/180. + + integer :: i,j,ilist(imn),numx,i1,j1,ii1 + integer :: jst, jen, kwd + + real :: glat(jmn) + real :: zmax(im,jm) + real :: lono(4),lato(4),loni,lati + real :: lono_rad(4), lato_rad(4) + real :: delxn,hc,height,xnpu,xnpd,t + real :: lon,lat,dlon,dlat,dlat_old + real :: lon1,lat1,lon2,lat2 + real :: xnsum11,xnsum12,xnsum21,xnsum22 + real :: hc_11, hc_12, hc_21, hc_22 + real :: xnsum1_11,xnsum1_12,xnsum1_21,xnsum1_22 + real :: xnsum2_11,xnsum2_12,xnsum2_21,xnsum2_22 + + print*,"- CREATE ASYMETRY AND LENGTH SCALE." +! +!---- GLOBAL XLAT AND XLON ( DEGREE ) +! + DELXN = 360./IMN ! MOUNTAIN DATA RESOLUTION + + DO J=1,JMN + GLAT(J) = -90. + (J-1) * DELXN + DELXN * 0.5 + ENDDO + print*,'- IM=',IM,' JM=',JM,' IMN=',IMN,' JMN=',JMN +! +!---- FIND THE AVERAGE OF THE MODES IN A GRID BOX +! + DO J=1,JM + DO I=1,IM + ELVMAX(I,J) = ORO(I,J) + ZMAX(I,J) = 0.0 +!---- COUNT NUMBER OF MODE. HIGHER THAN THE HC, CRITICAL HEIGHT +! IN A GRID BOX + ELVMAX(I,J) = ZMAX(I,J) + ENDDO + ENDDO + +! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. +! --- to JM or to JM1 +!$omp parallel do & +!$omp private (j,i,hc,lono,lato,jst,jen,ilist,numx,j1,ii1,i1,loni, & +!$omp lati,height,lono_rad,lato_rad) + DO J=1,JM + DO I=1,IM + HC = 1116.2 - 0.878 * VAR(I,J) + LONO(1) = lon_c(i,j) + LONO(2) = lon_c(i+1,j) + LONO(3) = lon_c(i+1,j+1) + LONO(4) = lon_c(i,j+1) + LATO(1) = lat_c(i,j) + LATO(2) = lat_c(i+1,j) + LATO(3) = lat_c(i+1,j+1) + LATO(4) = lat_c(i,j+1) + LONO_RAD = LONO * D2R + LATO_RAD = LATO * D2R + call get_index(IMN,JMN,4,LONO,LATO,DELXN,jst,jen,ilist,numx) + do j1 = jst, jen; do ii1 = 1, numx + i1 = ilist(ii1) + LONI = i1*DELXN + LATI = -90 + j1*DELXN + if(inside_a_polygon(LONI*D2R,LATI*D2R,4, & + LONO_RAD,LATO_RAD))then + + HEIGHT = FLOAT(ZAVG(I1,J1)) + IF(HEIGHT.LT.-990.) HEIGHT = 0.0 + IF ( HEIGHT .gt. ORO(I,J) ) then + if ( HEIGHT .gt. ZMAX(I,J) )ZMAX(I,J) = HEIGHT + ENDIF + endif + ENDDO ; ENDDO + ENDDO + ENDDO +!$omp end parallel do + + DO J=1,JM + DO I=1,IM + ELVMAX(I,J) = ZMAX(I,J) + ENDDO + ENDDO + + DO KWD = 1, 4 + DO J=1,JM + DO I=1,IM + OA4(I,J,KWD) = 0.0 + OL(I,J,KWD) = 0.0 + ENDDO + ENDDO + ENDDO + ! +! --- # of peaks > ZAVG value and ZMAX(IM,JM) -- ORO is already avg. +! +!---- CALCULATE THE 3D OROGRAPHIC ASYMMETRY FOR 4 WIND DIRECTIONS +!---- AND THE 3D OROGRAPHIC SUBGRID OROGRAPHY FRACTION +! (KWD = 1 2 3 4) +! ( WD = W S SW NW) + +!$omp parallel do & +!$omp private (j,i,lon,lat,kwd,dlon,dlat,lon1,lon2,lat1,lat2, & +!$omp xnsum11,xnsum12,xnsum21,xnsum22,xnpu,xnpd, & +!$omp xnsum1_11,xnsum2_11,hc_11, xnsum1_12,xnsum2_12, & +!$omp hc_12,xnsum1_21,xnsum2_21,hc_21, xnsum1_22, & +!$omp xnsum2_22,hc_22) + DO J=1,JM + DO I=1,IM + lon = lon_t(i,j) + lat = lat_t(i,j) + !--- for around north pole, oa and ol are all 0 + + if(is_north_pole(i,j)) then + print*, "- SET OA1 = 0 AND OL=0 AT I,J=", i,j + do kwd = 1, 4 + oa4(i,j,kwd) = 0. + ol(i,j,kwd) = 0. + enddo + else if(is_south_pole(i,j)) then + print*, "- SET OA1 = 0 AND OL=1 AT I,J=", i,j + do kwd = 1, 4 + oa4(i,j,kwd) = 0. + ol(i,j,kwd) = 1. + enddo + else + + !--- for each point, find a lat-lon grid box with same dx and dy as the cubic grid box + dlon = get_lon_angle(dx(i,j), lat ) + dlat = get_lat_angle(dy(i,j)) + !--- adjust dlat if the points are close to pole. + if( lat-dlat*0.5<-90.) then + print*, "- AT I,J =", i,j, lat, dlat, lat-dlat*0.5 + print*, "FATAL ERROR: lat-dlat*0.5<-90." + call ERREXIT(4) + endif + if( lat+dlat*2 > 90.) then + dlat_old = dlat + dlat = (90-lat)*0.5 + print*, "- AT I,J=",i,j," ADJUST DLAT FROM ", & + dlat_old, " TO ", dlat + endif + !--- lower left + lon1 = lon-dlon*1.5 + lon2 = lon-dlon*0.5 + lat1 = lat-dlat*0.5 + lat2 = lat+dlat*0.5 + + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + xnsum11 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) + + !--- upper left + lon1 = lon-dlon*1.5 + lon2 = lon-dlon*0.5 + lat1 = lat+dlat*0.5 + lat2 = lat+dlat*1.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + xnsum12 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) + + !--- lower right + lon1 = lon-dlon*0.5 + lon2 = lon+dlon*0.5 + lat1 = lat-dlat*0.5 + lat2 = lat+dlat*0.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + xnsum21 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) + + !--- upper right + lon1 = lon-dlon*0.5 + lon2 = lon+dlon*0.5 + lat1 = lat+dlat*0.5 + lat2 = lat+dlat*1.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + + xnsum22 = get_xnsum(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,zslm,delxn) + + XNPU = xnsum11 + xnsum12 + XNPD = xnsum21 + xnsum22 + IF (XNPD .NE. XNPU) OA4(I,J,1) = 1. - XNPD / MAX(XNPU , 1.) + + XNPU = xnsum11 + xnsum21 + XNPD = xnsum12 + xnsum22 + IF (XNPD .NE. XNPU) OA4(I,J,2) = 1. - XNPD / MAX(XNPU , 1.) + + XNPU = xnsum11 + (xnsum12+xnsum21)*0.5 + XNPD = xnsum22 + (xnsum12+xnsum21)*0.5 + IF (XNPD .NE. XNPU) OA4(I,J,3) = 1. - XNPD / MAX(XNPU , 1.) + + XNPU = xnsum12 + (xnsum11+xnsum22)*0.5 + XNPD = xnsum21 + (xnsum11+xnsum22)*0.5 + IF (XNPD .NE. XNPU) OA4(I,J,4) = 1. - XNPD / MAX(XNPU , 1.) + + + !--- calculate OL3 and OL4 + !--- lower left + lon1 = lon-dlon*1.5 + lon2 = lon-dlon*0.5 + lat1 = lat-dlat*0.5 + lat2 = lat+dlat*0.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_11, xnsum2_11, HC_11) + + !--- upper left + lon1 = lon-dlon*1.5 + lon2 = lon-dlon*0.5 + lat1 = lat+dlat*0.5 + lat2 = lat+dlat*1.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_12, xnsum2_12, HC_12) + + !--- lower right + lon1 = lon-dlon*0.5 + lon2 = lon+dlon*0.5 + lat1 = lat-dlat*0.5 + lat2 = lat+dlat*0.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_21, xnsum2_21, HC_21) + + !--- upper right + lon1 = lon-dlon*0.5 + lon2 = lon+dlon*0.5 + lat1 = lat+dlat*0.5 + lat2 = lat+dlat*1.5 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum2(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_22, xnsum2_22, HC_22) + + OL(i,j,3) = (XNSUM1_22+XNSUM1_11)/(XNSUM2_22+XNSUM2_11) + OL(i,j,4) = (XNSUM1_12+XNSUM1_21)/(XNSUM2_12+XNSUM2_21) + + !--- calculate OL1 and OL2 + !--- lower left + lon1 = lon-dlon*2.0 + lon2 = lon-dlon + lat1 = lat + lat2 = lat+dlat + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_11, xnsum2_11, HC_11) + + !--- upper left + lon1 = lon-dlon*2.0 + lon2 = lon-dlon + lat1 = lat+dlat + lat2 = lat+dlat*2.0 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER LEFT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_12, xnsum2_12, HC_12) + + !--- lower right + lon1 = lon-dlon + lon2 = lon + lat1 = lat + lat2 = lat+dlat + if(lat1<-90 .or. lat2>90) then + print*, "- AT UPPER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_21, xnsum2_21, HC_21) + + !--- upper right + lon1 = lon-dlon + lon2 = lon + lat1 = lat+dlat + lat2 = lat+dlat*2.0 + if(lat1<-90 .or. lat2>90) then + print*, "- AT LOWER RIGHT I=,J=", i, j, lat, dlat,lat1,lat2 + endif + + call get_xnsum3(lon1,lat1,lon2,lat2,IMN,JMN,GLAt, & + zavg,delxn, xnsum1_22, xnsum2_22, HC_22) + + OL(i,j,1) = (XNSUM1_11+XNSUM1_21)/(XNSUM2_11+XNSUM2_21) + OL(i,j,2) = (XNSUM1_21+XNSUM1_22)/(XNSUM2_21+XNSUM2_22) + ENDIF + ENDDO + ENDDO +!$omp end parallel do + DO KWD=1,4 + DO J=1,JM + DO I=1,IM + T = OA4(I,J,KWD) + OA4(I,J,KWD) = SIGN( MIN( ABS(T), 1. ), T ) + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE MAKEOA2 diff --git a/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 new file mode 100644 index 000000000..cae1f2bec --- /dev/null +++ b/sorc/orog_mask_tools.fd/orog.fd/orog_utils.F90 @@ -0,0 +1,1104 @@ +!> @file +!! @brief Utilities for orog code. +!! @author George Gayno NOAA/EMC + +!> Module containing utilites used by the orog program. +!! +!! @author George Gayno NOAA/EMC + module orog_utils + + implicit none + + private + + real, parameter :: earth_radius = 6371200. !< earth radius in meters. + real, parameter :: pi=3.1415926535897931 !< pi. + real, parameter :: rad2deg = 180./3.14159265358979 !< radians per degrees. + real, parameter :: deg2rad = 3.14159265358979/180. !< degrees per radians. + + public :: find_nearest_pole_points + public :: find_poles + public :: get_index + public :: get_lat_angle + public :: get_lon_angle + public :: get_xnsum + public :: get_xnsum2 + public :: get_xnsum3 + public :: inside_a_polygon + public :: latlon2xyz + public :: minmax + public :: remove_isolated_pts + public :: timef + public :: transpose_orog + public :: transpose_mask + + contains + +!> Print out the maximum and minimum values of +!! an array and optionally pass back the i/j +!! location of the maximum. +!! +!! @param[in] im The 'i' dimension of the array. +!! @param[in] jm The 'j' dimension of the array. +!! @param[in] a The array to check. +!! @param[in] title Name of the data to be checked. +!! @param[out] imax The 'i' location of the maximum. +!! @param[out] jmax The 'j' location of the maximum. +!! +!! @author Jordan Alpert NOAA/EMC + subroutine minmax(im,jm,a,title,imax,jmax) + + implicit none + + character(len=8), intent(in) :: title + + integer, intent(in) :: im, jm + integer, intent(out), optional :: imax, jmax + + real, intent(in) :: a(im,jm) + + integer :: i, j + + real :: rmin,rmax + + rmin=huge(a) + rmax=-rmin + + if (present(imax) .and. present(jmax)) then + imax=0 + jmax=0 + endif + + do j=1,jm + do i=1,im + if(a(i,j) >= rmax) then + rmax=a(i,j) + if (present(imax) .and. present(jmax)) then + imax = i + jmax = j + endif + endif + if(a(i,j) <= rmin)rmin=a(i,j) + enddo + enddo + + write(6,150) title,rmin,rmax +150 format(' - ',a8,' MIN=',e13.4,2x,'MAX=',e13.4) + + end subroutine minmax + +!> Convert from latitude and longitude to x,y,z coordinates. +!! +!! @param[in] siz Number of points to convert. +!! @param[in] lon Longitude (radians) of points to convert. +!! @param[in] lat Latitude (radians) of points to convert. +!! @param[out] x 'x' Coordinate of the converted points. +!! @param[out] y 'y' Coordinate of the converted points. +!! @param[out] z 'z' Coordinate of the converted points. +!! +!! @author GFDL programmer + subroutine latlon2xyz(siz,lon, lat, x, y, z) + + implicit none + + integer, intent(in) :: siz + real, intent(in) :: lon(siz), lat(siz) + real, intent(out) :: x(siz), y(siz), z(siz) + + integer :: n + + do n = 1, siz + x(n) = cos(lat(n))*cos(lon(n)) + y(n) = cos(lat(n))*sin(lon(n)) + z(n) = sin(lat(n)) + enddo + + end subroutine latlon2xyz + +!> Convert the 'y' direction distance of a cubed-sphere grid +!! point to the corresponding distance in latitude. +!! +!! @param[in] dy Distance along the 'y' direction of a cubed-sphere +!! point in meters. +!! @return get_lat_angle Corresponding latitudinal distance in degrees. +!! +!! @author GFDL programmer + + function get_lat_angle(dy) + + implicit none + + real, intent(in) :: dy + + real :: get_lat_angle + + get_lat_angle = dy/earth_radius*rad2deg + + end function get_lat_angle + +!> Convert the 'x' direction distance of a cubed-sphere grid +!! point to the corresponding distance in longitude. +!! +!! @param[in] dx Distance along the 'x' direction of a +!! cubed-sphere grid point in meters. +!! @param[in] lat_in Latitude of the cubed-sphere point in +!! degrees. +!! @return get_lon_angle Corresponding distance in longitude +!! in degrees. +!! +!! @author GFDL programmer + + function get_lon_angle(dx,lat_in) + + implicit none + + real, intent(in) :: dx, lat_in + + real :: get_lon_angle, lat + + lat = lat_in + if (lat > 89.5) lat = 89.5 + if (lat < -89.5) lat = -89.5 + + get_lon_angle = 2*asin( sin(dx/earth_radius*0.5)/cos(lat*deg2rad) )*rad2deg + + end function get_lon_angle + +!> Transpose the global landmask by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of landmask data. +!! @param[in] jmn j-dimension of landmask data. +!! @param[inout] mask The global landmask data. +!! @author G. Gayno + + subroutine transpose_mask(imn, jmn, mask) + + implicit none + + integer, intent(in) :: imn, jmn + integer(1), intent(inout) :: mask(imn,jmn) + + integer :: i, j, it, jt + integer(1) :: isave + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + isave = mask(I,j) + mask(I,j)=mask(I,jt) + mask(I,jt) = isave + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + isave = mask(i,J) + mask(i,J)=mask(it,J) + mask(it,J) = isave + enddo + enddo + + end subroutine transpose_mask + +!> Transpose the global orography data by flipping +!! the poles and moving the starting longitude to +!! Greenwich. +!! +!! @param[in] imn i-dimension of orography data. +!! @param[in] jmn j-dimension of orography data. +!! @param[inout] glob The global orography data. +!! @author G. Gayno + + subroutine transpose_orog(imn, jmn, glob) + + implicit none + + integer, intent(in) :: imn, jmn + integer(2), intent(inout) :: glob(imn,jmn) + + integer :: i, j, it, jt + integer(2) :: i2save + +! Transpose from S to N to the NCEP standard N to S. + + do j=1,jmn/2 + do I=1,imn + jt=jmn - j + 1 + i2save = glob(I,j) + glob(I,j)=glob(I,jt) + glob(I,jt) = i2save + enddo + enddo + +! Data begins at dateline. NCEP standard is Greenwich. + + do j=1,jmn + do I=1,imn/2 + it=imn/2 + i + i2save = glob(i,J) + glob(i,J)=glob(it,J) + glob(it,J) = i2save + enddo + enddo + + end subroutine transpose_orog + +!> Compute spherical angle. +!! +!! @param[in] v1 Vector 1. +!! @param[in] v2 Vector 2. +!! @param[in] v3 Vector 3. +!! @return spherical_angle Spherical Angle. +!! @author GFDL programmer + + function spherical_angle(v1, v2, v3) + + implicit none + + real :: spherical_angle + + real, parameter :: EPSLN30 = 1.e-30 + + real, intent(in) :: v1(3), v2(3), v3(3) + + real :: px, py, pz, qx, qy, qz, ddd + +! vector product between v1 and v2 + + px = v1(2)*v2(3) - v1(3)*v2(2) + py = v1(3)*v2(1) - v1(1)*v2(3) + pz = v1(1)*v2(2) - v1(2)*v2(1) + +! vector product between v1 and v3 + + qx = v1(2)*v3(3) - v1(3)*v3(2); + qy = v1(3)*v3(1) - v1(1)*v3(3); + qz = v1(1)*v3(2) - v1(2)*v3(1); + + ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); + if ( ddd <= 0.0 ) then + spherical_angle = 0. + else + ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd); + if( abs(ddd-1) < EPSLN30 ) ddd = 1; + if( abs(ddd+1) < EPSLN30 ) ddd = -1; + if ( ddd>1. .or. ddd<-1. ) then + !FIX to correctly handle co-linear points (angle near pi or 0) */ + if (ddd < 0.) then + spherical_angle = PI + else + spherical_angle = 0. + endif + else + spherical_angle = acos( ddd ) + endif + endif + + end function spherical_angle + +!> Check if a point is inside a polygon. +!! +!! @param[in] lon1 Longitude of the point to check. +!! @param[in] lat1 Latitude of the point to check. +!! @param[in] npts Number of polygon vertices. +!! @param[in] lon2 Longitude of the polygon vertices. +!! @param[in] lat2 Latitude of the polygon vertices. +!! @return inside_a_polygon When true, point is within +!! the polygon. +!! @author GFDL programmer + + function inside_a_polygon(lon1, lat1, npts, lon2, lat2) + + implicit none + + logical inside_a_polygon + + real, parameter :: EPSLN10 = 1.e-10 + real, parameter :: EPSLN8 = 1.e-8 + real, parameter :: RANGE_CHECK_CRITERIA=0.05 + + integer, intent(in) :: npts + + real, intent(in) :: lon1, lat1 + real, intent(in) :: lon2(npts), lat2(npts) + + integer :: i, ip1 + + real :: anglesum, angle + real :: x2(npts), y2(npts), z2(npts) + real :: lon1_1d(1), lat1_1d(1) + real :: x1(1), y1(1), z1(1) + real :: pnt0(3),pnt1(3),pnt2(3) + real :: max_x2,min_x2,max_y2,min_y2,max_z2,min_z2 + +! first convert to cartesian grid. + + call latlon2xyz(npts,lon2, lat2, x2, y2, z2); + lon1_1d(1) = lon1 + lat1_1d(1) = lat1 + call latlon2xyz(1,lon1_1d, lat1_1d, x1, y1, z1); + inside_a_polygon = .false. + max_x2 = maxval(x2) + if( x1(1) > max_x2+RANGE_CHECK_CRITERIA ) return + min_x2 = minval(x2) + if( x1(1)+RANGE_CHECK_CRITERIA < min_x2 ) return + max_y2 = maxval(y2) + if( y1(1) > max_y2+RANGE_CHECK_CRITERIA ) return + min_y2 = minval(y2) + if( y1(1)+RANGE_CHECK_CRITERIA < min_y2 ) return + max_z2 = maxval(z2) + if( z1(1) > max_z2+RANGE_CHECK_CRITERIA ) return + min_z2 = minval(z2) + if( z1(1)+RANGE_CHECK_CRITERIA < min_z2 ) return + + pnt0(1) = x1(1) + pnt0(2) = y1(1) + pnt0(3) = z1(1) + + anglesum = 0 + + do i = 1, npts + if(abs(x1(1)-x2(i)) < EPSLN10 .and. & + abs(y1(1)-y2(i)) < EPSLN10 .and. & + abs(z1(1)-z2(i)) < EPSLN10 ) then ! same as the corner point + inside_a_polygon = .true. + return + endif + ip1 = i+1 + if(ip1>npts) ip1 = 1 + pnt1(1) = x2(i) + pnt1(2) = y2(i) + pnt1(3) = z2(i) + pnt2(1) = x2(ip1) + pnt2(2) = y2(ip1) + pnt2(3) = z2(ip1) + angle = spherical_angle(pnt0, pnt2, pnt1); + anglesum = anglesum + angle + enddo + + if(abs(anglesum-2*PI) < EPSLN8) then + inside_a_polygon = .true. + else + inside_a_polygon = .false. + endif + + end function inside_a_polygon + +!> Find the point on the model grid tile closest to the +!! north and south pole. +!! +!! @param[in] geolat Latitude on the supergrid. +!! @param[in] nx i-dimension of the supergrid. +!! @param[in] ny j-dimension of the supergrid. +!! @param[out] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[out] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[out] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @author GFDL Programmer + subroutine find_poles(geolat, nx, ny, i_north_pole, j_north_pole, & + i_south_pole, j_south_pole) + + implicit none + + integer, intent(in) :: nx, ny + + real, intent(in) :: geolat(nx+1,ny+1) + + integer, intent(out) :: i_north_pole, j_north_pole + integer, intent(out) :: i_south_pole, j_south_pole + + integer :: i, j + + real :: maxlat, minlat + + print*,'- CHECK IF THE TILE CONTAINS A POLE.' + +!--- figure out pole location. + + maxlat = -90 + minlat = 90 + i_north_pole = 0 + j_north_pole = 0 + i_south_pole = 0 + j_south_pole = 0 + do j = 1, ny+1; do i = 1, nx+1 + if( geolat(i,j) > maxlat ) then + i_north_pole=i + j_north_pole=j + maxlat = geolat(i,j) + endif + if( geolat(i,j) < minlat ) then + i_south_pole=i + j_south_pole=j + minlat = geolat(i,j) + endif + enddo ; enddo + +!--- only when maxlat is close to 90. the point is north pole + + if(maxlat < 89.9 ) then + i_north_pole = 0 + j_north_pole = 0 + endif + if(minlat > -89.9 ) then + i_south_pole = 0 + j_south_pole = 0 + endif + + print*, "- MINLAT=", minlat, "MAXLAT=", maxlat + print*, "- NORTH POLE SUPERGRID INDEX IS ", & + i_north_pole, j_north_pole + print*, "- SOUTH POLE SUPERGRID INDEX IS ", & + i_south_pole, j_south_pole + + end subroutine find_poles + +!> Find the point on the model grid tile closest to the +!! north and south pole. +!! +!! @param[in] i_north_pole 'i' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] j_north_pole 'j' index of north pole. '0' if +!! pole is outside of grid. +!! @param[in] i_south_pole 'i' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] j_south_pole 'j' index of south pole. '0' if +!! pole is outside of grid. +!! @param[in] im i-dimension of model tile +!! @param[in] jm j-dimension of model tile +!! @param[out] is_north_pole 'true' for points surrounding the north pole. +!! @param[out] is_south_pole 'true' for points surrounding the south pole. +!! @author GFDL Programmer + + subroutine find_nearest_pole_points(i_north_pole, j_north_pole, & + i_south_pole, j_south_pole, im, jm, is_north_pole, & + is_south_pole) + + implicit none + + integer, intent(in) :: im, jm + integer, intent(in) :: i_north_pole, j_north_pole + integer, intent(in) :: i_south_pole, j_south_pole + + logical, intent(out) :: is_north_pole(im,jm) + logical, intent(out) :: is_south_pole(im,jm) + + integer :: i, j + + print*,'- FIND NEAREST POLE POINTS.' + + is_north_pole=.false. + is_south_pole=.false. + + if(i_south_pole >0 .and. j_south_pole > 0) then + if(mod(i_south_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_south_pole/2 .and. (j==j_south_pole/2 & + .or. j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_south_pole/2 .or. i==i_south_pole/2+1) & + .and. (j==j_south_pole/2 .or. & + j==j_south_pole/2+1) ) then + is_south_pole(i,j) = .true. + print*, "- SOUTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + if(i_north_pole >0 .and. j_north_pole > 0) then + if(mod(i_north_pole,2)==0) then ! stretched grid + do j = 1, JM; do i = 1, IM + if(i==i_north_pole/2 .and. (j==j_north_pole/2 .or. & + j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + else + do j = 1, JM; do i = 1, IM + if((i==i_north_pole/2 .or. i==i_north_pole/2+1) & + .and. (j==j_north_pole/2 .or. & + j==j_north_pole/2+1) ) then + is_north_pole(i,j) = .true. + print*, "- NORTH POLE AT I,J= ", i, j + endif + enddo; enddo + endif + endif + + end subroutine find_nearest_pole_points + +!> Remove isolated model points. +!! +!! @param[in] im 'i' dimension of a model grid tile. +!! @param[in] jm 'j' dimension of a model grid tile. +!! @param[inout] slm Land-mask on the model tile. +!! @param[inout] oro Orography on the model tile. +!! @param[inout] var Standard deviation of orography on the model tile. +!! @param[inout] var4 Convexity on the model tile. +!! @param[inout] oa Orographic asymmetry on the model tile. +!! @param[inout] ol Orographic length scale on the model tile. +!! @author Jordan Alpert NOAA/EMC + + subroutine remove_isolated_pts(im,jm,slm,oro,var,var4,oa,ol) + + implicit none + + integer, intent(in) :: im, jm + + real, intent(inout) :: slm(im,jm) + real, intent(inout) :: oro(im,jm) + real, intent(inout) :: var(im,jm) + real, intent(inout) :: var4(im,jm) + real, intent(inout) :: oa(im,jm,4) + real, intent(inout) :: ol(im,jm,4) + + integer :: i, j, jn, js, k + integer :: iw, ie, wgta, is, ise + integer :: in, ine, inw, isw + + real :: slma, oroa, vara, var4a, xn, xs + real, allocatable :: oaa(:), ola(:) + +! REMOVE ISOLATED POINTS + + print*,"- REMOVE ISOLATED POINTS." + + allocate (oaa(4),ola(4)) + + iso_loop : DO J=2,JM-1 + JN=J-1 + JS=J+1 + i_loop : DO I=1,IM + IW=MOD(I+IM-2,IM)+1 + IE=MOD(I,IM)+1 + SLMA=SLM(IW,J)+SLM(IE,J) + OROA=ORO(IW,J)+ORO(IE,J) + VARA=VAR(IW,J)+VAR(IE,J) + VAR4A=VAR4(IW,J)+VAR4(IE,J) + DO K=1,4 + OAA(K)=OA(IW,J,K)+OA(IE,J,K) +! --- (*j*) fix typo: + OLA(K)=OL(IW,J,K)+OL(IE,J,K) + ENDDO + WGTA=2 + XN=(I-1)+1 + IF(ABS(XN-NINT(XN)).LT.1.E-2) THEN + IN=MOD(NINT(XN)-1,IM)+1 + INW=MOD(IN+IM-2,IM)+1 + INE=MOD(IN,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(IN,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(IN,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(IN,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(IN,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(IN,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(IN,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+3 + ELSE + INW=INT(XN) + INE=MOD(INW,IM)+1 + SLMA=SLMA+SLM(INW,JN)+SLM(INE,JN) + OROA=OROA+ORO(INW,JN)+ORO(INE,JN) + VARA=VARA+VAR(INW,JN)+VAR(INE,JN) + VAR4A=VAR4A+VAR4(INW,JN)+VAR4(INE,JN) + DO K=1,4 + OAA(K)=OAA(K)+OA(INW,JN,K)+OA(INE,JN,K) + OLA(K)=OLA(K)+OL(INW,JN,K)+OL(INE,JN,K) + ENDDO + WGTA=WGTA+2 + ENDIF + XS=(I-1)+1 + IF(ABS(XS-NINT(XS)).LT.1.E-2) THEN + IS=MOD(NINT(XS)-1,IM)+1 + ISW=MOD(IS+IM-2,IM)+1 + ISE=MOD(IS,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(IS,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(IS,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(IS,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(IS,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(IS,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(IS,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+3 + ELSE + ISW=INT(XS) + ISE=MOD(ISW,IM)+1 + SLMA=SLMA+SLM(ISW,JS)+SLM(ISE,JS) + OROA=OROA+ORO(ISW,JS)+ORO(ISE,JS) + VARA=VARA+VAR(ISW,JS)+VAR(ISE,JS) + VAR4A=VAR4A+VAR4(ISW,JS)+VAR4(ISE,JS) + DO K=1,4 + OAA(K)=OAA(K)+OA(ISW,JS,K)+OA(ISE,JS,K) + OLA(K)=OLA(K)+OL(ISW,JS,K)+OL(ISE,JS,K) + ENDDO + WGTA=WGTA+2 + ENDIF + OROA=OROA/WGTA + VARA=VARA/WGTA + VAR4A=VAR4A/WGTA + DO K=1,4 + OAA(K)=OAA(K)/WGTA + OLA(K)=OLA(K)/WGTA + ENDDO + IF(SLM(I,J).EQ.0..AND.SLMA.EQ.WGTA) THEN + PRINT '(" - SEA ",2F8.0," MODIFIED TO LAND",2F8.0, & + " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=1. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ELSEIF(SLM(I,J).EQ.1..AND.SLMA.EQ.0.) THEN + PRINT '(" - LAND",2F8.0," MODIFIED TO SEA ",2F8.0, & + " AT ",2I8)',ORO(I,J),VAR(I,J),OROA,VARA,I,J + SLM(I,J)=0. + ORO(I,J)=OROA + VAR(I,J)=VARA + VAR4(I,J)=VAR4A + DO K=1,4 + OA(I,J,K)=OAA(K) + OL(I,J,K)=OLA(K) + ENDDO + ENDIF + ENDDO i_loop + ENDDO iso_loop + + deallocate (oaa,ola) + + end subroutine remove_isolated_pts + +!> Determine the location of a cubed-sphere point within +!! the high-resolution orography data. The location is +!! described by the range of i/j indices on the high-res grid. +!! +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data set. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data set. +!! @param[in] npts Number of vertices to describe the cubed-sphere point. +!! @param[in] lonO The longitudes of the cubed-sphere vertices. +!! @param[in] latO The latitudes of the cubed-sphere vertices. +!! @param[in] delxn Resolution of the high-resolution orography +!! data set. +!! @param[out] jst Starting 'j' index on the high-resolution grid. +!! @param[out] jen Ending 'j' index on the high-resolution grid. +!! @param[out] ilist List of 'i' indices on the high-resolution grid. +!! @param[out] numx The number of 'i' indices on the high-resolution +!! grid. +!! @author GFDL programmer + subroutine get_index(imn,jmn,npts,lonO,latO,delxn, & + jst,jen,ilist,numx) + + implicit none + integer, intent(in) :: IMN,JMN + integer, intent(in) :: npts + real, intent(in) :: LONO(npts), LATO(npts) + real, intent(in) :: DELXN + integer, intent(out) :: jst,jen + integer, intent(out) :: ilist(IMN) + integer, intent(out) :: numx + + integer :: i2, ii, ist, ien + real :: minlat,maxlat,minlon,maxlon + + minlat = minval(LATO) + maxlat = maxval(LATO) + minlon = minval(LONO) + maxlon = maxval(LONO) + ist = minlon/DELXN+1 + ien = maxlon/DELXN+1 + jst = (minlat+90)/DELXN+1 + jen = (maxlat+90)/DELXN +!--- add a few points to both ends of j-direction + jst = jst - 5 + if(jst<1) jst = 1 + jen = jen + 5 + if(jen>JMN) jen = JMN + +!--- when around the pole, just search through all the points. + if((jst == 1 .OR. jen == JMN) .and. & + (ien-ist+1 > IMN/2) )then + numx = IMN + do i2 = 1, IMN + ilist(i2) = i2 + enddo + else if( ien-ist+1 > IMN/2 ) then ! cross longitude = 0 +!--- find the minimum that greater than IMN/2 +!--- and maximum that less than IMN/2 + ist = 0 + ien = IMN+1 + do i2 = 1, npts + ii = LONO(i2)/DELXN+1 + if(ii <0 .or. ii>IMN) then + print*,"- II=",ii,IMN,LONO(i2),DELXN + endif + if( ii < IMN/2 ) then + ist = max(ist,ii) + else if( ii > IMN/2 ) then + ien = min(ien,ii) + endif + enddo + if(ist<1 .OR. ist>IMN) then + print*, "FATAL ERROR: ist<1 .or. ist>IMN" + call ABORT() + endif + if(ien<1 .OR. ien>IMN) then + print*, "FATAL ERROR: iend<1 .or. iend>IMN" + call ABORT() + endif + + numx = IMN - ien + 1 + do i2 = 1, numx + ilist(i2) = ien + (i2-1) + enddo + do i2 = 1, ist + ilist(numx+i2) = i2 + enddo + numx = numx+ist + else + numx = ien-ist+1 + do i2 = 1, numx + ilist(i2) = ist + (i2-1) + enddo + endif + + end subroutine get_index + +!> Count the number of high-resolution orography points that +!! are higher than the model grid box average orography height. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] zslm The high-resolution land mask. +!! @param[in] delxn Resolution of the high-res orography data. +!! @return get_xnsum The number of high-res points above the +!! mean orography. +!! @author GFDL Programmer + + function get_xnsum(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,zslm,delxn) + + implicit none + + real :: get_xnsum + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn),zslm(imn,jmn) + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(in) :: glat(jmn) + + integer :: i, j, ist, ien, jst, jen, i1 + real :: oro, height + real :: xland,xwatr,xl1,xs1,slm,xnsum + +!-- Figure out ist,ien,jst,jen + + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + +!--- Compute average oro + + oro = 0.0 + xnsum = 0 + xland = 0 + xwatr = 0 + xl1 = 0 + xs1 = 0 + do j = jst,jen + do i1 = 1, ien - ist + 1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + xland = xland + float(zslm(i,j)) + xwatr = xwatr + float(1-zslm(i,j)) + xnsum = xnsum + 1. + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + xl1 = xl1 + height * float(zslm(i,j)) + xs1 = xs1 + height * float(1-zslm(i,j)) + enddo + enddo + + if( xnsum > 1.) then + slm = float(nint(xland/xnsum)) + if(slm.ne.0.) then + oro= xl1 / xland + else + oro = xs1 / xwatr + endif + endif + + get_xnsum = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. IMN) i = i - imn + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + if ( height .gt. oro ) get_xnsum = get_xnsum + 1 + enddo + enddo + + end function get_xnsum + +!> Count the number of high-resolution orography points that +!! are higher than a critical value inside a model grid box +!! (or a portion of a model grid box). The critical value is a +!! function of the standard deviation of orography. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] delxn Resolution of the high-res orography data. +!! @param[out] xnsum1 The number of high-resolution orography +!! above the critical value inside a model grid box. +!! @param[out] xnsum2 The number of high-resolution orography +!! points inside a model grid box. +!! @param[out] hc Critical height. +!! @author GFDL Programmer + + subroutine get_xnsum2(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,delxn,xnsum1,xnsum2,hc) + + implicit none + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn) + + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(in) :: glat(jmn) + real, intent(out) :: xnsum1,xnsum2,hc + + integer :: i, j, ist, ien, jst, jen, i1 + + real :: height, var + real :: xw1,xw2,xnsum + +!-- Figure out ist,ien,jst,jen + + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + +!--- Compute average oro + + xnsum = 0 + xw1 = 0 + xw2 = 0 + do j = jst,jen + do i1 = 1, ien - ist + 1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + xnsum = xnsum + 1. + height = float(zavg(i,j)) + if(height.lt.-990.) height = 0.0 + xw1 = xw1 + height + xw2 = xw2 + height ** 2 + enddo + enddo + + var = sqrt(max(xw2/xnsum-(xw1/xnsum)**2,0.)) + hc = 1116.2 - 0.878 * var + xnsum1 = 0 + xnsum2 = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + height = float(zavg(i,j)) + if ( height .gt. hc ) xnsum1 = xnsum1 + 1 + xnsum2 = xnsum2 + 1 + enddo + enddo + + end subroutine get_xnsum2 + +!> Count the number of high-resolution orography points that +!! are higher than a critical value inside a model grid box +!! (or a portion of a model grid box). Unlike routine +!! get_xnsum2(), this routine does not compute the critical +!! value. Rather, it is passed in. +!! +!! @param[in] lon1 Longitude of corner point 1 of the model +!! grid box. +!! @param[in] lat1 Latitude of corner point 1 of the model +!! grid box. +!! @param[in] lon2 Longitude of corner point 2 of the model +!! grid box. +!! @param[in] lat2 Latitude of corner point 2 of the model +!! grid box. +!! @param[in] imn 'i' dimension of the high-resolution orography +!! data. +!! @param[in] jmn 'j' dimension of the high-resolution orography +!! data. +!! @param[in] glat Latitude of each row of the high-resolution +!! orography data. +!! @param[in] zavg The high-resolution orography. +!! @param[in] delxn Resolution of the high-res orography data. +!! @param[out] xnsum1 The number of high-resolution orography +!! above the critical value inside a model grid box. +!! @param[out] xnsum2 The number of high-resolution orography +!! points inside a model grid box. +!! @param[in] hc Critical height. +!! @author GFDL Programmer + + subroutine get_xnsum3(lon1,lat1,lon2,lat2,imn,jmn, & + glat,zavg,delxn,xnsum1,xnsum2,HC) + implicit none + + integer, intent(in) :: imn,jmn + integer, intent(in) :: zavg(imn,jmn) + + real, intent(in) :: hc, glat(jmn) + real, intent(in) :: lon1,lat1,lon2,lat2,delxn + real, intent(out) :: xnsum1,xnsum2 + + integer :: i, j, ist, ien, jst, jen, i1 + + real :: height + +!-- Figure out ist,ien,jst,jen + +! if lat1 or lat 2 is 90 degree. set jst = JMN + + jst = jmn + jen = jmn + do j = 1, jmn + if( glat(j) .gt. lat1 ) then + jst = j + exit + endif + enddo + + do j = 1, jmn + if( glat(j) .gt. lat2 ) then + jen = j + exit + endif + enddo + + ist = lon1/delxn + 1 + ien = lon2/delxn + if(ist .le.0) ist = ist + imn + if(ien < ist) ien = ien + imn + + xnsum1 = 0 + xnsum2 = 0 + do j = jst, jen + do i1= 1, ien-ist+1 + i = ist + i1 -1 + if( i .le. 0) i = i + imn + if( i .gt. imn) i = i - imn + height = float(zavg(i,j)) + if ( height .gt. hc ) xnsum1 = xnsum1 + 1 + xnsum2 = xnsum2 + 1 + enddo + enddo + + end subroutine get_xnsum3 +!> Get the date/time from the system clock. +!! +!! @return timef +!! @author Mark Iredell + + real function timef() + + implicit none + + character(8) :: date + character(10) :: time + character(5) :: zone + integer,dimension(8) :: values + integer :: total + real :: elapsed + + call date_and_time(date,time,zone,values) + total=(3600*values(5)) + (60*values(6))+values(7) + elapsed=float(total) + (1.0e-3*float(values(8))) + timef=elapsed + + end function timef + + end module orog_utils diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 95b28c8fe..9a5850084 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -42,3 +42,4 @@ add_subdirectory(sfc_climo_gen) add_subdirectory(cpld_gridgen) add_subdirectory(emcsfc_snow2mdl) add_subdirectory(ocnice_prep) +add_subdirectory(orog) diff --git a/tests/orog/CMakeLists.txt b/tests/orog/CMakeLists.txt new file mode 100644 index 000000000..b1bd2179b --- /dev/null +++ b/tests/orog/CMakeLists.txt @@ -0,0 +1,23 @@ +# This is the cmake build file. +# +# George Gayno, Ed Hartnett + +if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8") +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffree-line-length-0 -fdefault-real-8") +endif() + +include_directories(${PROJECT_SOURCE_DIR}) + +add_executable(ftst_ll2xyz ftst_ll2xyz.F90) +add_test(NAME orog-ftst_ll2xyz COMMAND ftst_ll2xyz) +target_link_libraries(ftst_ll2xyz orog_lib) + +add_executable(ftst_minmax ftst_minmax.F90) +add_test(NAME orog-ftst_minmax COMMAND ftst_minmax) +target_link_libraries(ftst_minmax orog_lib) + +add_executable(ftst_get_ll_angle ftst_get_ll_angle.F90) +add_test(NAME orog-ftst_get_ll_angle COMMAND ftst_get_ll_angle) +target_link_libraries(ftst_get_ll_angle orog_lib) diff --git a/tests/orog/ftst_get_ll_angle.F90 b/tests/orog/ftst_get_ll_angle.F90 new file mode 100644 index 000000000..e1812f4d6 --- /dev/null +++ b/tests/orog/ftst_get_ll_angle.F90 @@ -0,0 +1,58 @@ + program get_ll_angle + +! Unit test for functions get_lat_angle and +! get_lon_angle. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : get_lat_angle, get_lon_angle + + implicit none + + real :: dlat, dlon, dy, lat + real, parameter :: EPSILON=0.001 + + print*,'Test get_lat_angle' + +! dy is the approximate distance in meters of one +! degree of latitude (or longitude at the equator). + + dy = 111139.0 + + dlat = get_lat_angle(dy) + +! Is dlat approximately one degree? + + if (abs(dlat - 1.0) > EPSILON) stop 2 + + print*,'Test get_lon_angle' + +! Test equator point. Should be about 1-degree. + + lat = 0.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 1.0) > EPSILON) stop 3 + +! Test point at 60S. Should be about 2-degrees. + + lat = -60.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 2.0) > EPSILON) stop 4 + +! Test both poles. To prevent a divide by zero, +! the function has special logic at the poles. +! The result is about 176 degrees. + + lat = -90.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 176.254) > EPSILON) stop 5 + + lat = 90.0 + dlon = get_lon_angle(dy,lat) + if (abs(dlon - 176.254) > EPSILON) stop 6 + + print*,"OK" + + print*,"SUCCESS" + + end program get_ll_angle diff --git a/tests/orog/ftst_ll2xyz.F90 b/tests/orog/ftst_ll2xyz.F90 new file mode 100644 index 000000000..37b9ea6b8 --- /dev/null +++ b/tests/orog/ftst_ll2xyz.F90 @@ -0,0 +1,87 @@ + program ll2xyz + +! Unit test for routine latlon2xyz, which converts +! lat/lon to x/y/z coordinates. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : latlon2xyz + + implicit none + + integer, parameter :: siz = 6 + + real, parameter :: d2r = 3.14159265358979/180. + real, parameter :: EPSILON=0.0001 + + integer :: j + + real :: lon(siz), lat(siz), x(siz), y(siz), z(siz) + real :: expected_x_component(siz) + real :: expected_y_component(siz) + real :: expected_z_component(siz) + +! These are the expected x/y/z components returned from +! latlon2xyz for our test points. + + data expected_x_component/1.0, 0.0, -1.0, & + 0.0, 0.0, 0.7071068/ + + data expected_y_component/0.0, 1.0, 0.0, & + -1.0, 0.0, 0.0/ + + data expected_z_component/0.0, 0.0, 0.0, & + 0.0, 1.0, -0.7071068/ + + print*,"Starting test of latlon2xyz." + +! Test point 1 - the equator/greenwich. + + lat(1) = 0.0 + lon(1) = 0.0 + +! Test point 2 - the equator/90E + + lat(2) = 0.0 + lon(2) = 90.0 + +! Test point 3 - the equator/dateline + + lat(3) = 0.0 + lon(3) = 180.0 + +! Test point 4 - the equator/90W + + lat(4) = 0.0 + lon(4) = 270.0 + +! Test point 5 - the north pole/greenwich + + lat(5) = 90.0 + lon(5) = 0.0 + +! Test point 6 - 45S/greenwich + + lat(6) = -45.0 + lon(6) = 0.0 + + lat = lat * d2r + lon = lon * d2r + +! Call the routine to unit test. + + call latlon2xyz(siz,lon,lat,x,y,z) + +! Check results. + + do j = 1, siz + if (abs(x(j) - expected_x_component(j)) > EPSILON) stop 2 + if (abs(y(j) - expected_y_component(j)) > EPSILON) stop 3 + if (abs(z(j) - expected_z_component(j)) > EPSILON) stop 4 + enddo + + print*,"OK" + + print*,"SUCCESS" + + end program ll2xyz diff --git a/tests/orog/ftst_minmax.F90 b/tests/orog/ftst_minmax.F90 new file mode 100644 index 000000000..3f90bef0c --- /dev/null +++ b/tests/orog/ftst_minmax.F90 @@ -0,0 +1,44 @@ + program minmax_test + +! Unit test for routine minmax, which finds the +! minimum and maximum value of an array and +! the indices of the maximum. +! +! Author George Gayno NCEP/EMC + + use orog_utils, only : minmax + + implicit none + + character(len=8) :: title + + integer, parameter :: im = 3 + integer, parameter :: jm = 2 + integer :: imax, jmax + + real :: a(im,jm) + + print*,"Starting test of minmax." + +! Test array. + + a(1,1) = 3. + a(2,1) = 4. + a(3,1) = 2. + a(1,2) = 1. + a(2,2) = 4. + a(3,2) = -1. + + title = 'test ' + +! Call the routine to unit test. + + call minmax(im,jm,a,title,imax,jmax) + + if (imax /= 2 .or. jmax /= 2) stop 3 + + print*,"OK" + + print*,"SUCCESS" + + end program minmax_test