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 1/2] 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
From 0c2c4b3d27cab6b4d617f0cc0171d3cb4c6b6758 Mon Sep 17 00:00:00 2001
From: GeorgeGayno-NOAA <52789452+GeorgeGayno-NOAA@users.noreply.github.com>
Date: Tue, 1 Oct 2024 08:35:10 -0400
Subject: [PATCH 2/2] Update for new 'fixed' directories (#986)
The './orog_raw' directory is removed. All needed files from
that directory were moved to './orog'.
Fixes #984.
---
docs/source/chgres_cube.rst | 8 ++++----
docs/source/ufs_utils.rst | 18 +++++++++---------
fix/link_fixdirs.sh | 12 ++++--------
ush/fv3gfs_driver_grid.sh | 2 +-
4 files changed, 18 insertions(+), 22 deletions(-)
diff --git a/docs/source/chgres_cube.rst b/docs/source/chgres_cube.rst
index 1f5ede13c..7d3c9f3c1 100644
--- a/docs/source/chgres_cube.rst
+++ b/docs/source/chgres_cube.rst
@@ -55,7 +55,7 @@ Program inputs and outputs for global applications
**Inputs**
-Users may create their own global grids, or use the pre-defined files located in the `./CRES directories `_. (where CRES is the atmospheric resolution and mxRES is the ocean resolution).
+Users may create their own global grids, or use the pre-defined files located in the `./CRES directories `_. (where CRES is the atmospheric resolution and mxRES is the ocean resolution).
* FV3 mosaic file - (NetCDF format)
* CRES_mosaic.nc
@@ -76,7 +76,7 @@ Users may create their own global grids, or use the pre-defined files located in
* CRES.mxRES_oro_data.tile5.nc
* CRES.mxRES_oro_data.tile6.nc
- * FV3 surface climatological files - Located under the `./CRES/sfc `_ subdirectories. One file for each tile. NetCDF format.
+ * FV3 surface climatological files - Located under the `./CRES/sfc `_ subdirectories. One file for each tile. NetCDF format.
* CRES.mxRES.facsf.tileX.nc (fractional coverage for strong/weak zenith angle dependent albedo)
* CRES.mxRES.maximum_snow_albedo.tileX.nc (maximum snow albedo)
* CRES.mxRES.slope_type.tileX.nc (slope type)
@@ -86,7 +86,7 @@ Users may create their own global grids, or use the pre-defined files located in
* CRES.mxRES.vegetation_greenness.tileX.nc (vegetation greenness)
* CRES.mxRES.vegetation_type.tileX.nc (vegetation type)
- * FV3 vertical coordinate file. Text file. `Located here `_.
+ * FV3 vertical coordinate file. Text file. `Located here `_.
* global_hyblev.l$LEVS.txt
* Input data files. GRIB2, NEMSIO or NetCDF. See the next section for how to find this data.
@@ -257,7 +257,7 @@ The following four sets of files/directories should all be located in the same d
* CRES.vegetation_greenness.tile7.halo4.nc (vegetation greenness)
* CRES.vegetation_type.tile7.halo4.nc (vegetation type)
- * FV3 vertical coordinate file. Text file. `Located here `_.
+ * FV3 vertical coordinate file. Text file. `Located here `_.
* global_hyblev.l$LEVS.txt
* Input data files. GRIB2 only. See the next section for how to find this data.
diff --git a/docs/source/ufs_utils.rst b/docs/source/ufs_utils.rst
index ed400585e..a7b284b33 100644
--- a/docs/source/ufs_utils.rst
+++ b/docs/source/ufs_utils.rst
@@ -240,11 +240,11 @@ Program inputs and outputs
* The "grid" files (CRES_grid.tile#.nc) containing the geo-reference records for the grid - (NetCDF). Created by the make_hgrid or regional_esg_grid programs.
* Global 30-arc-second University of Maryland land cover data. Used to create the land-sea mask.
- * landcover.umd.30s.nc (NetCDF). Located here `./fix/fix_orog `_.
+ * landcover.umd.30s.nc (NetCDF). Located here `./fix/orog `_.
* Global 30-arc-second USGS GMTED2010 orography data.
- * topography.gmted2010.30s.nc (NetCDF). Located here `./fix/fix_orog `_.
+ * topography.gmted2010.30s.nc (NetCDF). Located here `./fix/orog `_.
* 30-arc-second RAMP Antarctic terrain data (Radarsat Antarctic Mapping Project)
- * topography.antarctica.ramp.30s.nc (NetCDF). Located here `./fix/fix_orog `_.
+ * topography.antarctica.ramp.30s.nc (NetCDF). Located here `./fix/orog `_.
**Output data:**
@@ -288,8 +288,8 @@ The program reads the tile number (1-6 for global, 7 for stand-alone regional) a
All in NetCDF.
* The tiled "grid" files (CRES_grid.tile#.nc) created by the make_hgrid or regional_esg_grid programs.
- * geo_em.d01.lat-lon.2.5m.HGT_M.nc - global topographic data on 2.5-minute lat-lon grid (interpolated from GMTED2010 30-second topographic data). `Located here `_.
- * HGT.Beljaars_filtered.lat-lon.30s_res.nc - global topographic data on 30-second lat-lon grid (GMTED2010 data smoothed according to Beljaars et al. (QJRMS, 2004)). `Located here `_.
+ * geo_em.d01.lat-lon.2.5m.HGT_M.nc - global topographic data on 2.5-minute lat-lon grid (interpolated from GMTED2010 30-second topographic data). `Located here `_.
+ * HGT.Beljaars_filtered.lat-lon.30s_res.nc - global topographic data on 30-second lat-lon grid (GMTED2010 data smoothed according to Beljaars et al. (QJRMS, 2004)). `Located here `_.
**Output data:**
@@ -375,11 +375,11 @@ Program inputs and outputs
* grid file - the "grid" file from the make_hgrid or regional_esg programs - CRES_grid.tile#.nc - (NetCDF)
* orography file - the orography file including the 'inland' flag record from the inland program - oro.CRES.tile#.nc (NetCDF)
- * lake status code file - One of the following files. (located in `./fix/fix_orog `_). See GlobalLakeStatus.txt for a description of the file format.
+ * lake status code file - One of the following files. (located in `./fix/orog `_).
* GlobalLakeStatus_MOSISp.dat
* GlobalLakeStatus_GLDBv3release.dat
* GlobalLakeStatus_VIIRS.dat
- * lake depth file - One of the following files. (located in `./fix/fix_orog `_). See GlobalLakeDepth.txt for a description of this file.
+ * lake depth file - One of the following files. (located in `./fix/orog `_).
* GlobalLakeDepth_GLDBv3release.dat
* GlobalLakeDepth_GLOBathy.dat
@@ -529,7 +529,7 @@ Program inputs and outputs
**Input data:**
-The surface climatological data is located here `./fix/fix_sfc_climo `_. All NetCDF.
+The surface climatological data is located here `./fix/sfc_climo `_. All NetCDF.
* Global 1-degree fractional coverage strong/weak zenith angle albedo - facsf.1.0.nc
* Global 0.05-degree maximum snow albedo - maximum_snow_albedo.0.05.nc
@@ -697,7 +697,7 @@ Invoke the build script from the root directory:
./build_all.sh
-Set the 'fixed' directories using the script in the './fix' subdirectory (where $MACHINE is 'hera', 'jet', 'wcoss2', or 's4'):
+Set the 'fixed' directories using the script in the './fix' subdirectory (where $MACHINE is 'hera', 'jet', 'orion', 'hercules', 'gaea', 'wcoss2', or 's4'):
::
diff --git a/fix/link_fixdirs.sh b/fix/link_fixdirs.sh
index 46907f2d0..97136e4db 100755
--- a/fix/link_fixdirs.sh
+++ b/fix/link_fixdirs.sh
@@ -59,20 +59,16 @@ elif [ $machine = "gaea" ]; then
fi
am_ver=${am_ver:-20220805}
-orog_ver=${orog_ver:-20231027}
+orog_ver=${orog_ver:-20240917}
sfc_climo_ver=${sfc_climo_ver:-20230925}
-for dir in am orog orog_raw sfc_climo; do
+for dir in am orog sfc_climo; do
if [ -d $dir ]; then
[[ $RUN_ENVIR = nco ]] && chmod -R 755 $dir
rm -rf $dir
fi
- if [ $dir = "orog_raw" ]; then
- $LINK $FIX_DIR/raw/orog ${dir}
- else
- fix_ver="${dir}_ver"
- $LINK $FIX_DIR/$dir/${!fix_ver} ${dir}
- fi
+ fix_ver="${dir}_ver"
+ $LINK $FIX_DIR/$dir/${!fix_ver} ${dir}
done
exit 0
diff --git a/ush/fv3gfs_driver_grid.sh b/ush/fv3gfs_driver_grid.sh
index a0b48f420..7330e3c59 100755
--- a/ush/fv3gfs_driver_grid.sh
+++ b/ush/fv3gfs_driver_grid.sh
@@ -111,7 +111,7 @@ export out_dir=${out_dir:?}
export home_dir=${home_dir:-"$PWD/../"}
export script_dir=$home_dir/ush
export exec_dir=${exec_dir:-"$home_dir/exec"}
-export topo=$home_dir/fix/orog_raw
+export topo=$home_dir/fix/orog
export NCDUMP=${NCDUMP:-ncdump}