From d0490d278c44f99f337e64369e5a0da96d148c0a Mon Sep 17 00:00:00 2001 From: GeorgeGayno-NOAA <52789452+GeorgeGayno-NOAA@users.noreply.github.com> Date: Tue, 29 Dec 2020 14:52:54 -0500 Subject: [PATCH 01/47] Add doxygen comments to chgres_cube Resolves #191. --- sorc/chgres_cube.fd/atmosphere.F90 | 49 ++- sorc/chgres_cube.fd/chgres.F90 | 18 +- sorc/chgres_cube.fd/grib2_util.F90 | 10 +- sorc/chgres_cube.fd/input_data.F90 | 67 ++-- sorc/chgres_cube.fd/model_grid.F90 | 143 ++++---- sorc/chgres_cube.fd/program_setup.f90 | 323 +++++++++--------- sorc/chgres_cube.fd/search_util.f90 | 47 ++- sorc/chgres_cube.fd/static_data.F90 | 84 +++-- sorc/chgres_cube.fd/surface.F90 | 38 +-- .../chgres_cube.fd/thompson_mp_climo_data.F90 | 36 +- sorc/chgres_cube.fd/utils.f90 | 29 +- sorc/chgres_cube.fd/write_data.F90 | 61 ++-- 12 files changed, 455 insertions(+), 450 deletions(-) diff --git a/sorc/chgres_cube.fd/atmosphere.F90 b/sorc/chgres_cube.fd/atmosphere.F90 index 53ae2d077..7f5b4cbcf 100644 --- a/sorc/chgres_cube.fd/atmosphere.F90 +++ b/sorc/chgres_cube.fd/atmosphere.F90 @@ -1,30 +1,22 @@ +!> @file +!! @brief Process atmospheric fields +!! +!! @author gayno NCEP/EMC +!! +!! Process atmospheric fields: Horizontally interpolate input +!! fields to the target grid. Adjust surface pressure according to +!! terrain difference between input and target grids. Vertically +!! interpolate to target grid vertical levels. Processing based on +!! the spectral GFS version of CHGRES. +!! +!! Variables defined below. Here "b4adj" indicates fields on the target +!! grid before vertical adjustment. "target" indicates data on target +!! grid. "input" indicates data on input grid. "_s" indicates fields +!! on the 'south' edge of the grid box. "_w" indicate fields on the +!! 'west' edge of the grid box. Otherwise, fields are at the center +!! of the grid box. module atmosphere -!-------------------------------------------------------------------------- -! Module atmosphere -! -! Abstract: Process atmospheric fields: Horizontally interpolate input -! fields to the target grid. Adjust surface pressure according to -! terrain difference between input and target grids. Vertically -! interpolate to target grid vertical levels. Processing based on -! the spectral GFS version of CHGRES. -! -! Public Subroutines: -! ------------------- -! atmosphere driver Driver routine for processing atmospheric -! fields -! -! Public variables: -! ----------------- -! Variables defined below. Here "b4adj" indicates fields on the target -! grid before vertical adjustment. "target" indicates data on target -! grid. "input" indicates data on input grid. "_s" indicates fields -! on the 'south' edge of the grid box. "_w" indicate fields on the -! 'west' edge of the grid box. Otherwise, fields are at the center -! of the grid box. -! -!-------------------------------------------------------------------------- - use esmf use input_data, only : lev_input, & @@ -138,10 +130,9 @@ module atmosphere contains -!----------------------------------------------------------------------------------- -! Driver routine for atmospheric fields. -!----------------------------------------------------------------------------------- - +!> @brief +!! Driver routine for atmospheric fields. +!! subroutine atmosphere_driver(localpet) use mpi diff --git a/sorc/chgres_cube.fd/chgres.F90 b/sorc/chgres_cube.fd/chgres.F90 index 20d6b94cc..3aace4ba8 100644 --- a/sorc/chgres_cube.fd/chgres.F90 +++ b/sorc/chgres_cube.fd/chgres.F90 @@ -1,14 +1,14 @@ +!> @file +!! @brief Initialize an FV3 model run. +!! +!! Program CHGRES_CUBE +!! +!! Initialize an FV3 run using history or restart data from +!! another FV3 run, the spectral GFS, and a few other models. +!! Converts atmospheric, surface and nst data. +!! program chgres -!------------------------------------------------------------------------- -! Program CHGRES -! -! Abstract: Initialize an FV3 run using history or restart data from -! another FV3 run, or the NEMS version of the spectral GFS. -! Converts atmospheric, surface and nst data. -! -!------------------------------------------------------------------------- - use mpi use esmf diff --git a/sorc/chgres_cube.fd/grib2_util.F90 b/sorc/chgres_cube.fd/grib2_util.F90 index 195d5c71d..ebdb1dfc5 100644 --- a/sorc/chgres_cube.fd/grib2_util.F90 +++ b/sorc/chgres_cube.fd/grib2_util.F90 @@ -1,12 +1,8 @@ +!> @file +!! @brief Utilities for use when reading grib2 data. +!! module grib2_util -!-------------------------------------------------------------------------- -! Module: grib2_util -! -! Abstract: Utilities for use when reading grib2 data. -! -!-------------------------------------------------------------------------- - use esmf use model_grid, only : i_input, j_input diff --git a/sorc/chgres_cube.fd/input_data.F90 b/sorc/chgres_cube.fd/input_data.F90 index 66691a845..78005194c 100644 --- a/sorc/chgres_cube.fd/input_data.F90 +++ b/sorc/chgres_cube.fd/input_data.F90 @@ -1,28 +1,17 @@ +!> @file +!! @brief Read input data +!! @author gayno NCEP/EMC +!! +!! Read atmospheric, surface and nst data on the input grid. +!! Supported formats include fv3 tiled 'restart' files, fv3 tiled +!! 'history' files, fv3 gaussian history files, spectral gfs +!! gaussian nemsio files, and spectral gfs sigio/sfcio files. +!! +!! Public variables are defined below: "input" indicates field +!! associated with the input grid. +!! module input_data -!-------------------------------------------------------------------------- -! Module input_data -! -! Abstract: Read atmospheric, surface and nst data on the input grid. -! Supported formats include fv3 tiled 'restart' files, fv3 tiled -! 'history' files, fv3 gaussian history files, spectral gfs -! gaussian nemsio files, and spectral gfs sigio/sfcio files. -! -! Public Subroutines: -! ----------------- -! read_input_atm_data Driver routine to read atmospheric data -! cleanup_input_atm_data Free up memory associated with atm data -! read_input_sfc_data Driver routine to read surface data -! cleanup_input_sfc_data Free up memory associated with sfc data -! read_input_nst_data Driver routine to read nst data -! cleanup_input_nst_data Free up memory associated with nst data -! -! Public variables: -! ----------------- -! Defined below. "input" indicates field associated with the input grid. -! -!-------------------------------------------------------------------------- - use esmf use netcdf use nemsio_module @@ -52,7 +41,7 @@ module input_data num_tiles_input_grid, & latitude_input_grid, & longitude_input_grid, & - inv_file!, the_file_hrrr + inv_file implicit none @@ -143,10 +132,9 @@ module input_data contains -!--------------------------------------------------------------------------- -! Read input grid atmospheric data driver -!--------------------------------------------------------------------------- - +!> @brief +!! Read input grid atmospheric data driver +!! subroutine read_input_atm_data(localpet) implicit none @@ -213,10 +201,9 @@ subroutine read_input_atm_data(localpet) end subroutine read_input_atm_data -!--------------------------------------------------------------------------- -! Read input grid nst data driver -!--------------------------------------------------------------------------- - +!> @brief +!! Driver to read input grid nst data. +!! subroutine read_input_nst_data(localpet) implicit none @@ -375,10 +362,9 @@ subroutine read_input_nst_data(localpet) end subroutine read_input_nst_data -!--------------------------------------------------------------------------- -! Read input grid surface data driver. -!--------------------------------------------------------------------------- - +!> @brief +!! Driver to read input grid surface data. +!! subroutine read_input_sfc_data(localpet) implicit none @@ -6428,6 +6414,9 @@ subroutine read_grib_soil(the_file,inv_file,vname,vname_file,dummy3d,rc) end subroutine read_grib_soil +!> @brief +!! Free up memory associated with atm data +!! subroutine cleanup_input_atm_data implicit none @@ -6450,6 +6439,9 @@ subroutine cleanup_input_atm_data end subroutine cleanup_input_atm_data +!> @brief +!! Free up memory associated with nst data +!! subroutine cleanup_input_nst_data implicit none @@ -6480,6 +6472,9 @@ subroutine cleanup_input_nst_data end subroutine cleanup_input_nst_data +!> @brief +!! Free up memory associated with sfc data +!! subroutine cleanup_input_sfc_data implicit none diff --git a/sorc/chgres_cube.fd/model_grid.F90 b/sorc/chgres_cube.fd/model_grid.F90 index 6258ce44d..0e4221e03 100644 --- a/sorc/chgres_cube.fd/model_grid.F90 +++ b/sorc/chgres_cube.fd/model_grid.F90 @@ -1,60 +1,12 @@ +!> @file +!! @brief Specify input and target model grids +!! +!! @author gayno NCEP/EMC +!! +!! Specify input and target model grids via ESMF grid objects. +!! module model_grid -!-------------------------------------------------------------------------- -! Module model_grid -! -! Abstract: Specify input and target model grids -! -! Public Subroutines: -! ------------------- -! define_target_grid Setup the esmf grid object for the -! target grid. -! define_input_grid Setup the esmf grid object for the -! input grid. -! cleanup_input_target_grid_data Deallocate all esmf grid objects. -! -! Public variables: -! ----------------- -! i/j_input i/j dimension of each cube of the -! input grid. -! ip1/jp1_input i/j dimension plus 1 of input grid. -! i/j_target i/j dimension of each cube or of -! a nest, target grid. -! ip1/jp1_target i/j dimension plus 1 of input grid. -! input_grid input grid esmf grid object -! landmask_target_grid land mask target grid - '1' land; -! '0' non-land -! latitude_input_grid latitude of grid center, input grid -! latitude_target_grid latitude of grid center, target grid -! latitude_s_input_grid latitude of 'south' edge of grid -! box, input grid -! latitude_s_target_grid latitude of 'south' edge of grid -! box, target grid -! latitude_w_input_grid latitude of 'west' edge of grid -! box, input grid -! latitude_w_target_grid latitude of 'west' edge of grid -! box, target grid -! longitude_input_grid longitude of grid center, input grid -! longitude_target_grid longitude of grid center, target grid -! longitude_s_input_grid longitude of 'south' edge of grid -! box, input grid -! longitude_s_target_grid longitude of 'south' edge of grid -! box, target grid -! longitude_w_input_grid longitude of 'west' edge of grid -! box, input grid -! longitude_w_target_grid longitude of 'west' edge of grid -! box, target grid -! lsoil_target Number of soil layers, target grid. -! num_tiles_input_grid Number of tiles, input grid -! num_tiles_target_grid Number of tiles, target grid -! seamask_target_grid sea mask target grid - '1' non-land; -! '0' land -! target_grid target grid esmf grid object. -! terrain_target_grid terrain height target grid -! tiles_target_grid Tile names of target grid. -! -!-------------------------------------------------------------------------- - use esmf use ESMF_LogPublicMod @@ -63,39 +15,86 @@ module model_grid private character(len=5), allocatable, public :: tiles_target_grid(:) + !< Tile names of target grid. character(len=10), public :: inv_file = "chgres.inv" + !< wgrib2 inventory file character(len=50), public :: input_grid_type = "latlon" - !character(len=100), public :: the_file_hrrr = "./HRRR_adj_rad.grib2" + !< map projection of input grid ! Made lsoil_target non-parameter to allow for RAP land surface initiation integer, public :: lsoil_target = 4 ! # soil layers - - integer, public :: i_input, j_input - integer, public :: ip1_input, jp1_input - integer, public :: i_target, j_target - integer, public :: ip1_target, jp1_target + !< Number of soil layers, target grid. + integer, public :: i_input + !< i-dimension of input grid + !! (or of each global tile) + integer, public :: j_input + !< j-dimension of input grid + !! (or of each global tile) + integer, public :: ip1_input + !< i_input plus 1 + integer, public :: jp1_input + !< j_input plus 1 + integer, public :: i_target + !< i dimension of each global tile, + !! or of a nest, target grid. + integer, public :: j_target + !< j dimension of each global tile, + !! or of a nest, target grid. + integer, public :: ip1_target + !< ip1_target plus 1 + integer, public :: jp1_target + !< jp1_target plus 1 integer, public :: num_tiles_input_grid + !< Number of tiles, input grid integer, public :: num_tiles_target_grid + !< Number of tiles, target grid type(esmf_grid), public :: input_grid + !< input grid esmf grid object type(esmf_grid), public :: target_grid + !< target grid esmf grid object. type(esmf_field), public :: latitude_input_grid + !< latitude of grid center, input grid type(esmf_field), public :: longitude_input_grid + !< longitude of grid center, input grid type(esmf_field), public :: latitude_s_input_grid + !< latitude of 'south' edge of grid + !! box, input grid type(esmf_field), public :: longitude_s_input_grid + !< longitude of 'south' edge of grid + !! box, input grid type(esmf_field), public :: latitude_w_input_grid + !< latitude of 'west' edge of grid + !! box, input grid type(esmf_field), public :: longitude_w_input_grid + !< longitude of 'west' edge of grid + !! box, input grid type(esmf_field), public :: landmask_target_grid + !< land mask target grid - '1' land; + !! '0' non-land type(esmf_field), public :: latitude_target_grid + !< latitude of grid center, target grid type(esmf_field), public :: latitude_s_target_grid + !< latitude of 'south' edge of grid + !! box, target grid type(esmf_field), public :: latitude_w_target_grid + !< latitude of 'west' edge of grid + !! box, target grid type(esmf_field), public :: longitude_target_grid + !< longitude of grid center, target grid type(esmf_field), public :: longitude_s_target_grid + !< longitude of 'south' edge of grid + !! box, target grid type(esmf_field), public :: longitude_w_target_grid + !< longitude of 'west' edge of grid + !! box, target grid type(esmf_field), public :: seamask_target_grid + !< sea mask target grid - '1' non-land; + !! '0' land type(esmf_field), public :: terrain_target_grid + !< terrain height target grid public :: define_target_grid public :: define_input_grid @@ -103,15 +102,14 @@ module model_grid contains -!-------------------------------------------------------------------------- -! Set up the esmf grid object for the input grid. If the input -! source is tiled fv3 restart or history data, the grid is created -! by reading the mosaic and grid files. If the input source is -! fv3 global gaussian nemsio, spectral gfs global gaussian nemsio, or -! spectral gfs global gaussian sigio/sfcio, the grid is setup by -! computing lat/lons using the sp library. -!-------------------------------------------------------------------------- - +!> @brief Setup the esmf grid object for the input grid. +!! +!! If the input source is tiled fv3 restart or history data, the grid is +!! created by reading the mosaic and grid files. If the input source is +!! fv3 global gaussian nemsio, spectral gfs global gaussian nemsio, or +!! spectral gfs global gaussian sigio/sfcio, the grid is setup by +!! computing lat/lons using the sp library. +!! subroutine define_input_grid(localpet, npets) use program_setup, only : input_type, external_model @@ -1081,6 +1079,9 @@ subroutine define_input_grid_grib2(localpet, npets) end subroutine define_input_grid_grib2 +!> @brief +!! Setup the esmf grid object for the target grid. +!! subroutine define_target_grid(localpet, npets) use netcdf @@ -1643,6 +1644,8 @@ subroutine get_model_mask_terrain(orog_file, idim, jdim, mask, terrain) end subroutine get_model_mask_terrain +!> @brief Deallocate all esmf grid objects. +!! subroutine cleanup_input_target_grid_data implicit none diff --git a/sorc/chgres_cube.fd/program_setup.f90 b/sorc/chgres_cube.fd/program_setup.f90 index 2b2d6ba65..7bf070e93 100644 --- a/sorc/chgres_cube.fd/program_setup.f90 +++ b/sorc/chgres_cube.fd/program_setup.f90 @@ -1,166 +1,158 @@ +!> @file +!! @brief Set up program execution +!! +!! @author gayno NCEP/EMC +!! +!! Set up program execution +!! +!! Public variables: +!! +!! - atm_files_input_grid - File names of input atmospheric data. +!! Not used for "grib2" or "restart" +!! input types. +!! - atm_core_files_input_grid - File names of input atmospheric restart +!! core files. Only used for 'restart' +!! input type. +!! - atm_tracer_files_input_grid - File names of input atmospheric restart +!! tracer files. Only used for 'restart' +!! input type. +!! - atm_weight_file - File containing pre-computed weights +!! to horizontally interpolate +!! atmospheric fields. +!! - bb_target - Soil 'b' parameter, target grid +!! - convert_atm - Convert atmospheric data when true. +!! - convert_nst - Convert nst data when true. +!! - convert_sfc - Convert sfc data when true. +!! - cres_target_grid - Target grid resolution, i.e., C768. +!! - cycle_mon/day/hour - Cycle month/day/hour +!! - data_dir_input_grid - Directory containing input atm or sfc +!! files. +!! - drysmc_input/target - Air dry soil moisture content input/ +!! target grids. +!! - fix_dir_target_grid - Directory containing target grid +!! pre-computed fixed data (ex: soil type) +!! - halo_blend - Number of row/cols of blending halo, +!! where model tendencies and lateral +!! boundary tendencies are applied. +!! Regional target grids only. +!! - halo_bndy - Number of row/cols of lateral halo, +!! where pure lateral bndy conditions are +!! applied (regional target grids). +!! - input_type - Input data type: +!! - "restart" for fv3 tiled warm restart +!! files (netcdf). +!! - "history" for fv3 tiled history files +!! (netcdf). +!! - "gaussian_nemsio" for fv3 gaussian +!! nemsio files; +!! - "gaussian_netcdf" for fv3 gaussian +!! netcdf files. +!! - "grib2" for grib2 files. +!! - "gfs_gaussian_nemsio" for spectral gfs +!! gaussian nemsio files +!! - "gfs_sigio" for spectral gfs +!! gfs sigio/sfcio files. +!! - max_tracers - Maximum number of atmospheric tracers +!! processed +!! - maxsmc_input/target - Maximum soil moisture content input/ +!! target grids +!! - mosaic_file_input_grid - Input grid mosaic file. Only used for +!! "restart" or "history" input type. +!! - mosaic_file_target_grid - Target grid mosaic file +!! - nst_files_input_grid - File name of input nst data. Only +!! used for input_type "gfs_gaussian_nemsio". +!! - num_tracers - Number of atmospheric tracers to +!! be processed. +!! - orog_dir_input_grid - Directory containing the input grid +!! orography files. Only used for "restart" +!! or "history" input types. +!! - orog_files_input_grid - Input grid orography files. Only used for +!! "restart" or "history" input types. +!! - orog_dir_target_grid - Directory containing the target grid +!! orography files. +!! - orog_files_target_grid - Target grid orography files. +!! - refsmc_input/target - Reference soil moisture content input/ +!! target grids (onset of soil moisture +!! stress). +!! - regional - For regional target grids. When '1' +!! remove boundary halo region from +!! atmospheric/surface data and +!! output atmospheric boundary file. +!! When '2' output boundary file only. +!! Default is '0' (global grids). +!! - satpsi_target - Saturated soil potential, target grid +!! - sfc_files_input_grid - File names containing input surface data. +!! Not used for 'grib2' input type. +!! - thomp_mp_climo_file - Path/name to the Thompson MP climatology +!! file. +!! - tracers - Name of each atmos tracer to be processed. +!! These names will be used to identify +!! the tracer records in the output files. +!! Follows the convention in the field table. +!! FOR GRIB2 FILES: Not used. Tracers instead taken +!! from the varmap file. +!! - tracers_input - Name of each atmos tracer record in +!! the input file. May be different from +!! value in 'tracers'. +!! FOR GRIB2 FILES: Not used. Tracers instead taken +!! from the varmap file. +!! - use_thomp_mp_climo - When true, read and process Thompson +!! MP climatological tracers. False, +!! when 'thomp_mp_climo_file' is NULL. +!! - vcoord_file_target_grid - Vertical coordinate definition file +!! - wltsmc_input/target - Wilting point soil moisture content +!! input/target grids +!! - nsoill_out - Number of soil levels desired in the output data. +!! chgres_cube can interpolate from 9 input to 4 output +!! levels. DEFAULT: 4 +!! +!! Variables that are relevant only for "grib2" input type: +!! +!! - grib2_file_input_grid - REQUIRED. File name of grib2 input data. +!! Assumes atmospheric and surface data are in a single +!! file. +!! +!! - varmap_file - REQUIRED. Full path of the relevant varmap file. +!! +!! - external_model - The model that the input data is derived from. Current +!! supported options are: "GFS", "HRRR", "NAM", "RAP". +!! Default: "GFS" +!! +!! - vgtyp_from_climo - If false, interpolate vegetation type from the input +!! data to the target grid instead of using data from +!! static data. Use with caution as vegetation categories +!! can vary. Default: True +!! +!! - sotyp_from_climo - If false, interpolate soil type from the input +!! data to the target grid instead of using data from +!! static data. Use with caution as the code assumes +!! input soil type use STATSGO soil categories. +!! Default: True +!! +!! - vgfrc_from_climo - If false, interpolate vegetation fraction from the input +!! data to the target grid instead of using data from +!! static data. Use with caution as vegetation categories +!! can vary. +!! Default: True +!! +!! - minmax_vgfrc_from_climo - If false, interpolate min/max vegetation fraction from +!! the input data to the target grid instead of using data +!! from static data. Use with caution as vegetation +!! categories can vary. +!! Default: True +!! +!! - lai_from_climo - If false, interpolate leaf area index from the input +!! data to the target grid instead of using data from +!! static data. +!! Default: True +!! +!! - tg3_from_soil - If false, use lowest level soil temperature for the +!! base soil temperature instead of using data from +!! static data. +!! Default: False +!! module program_setup -!-------------------------------------------------------------------------- -! Module program_setup -! -! Abstract: Set up program execution -! -! Public Subroutines: -! ------------------- -! read_setup_namelist Reads configuration namelist -! calc_soil_params_driver Computes soil parameters -! -! Public variables: -! ----------------- -! atm_files_input_grid File names of input atmospheric data. -! Not used for "grib2" or "restart" -! input types. -! atm_core_files_input_grid File names of input atmospheric restart -! core files. Only used for 'restart' -! input type. -! atm_tracer_files_input_grid File names of input atmospheric restart -! tracer files. Only used for 'restart' -! input type. -! atm_weight_file File containing pre-computed weights -! to horizontally interpolate -! atmospheric fields. -! bb_target Soil 'b' parameter, target grid -! convert_atm Convert atmospheric data when true. -! convert_nst Convert nst data when true. -! convert_sfc Convert sfc data when true. -! cres_target_grid Target grid resolution, i.e., C768. -! cycle_mon/day/hour Cycle month/day/hour -! data_dir_input_grid Directory containing input atm or sfc -! files. -! drysmc_input/target Air dry soil moisture content input/ -! target grids. -! fix_dir_target_grid Directory containing target grid -! pre-computed fixed data (ex: soil type) -! halo_blend Number of row/cols of blending halo, -! where model tendencies and lateral -! boundary tendencies are applied. -! Regional target grids only. -! halo_bndy Number of row/cols of lateral halo, -! where pure lateral bndy conditions are -! applied (regional target grids). -! input_type Input data type: -! (1) "restart" for fv3 tiled warm restart -! files (netcdf). -! (2) "history" for fv3 tiled history files -! (netcdf). -! (3) "gaussian_nemsio" for fv3 gaussian -! nemsio files; -! (4) "gaussian_netcdf" for fv3 gaussian -! netcdf files. -! (5) "grib2" for grib2 files. -! (6) "gfs_gaussian_nemsio" for spectral gfs -! gaussian nemsio files -! (7) "gfs_sigio" for spectral gfs -! gfs sigio/sfcio files. -! max_tracers Maximum number of atmospheric tracers -! processed -! maxsmc_input/target Maximum soil moisture content input/ -! target grids -! mosaic_file_input_grid Input grid mosaic file. Only used for -! "restart" or "history" input type. -! mosaic_file_target_grid Target grid mosaic file -! nst_files_input_grid File name of input nst data. Only -! used for input_type "gfs_gaussian_nemsio". -! num_tracers Number of atmospheric tracers to -! be processed. -! orog_dir_input_grid Directory containing the input grid -! orography files. Only used for "restart" -! or "history" input types. -! orog_files_input_grid Input grid orography files. Only used for -! "restart" or "history" input types. -! orog_dir_target_grid Directory containing the target grid -! orography files. -! orog_files_target_grid Target grid orography files. -! refsmc_input/target Reference soil moisture content input/ -! target grids (onset of soil moisture -! stress). -! regional For regional target grids. When '1' -! remove boundary halo region from -! atmospheric/surface data and -! output atmospheric boundary file. -! When '2' output boundary file only. -! Default is '0' (global grids). -! satpsi_target Saturated soil potential, target grid -! sfc_files_input_grid File names containing input surface data. -! Not used for 'grib2' input type. -! thomp_mp_climo_file Path/name to the Thompson MP climatology -! file. -! tracers Name of each atmos tracer to be processed. -! These names will be used to identify -! the tracer records in the output files. -! Follows the convention in the field table. -! FOR GRIB2 FILES: Not used. Tracers instead taken -! from the varmap file. -! tracers_input Name of each atmos tracer record in -! the input file. May be different from -! value in 'tracers'. -! FOR GRIB2 FILES: Not used. Tracers instead taken -! from the varmap file. -! use_thomp_mp_climo When true, read and process Thompson -! MP climatological tracers. False, -! when 'thomp_mp_climo_file' is NULL. -! vcoord_file_target_grid Vertical coordinate definition file -! wltsmc_input/target Wilting point soil moisture content -! input/target grids -! -! nsoill_out Number of soil levels desired in the output data. -! chgres_cube can interpolate from 9 input to 4 output -! levels. -! DEFAULT: 4 -! -! Variables that are relevant only for "grib2" input type: -! -! grib2_file_input_grid REQUIRED. File name of grib2 input data. -! Assumes atmospheric and surface data are in a single -! file. -! -! varmap_file REQUIRED. Full path of the relevant varmap file. -! -! external_model The model that the input data is derived from. Current -! supported options are: "GFS", "HRRR", "NAM", "RAP". -! Default: "GFS" -! -! vgtyp_from_climo If false, interpolate vegetation type from the input -! data to the target grid instead of using data from -! static data. Use with caution as vegetation categories -! can vary. -! Default: True -! -! sotyp_from_climo If false, interpolate soil type from the input -! data to the target grid instead of using data from -! static data. Use with caution as the code assumes -! input soil type use STATSGO soil categories. -! Default: True -! -! vgfrc_from_climo If false, interpolate vegetation fraction from the input -! data to the target grid instead of using data from -! static data. Use with caution as vegetation categories -! can vary. -! Default: True -! -! minmax_vgfrc_from_climo If false, interpolate min/max vegetation fraction from -! the input data to the target grid instead of using data -! from static data. Use with caution as vegetation -! categories can vary. -! Default: True -! -! lai_from_climo If false, interpolate leaf area index from the input -! data to the target grid instead of using data from -! static data. -! Default: True -! -! tg3_from_soil If false, use lowest level soil temperature for the -! base soil temperature instead of using data from -! static data. -! Default: False -! -!-------------------------------------------------------------------------- - implicit none private @@ -242,6 +234,10 @@ module program_setup contains +!> @brief Reads configuration namelist. +!! +!! @author gayno NCEP/EMC +!! subroutine read_setup_namelist implicit none @@ -295,7 +291,6 @@ subroutine read_setup_namelist close (41) call to_lower(input_type) -! call to_upper(phys_suite) orog_dir_target_grid = trim(orog_dir_target_grid) // '/' orog_dir_input_grid = trim(orog_dir_input_grid) // '/' @@ -517,6 +512,10 @@ subroutine get_var_cond(var_name,this_miss_var_method,this_miss_var_value, & end subroutine get_var_cond +!> @brief Compute soil parameters. +!! +!! @author gayno NCEP/EMC +!! subroutine calc_soil_params_driver(localpet) implicit none diff --git a/sorc/chgres_cube.fd/search_util.f90 b/sorc/chgres_cube.fd/search_util.f90 index e5bec9c53..6239b8c9c 100644 --- a/sorc/chgres_cube.fd/search_util.f90 +++ b/sorc/chgres_cube.fd/search_util.f90 @@ -1,39 +1,34 @@ +!> @file +!! @brief Replace undefined surface values. +!! +!! @author gayno NCEP/EMC +!! +!! Replace undefined values with a valid value. This can +!! happen for an isolated lake or island that is unresolved by +!! the input grid. +!! module search_util -!-------------------------------------------------------------------------- -! Module search -! -! Abstract: Replace undefined values with a valid value. This can -! happen for an isolated lake or island that is unresolved by -! the input grid. -! -! Public Subroutines: -! ------------------- -! search Performs the search and replace. -! -!-------------------------------------------------------------------------- - private public :: search contains +!> @brief Replace undefined surface values. +!! +!! Replace undefined values on the model grid with a valid value at +!! a nearby neighbor. Undefined values are typically associated +!! with isolated islands where there is no source data. +!! +!! Routine searches a neighborhood with a radius of 100 grid points. +!! If no valid value is found, a default value is used. +!! +!! @note This routine works for one tile of a cubed sphere grid. It +!! does not consider valid values at adjacent faces. That is a +!! future upgrade. subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_land, soilt_climo) -!----------------------------------------------------------------------- -! Replace undefined values on the model grid with a valid value at -! a nearby neighbor. Undefined values are typically associated -! with isolated islands where there is no source data. -! -! Routine searches a neighborhood with a radius of 100 grid points. -! If no valid value is found, a default value is used. -! -! Note: This routine works for one tile of a cubed sphere grid. It -! does not consider valid values at adjacent faces. That is a -! future upgrade. -!----------------------------------------------------------------------- - use mpi use esmf diff --git a/sorc/chgres_cube.fd/static_data.F90 b/sorc/chgres_cube.fd/static_data.F90 index 3bd297475..5386e8dc7 100644 --- a/sorc/chgres_cube.fd/static_data.F90 +++ b/sorc/chgres_cube.fd/static_data.F90 @@ -1,40 +1,33 @@ +!> @file +!! @brief Process static surface data +!! +!! @author gayno NCEP/EMC +!! +!! Read pre-computed static/climatological data on the fv3 +!! target grid. Time interpolate if necessary (for example a +!! monthly climo field). +!! +!! Public variables: +!! +!! - alnsf_target_grid - near ir black sky albedo +!! - alnwf_target_grid - near ir white sky albedo +!! - alvsf_target_grid - visible black sky albedo +!! - alvwf_target_grid - visible white sky albedo +!! - facsf_target_grid - fractional coverage for strong +!! zenith angle dependent albedo +!! - facwf_target_grid - fractional coverage for weak +!! zenith angle dependent albedo +!! - max_veg_greenness_target_grid - maximum annual greenness fraction +!! - min_veg_greenness_target_grid - minimum annual greenness fraction +!! - mxsno_albedo_target_grid - maximum snow albedo +!! - slope_type_target_grid - slope type +!! - soil_type_target_grid - soil type +!! - substrate_temp_target_grid - soil subtrate temperature +!! - veg_greenness_target_grid - vegetation greenness fraction +!! - veg_type_target_grid - vegetation type +!! module static_data -!-------------------------------------------------------------------------- -! Module static data -! -! Abstract: Read pre-computed static/climatological data on the fv3 -! target grid. Time interpolate if necessary (for example a -! monthly climo fields). -! -! Public Subroutines: -! ------------------- -! get_static_fields Driver routine to read/time interpolate -! static/climo fields on the fv3 target -! grid. -! cleanup_static_fields Free up memory for fields in this module. -! -! Public variables: -! ----------------- -! alnsf_target_grid near ir black sky albedo -! alnwf_target_grid near ir white sky albedo -! alvsf_target_grid visible black sky albedo -! alvwf_target_grid visible white sky albedo -! facsf_target_grid fractional coverage for strong -! zenith angle dependent albedo -! facwf_target_grid fractional coverage for weak -! zenith angle dependent albedo -! max_veg_greenness_target_grid maximum annual greenness fraction -! min_veg_greenness_target_grid minimum annual greenness fraction -! mxsno_albedo_target_grid maximum snow albedo -! slope_type_target_grid slope type -! soil_type_target_grid soil type -! substrate_temp_target_grid soil subtrate temperature -! veg_greenness_target_grid vegetation greenness fraction -! veg_type_targe_grid vegetation type -! -!-------------------------------------------------------------------------- - use esmf implicit none @@ -61,10 +54,11 @@ module static_data contains -!------------------------------------------------------------------------------ -! Read static fields on the target grid. -!------------------------------------------------------------------------------ - +!> @brief Driver routine to read/time interpolate static/climo fields +!! on the fv3 target grid. +!! +!! @author gayno NCEP/EMC +!! subroutine get_static_fields(localpet) use model_grid, only : target_grid, & @@ -362,10 +356,10 @@ subroutine get_static_fields(localpet) end subroutine get_static_fields -!------------------------------------------------------------------------------ -! Read data file. -!------------------------------------------------------------------------------ - +!> @brief Read static climatological data file +!! +!! @author gayno NCEP/EMC +!! subroutine read_static_file(field, i_target, j_target, tile, & data_one_tile, max_data_one_tile, & min_data_one_tile) @@ -500,6 +494,10 @@ subroutine read_static_file(field, i_target, j_target, tile, & end subroutine read_static_file +!> @brief Free up memory for fields in this module. +!! +!! @author gayno NCEP/EMC +!! subroutine cleanup_static_fields implicit none diff --git a/sorc/chgres_cube.fd/surface.F90 b/sorc/chgres_cube.fd/surface.F90 index 7701534aa..a4d055b71 100644 --- a/sorc/chgres_cube.fd/surface.F90 +++ b/sorc/chgres_cube.fd/surface.F90 @@ -1,25 +1,19 @@ +!> @file +!! @brief Process surface and nst fields. +!! +!! @author gayno NCEP/EMC +!! +!! Process surface and nst fields. Interpolates fields from +!! the input to target grids. Adjusts soil temperature according +!! to differences in input and target grid terrain. Rescales +!! soil moisture for soil type differences between input and target +!! grid. Computes frozen portion of total soil moisture. +!! +!! Public variables are defined below. "target" indicates field +!! associated with the target grid. "input" indicates field associated +!! with the input grid. module surface -!-------------------------------------------------------------------------- -! Module surface -! -! Abstract: Process surface and nst fields. Interpolates fields from -! the input to target grids. Adjusts soil temperature according -! to differences in input and target grid terrain. Rescales -! soil moisture for soil type differences between input and target -! grid. Computes frozen portion of total soil moisture. -! -! Public Subroutines: -! ----------------- -! surface_driver Driver routine to process surface/nst data -! -! Public variables: -! ----------------- -! Defined below. "target" indicates field associated with the target grid. -! "input" indicates field associated with the input grid. -! -!-------------------------------------------------------------------------- - use esmf implicit none @@ -117,6 +111,10 @@ module surface contains +!> @brief Driver routine to process surface/nst data +!! +!! @author gayno NCEP/EMC +!! subroutine surface_driver(localpet) use input_data, only : cleanup_input_sfc_data, & diff --git a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 index 82104324a..accd83382 100644 --- a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 +++ b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 @@ -1,10 +1,11 @@ +!> @file +!! @brief Process Thompson climatological MP data +!! +!! Module to read the Thompson climatological MP data file +!! and set up the associated esmf field and grid objects. +!! module thompson_mp_climo_data -!----------------------------------------------------------------------------------- -! Module to read the Thompson climatological MP data file and set up the -! associated esmf field and grid objects. -!----------------------------------------------------------------------------------- - use esmf use netcdf use program_setup, only : cycle_mon, cycle_day, cycle_hour, & @@ -15,25 +16,33 @@ module thompson_mp_climo_data private integer :: i_thomp_mp_climo + !< i-dimension of Thompson climo data integer :: j_thomp_mp_climo + !< j-dimension of Thompson climo data integer, public :: lev_thomp_mp_climo + !< number of vert lvls of Thompson climo data type(esmf_grid) :: thomp_mp_climo_grid + !< esmf grid object for Thompson data grid type(esmf_field), public :: qnifa_climo_input_grid + !< number concentration of ice friendly + !! nuclei. type(esmf_field), public :: qnwfa_climo_input_grid + !< number concentration of water friendly + !! nuclei. type(esmf_field), public :: thomp_pres_climo_input_grid + !< 3-d pressure of the Thompson climo + !! data points public :: read_thomp_mp_climo_data public :: cleanup_thomp_mp_climo_input_data contains -!----------------------------------------------------------------------------------- -! Read Thompson climatological MP data file and time interpolate data to current -! cycle time. -!----------------------------------------------------------------------------------- - +!> @brief Read Thompson climatological MP data file and time interpolate data to +!! to current cycle time. +!! subroutine read_thomp_mp_climo_data implicit none @@ -309,10 +318,9 @@ subroutine read_thomp_mp_climo_data end subroutine read_thomp_mp_climo_data -!----------------------------------------------------------------------------------- -! Cleanup routine -!----------------------------------------------------------------------------------- - +!> @brief +!! Free up memory associated with this module. +!! subroutine cleanup_thomp_mp_climo_input_data implicit none diff --git a/sorc/chgres_cube.fd/utils.f90 b/sorc/chgres_cube.fd/utils.f90 index 337083fd3..7ddb06288 100644 --- a/sorc/chgres_cube.fd/utils.f90 +++ b/sorc/chgres_cube.fd/utils.f90 @@ -1,3 +1,12 @@ +!> @file +!! @brief Contains utility routines +!! + + +!> @brief General error handler. +!! +!! @param[in] string error message +!! @param[in] rc error status code subroutine error_handler(string, rc) use mpi @@ -16,6 +25,10 @@ subroutine error_handler(string, rc) end subroutine error_handler +!> @brief Error handler for netcdf +!! +!! @param[in] err error status code +!! @param[in] string error message subroutine netcdf_err( err, string ) use mpi @@ -37,9 +50,13 @@ subroutine netcdf_err( err, string ) return end subroutine netcdf_err +!> @brief Convert from lower to uppercase. +!! @author Clive Page +!! +!! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) +!! +!! @param[in,out] strIn string to convert subroutine to_upper(strIn) -! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) -! Original author: Clive Page implicit none @@ -58,9 +75,13 @@ subroutine to_upper(strIn) strIn(:) = strOut(:) end subroutine to_upper +!> @brief Convert from upper to lowercase +!! @author Clive Page +!! +!! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) +!! +!! @param[in,out] strIn string to convert subroutine to_lower(strIn) -! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) -! Original author: Clive Page implicit none diff --git a/sorc/chgres_cube.fd/write_data.F90 b/sorc/chgres_cube.fd/write_data.F90 index a05c824d8..c4014bbae 100644 --- a/sorc/chgres_cube.fd/write_data.F90 +++ b/sorc/chgres_cube.fd/write_data.F90 @@ -1,22 +1,16 @@ -!-------------------------------------------------------------------------- -! Module: write_data -! -! Abstract: Write out target grid data into appropriate files for -! the forecast model. -! -! Main Subroutines: -! ------------------- -! write_fv3_atm_header_netcdf Writes atmospheric header file, -! netcdf format. -! write_fv3_atm_bndy_data_netcdf Writes atmospheric fields along the -! lateral boundary. For regional grids. -! netcdf format. -! write_fv3_atm_data_netcdf Writes atmospheric data into a -! 'coldstart' file (netcdf) -! write_fv3_sfc_data_netcdf Writes surface and nst data into a -! 'coldstart' file (netcdf) -!-------------------------------------------------------------------------- - +!> @file +!! @brief Write model coldstart files. +!! +!! @author gayno NCEP/EMC +!! +!! Write out target grid data into appropriate files for +!! the forecast model. +!! + +!> @brief Writes atmospheric header file in netcdf format +!! +!! @author gayno NCEP/EMC +!! subroutine write_fv3_atm_header_netcdf(localpet) use esmf @@ -85,6 +79,12 @@ subroutine write_fv3_atm_header_netcdf(localpet) end subroutine write_fv3_atm_header_netcdf +!> @brief +!! Writes atmospheric fields along the lateral boundary. +!! For regional grids only. Output in netcdf format. +!! +!! @author gayno NCEP/EMC +!! subroutine write_fv3_atm_bndy_data_netcdf(localpet) !--------------------------------------------------------------------------- @@ -1183,14 +1183,14 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) end subroutine write_fv3_atm_bndy_data_netcdf -!--------------------------------------------------------------------------- -! Write atmospheric coldstart files. -! -! Routine write tiled files in parallel. Tile 1 is written by -! localpet 0; tile 2 by localpet 1, etc. The number of pets -! must be equal to or greater than the number of tiled files. -!--------------------------------------------------------------------------- - +!> @brief Write atmospheric coldstart files (netcdf format). +!! +!! @author gayno NCEP/EMC +!! +!! Routine writes tiled files in parallel. Tile 1 is written by +!! localpet 0; tile 2 by localpet 1, etc. The number of pets +!! must be equal to or greater than the number of tiled files. +!! subroutine write_fv3_atm_data_netcdf(localpet) use esmf @@ -1800,9 +1800,10 @@ subroutine write_fv3_atm_data_netcdf(localpet) end subroutine write_fv3_atm_data_netcdf -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - +!> @brief Writes surface and nst data into a 'coldstart' file (netcdf). +!! +!! @author gayno NCEP/EMC +!! subroutine write_fv3_sfc_data_netcdf(localpet) use esmf From 7760027fa9887af96c22a066407ff4f552724435 Mon Sep 17 00:00:00 2001 From: GeorgeGayno-NOAA <52789452+GeorgeGayno-NOAA@users.noreply.github.com> Date: Tue, 12 Jan 2021 15:30:20 -0500 Subject: [PATCH 02/47] Add basic doxygen to remaining repository routines Add basic doxygen to all files under 'fre-nctools.fd' and 'orog.fd'. Removed unused include file - resovod.h - from orog.fd and converted machine.h to a Fortran module. Doxygen works better with module files. Update Doxyfile.in to use full paths for better online display. Issue #191. --- docs/Doxyfile.in | 2 +- sorc/fre-nctools.fd/shared_lib/affinity.c | 4 +++- sorc/fre-nctools.fd/shared_lib/constant.h | 4 +++- sorc/fre-nctools.fd/shared_lib/create_xgrid.c | 4 +++- sorc/fre-nctools.fd/shared_lib/create_xgrid.h | 4 +++- sorc/fre-nctools.fd/shared_lib/gradient.F90 | 5 +++++ sorc/fre-nctools.fd/shared_lib/gradient_c2l.c | 4 +++- sorc/fre-nctools.fd/shared_lib/gradient_c2l.h | 4 +++- sorc/fre-nctools.fd/shared_lib/grid.F90 | 3 +++ sorc/fre-nctools.fd/shared_lib/interp.c | 7 ++---- sorc/fre-nctools.fd/shared_lib/interp.h | 13 +++-------- sorc/fre-nctools.fd/shared_lib/mosaic.F90 | 4 ++++ sorc/fre-nctools.fd/shared_lib/mosaic_util.c | 4 +++- sorc/fre-nctools.fd/shared_lib/mosaic_util.h | 11 ++++------ sorc/fre-nctools.fd/shared_lib/mpp.c | 4 +++- sorc/fre-nctools.fd/shared_lib/mpp.h | 13 +++++------ sorc/fre-nctools.fd/shared_lib/mpp_domain.c | 12 +++++----- sorc/fre-nctools.fd/shared_lib/mpp_domain.h | 21 +++++++++--------- sorc/fre-nctools.fd/shared_lib/mpp_io.c | 5 ++++- sorc/fre-nctools.fd/shared_lib/mpp_io.h | 13 ++++------- sorc/fre-nctools.fd/shared_lib/read_mosaic.c | 4 +++- sorc/fre-nctools.fd/shared_lib/read_mosaic.h | 4 +++- sorc/fre-nctools.fd/shared_lib/tool_util.c | 5 ++++- sorc/fre-nctools.fd/shared_lib/tool_util.h | 3 +-- .../tools/fregrid/bilinear_interp.c | 3 +++ .../tools/fregrid/bilinear_interp.h | 3 +++ .../tools/fregrid/conserve_interp.c | 3 +++ .../tools/fregrid/conserve_interp.h | 3 +++ sorc/fre-nctools.fd/tools/fregrid/fregrid.c | 22 ++++--------------- .../tools/fregrid/fregrid_util.c | 3 +++ .../tools/fregrid/fregrid_util.h | 3 +++ sorc/fre-nctools.fd/tools/fregrid/globals.h | 3 +++ .../make_hgrid/create_conformal_cubic_grid.c | 3 +++ .../make_hgrid/create_gnomonic_cubic_grid.c | 3 +++ .../tools/make_hgrid/create_grid_from_file.c | 6 ++--- .../tools/make_hgrid/create_hgrid.h | 10 ++++----- .../tools/make_hgrid/create_lonlat_grid.c | 4 ++++ .../tools/make_hgrid/make_hgrid.c | 9 +++----- .../tools/make_solo_mosaic/get_contact.c | 3 +++ .../tools/make_solo_mosaic/get_contact.h | 3 +++ .../tools/make_solo_mosaic/make_solo_mosaic.c | 3 +++ .../orog_mask_tools.fd/orog.fd/CMakeLists.txt | 1 + sorc/orog_mask_tools.fd/orog.fd/machine.f90 | 14 ++++++++++++ sorc/orog_mask_tools.fd/orog.fd/machine.h | 11 ---------- .../orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f | 6 ++--- sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 | 4 ++-- sorc/orog_mask_tools.fd/orog.fd/resevod.h | 7 ------ 47 files changed, 160 insertions(+), 127 deletions(-) create mode 100644 sorc/orog_mask_tools.fd/orog.fd/machine.f90 delete mode 100644 sorc/orog_mask_tools.fd/orog.fd/machine.h delete mode 100644 sorc/orog_mask_tools.fd/orog.fd/resevod.h diff --git a/docs/Doxyfile.in b/docs/Doxyfile.in index 3421c45d6..fe5ab4adc 100644 --- a/docs/Doxyfile.in +++ b/docs/Doxyfile.in @@ -130,7 +130,7 @@ INLINE_INHERITED_MEMB = YES # shortest path that makes the file name unique will be used # The default value is: YES. -FULL_PATH_NAMES = NO +FULL_PATH_NAMES = YES # The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path. # Stripping is only done if one of the specified strings matches the left-hand diff --git a/sorc/fre-nctools.fd/shared_lib/affinity.c b/sorc/fre-nctools.fd/shared_lib/affinity.c index ed2360b0d..4f8eb32d7 100644 --- a/sorc/fre-nctools.fd/shared_lib/affinity.c +++ b/sorc/fre-nctools.fd/shared_lib/affinity.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Set or get CPU affinity. +*/ #define _GNU_SOURCE #include diff --git a/sorc/fre-nctools.fd/shared_lib/constant.h b/sorc/fre-nctools.fd/shared_lib/constant.h index 10c98f6d9..3a3bf74d7 100644 --- a/sorc/fre-nctools.fd/shared_lib/constant.h +++ b/sorc/fre-nctools.fd/shared_lib/constant.h @@ -1,3 +1,5 @@ -/** @file */ +/** @file + @brief Set some global constants. +*/ #define RADIUS (6371000.) #define STRING 255 diff --git a/sorc/fre-nctools.fd/shared_lib/create_xgrid.c b/sorc/fre-nctools.fd/shared_lib/create_xgrid.c index 0b850ba40..858c5b5c4 100644 --- a/sorc/fre-nctools.fd/shared_lib/create_xgrid.c +++ b/sorc/fre-nctools.fd/shared_lib/create_xgrid.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Utility routines to create and process exchange grids. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/create_xgrid.h b/sorc/fre-nctools.fd/shared_lib/create_xgrid.h index 585100474..5264eb0c4 100644 --- a/sorc/fre-nctools.fd/shared_lib/create_xgrid.h +++ b/sorc/fre-nctools.fd/shared_lib/create_xgrid.h @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Function declarations for create_xgrid.c. +*/ #ifndef CREATE_XGRID_H_ #define CREATE_XGRID_H_ #ifndef MAXXGRID diff --git a/sorc/fre-nctools.fd/shared_lib/gradient.F90 b/sorc/fre-nctools.fd/shared_lib/gradient.F90 index d41af3035..6fc93f390 100644 --- a/sorc/fre-nctools.fd/shared_lib/gradient.F90 +++ b/sorc/fre-nctools.fd/shared_lib/gradient.F90 @@ -1,3 +1,8 @@ +!> @file +!! +!! @brief Utility routines to calculate gradient. +!! +!! @author Zhi.Liang@noaa.gov module gradient_mod ! ! Zhi Liang diff --git a/sorc/fre-nctools.fd/shared_lib/gradient_c2l.c b/sorc/fre-nctools.fd/shared_lib/gradient_c2l.c index 95544a67b..31f683edd 100644 --- a/sorc/fre-nctools.fd/shared_lib/gradient_c2l.c +++ b/sorc/fre-nctools.fd/shared_lib/gradient_c2l.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Compute gradient terms. +*/ #include #include #include "constant.h" diff --git a/sorc/fre-nctools.fd/shared_lib/gradient_c2l.h b/sorc/fre-nctools.fd/shared_lib/gradient_c2l.h index 93264c01d..6a9132602 100644 --- a/sorc/fre-nctools.fd/shared_lib/gradient_c2l.h +++ b/sorc/fre-nctools.fd/shared_lib/gradient_c2l.h @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Function declarations for gradient_c2l.c +*/ #ifndef GRADIENT_H_ #define GRADIENT_H_ void grad_c2l(const int *nlon, const int *nlat, const double *pin, const double *dx, const double *dy, const double *area, diff --git a/sorc/fre-nctools.fd/shared_lib/grid.F90 b/sorc/fre-nctools.fd/shared_lib/grid.F90 index 262efd14a..9bf45deba 100644 --- a/sorc/fre-nctools.fd/shared_lib/grid.F90 +++ b/sorc/fre-nctools.fd/shared_lib/grid.F90 @@ -1,3 +1,6 @@ +!> @file +!! @brief Utility routines to compute grid parameters such as size and area. +!! module grid_mod use mpp_mod, only : mpp_root_pe diff --git a/sorc/fre-nctools.fd/shared_lib/interp.c b/sorc/fre-nctools.fd/shared_lib/interp.c index 0bcd190e0..1e4381cb7 100644 --- a/sorc/fre-nctools.fd/shared_lib/interp.c +++ b/sorc/fre-nctools.fd/shared_lib/interp.c @@ -1,8 +1,5 @@ -/** @file */ -/* - Copyright 2011 NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ - This program is distributed under the terms of the GNU General Public - License. See the file COPYING contained in this directory +/** @file + @brief Interpolation utilities. */ #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/interp.h b/sorc/fre-nctools.fd/shared_lib/interp.h index 139928291..8abb2639f 100644 --- a/sorc/fre-nctools.fd/shared_lib/interp.h +++ b/sorc/fre-nctools.fd/shared_lib/interp.h @@ -1,16 +1,9 @@ -/** @file */ -/* - Copyright 2011 NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ - This program is distributed under the terms of the GNU General Public - License. See the file COPYING contained in this directory +/** @file + @brief Function declarations for interp.c + @author Zhi.Liang@noaa.gov */ #ifndef INTERP_H_ #define INTERP_H_ -/********************************************************************* - interp.h - This header files contains defition of some interpolation routine (1-D or 2-D). - contact: Zhi.Liang@noaa.gov -*********************************************************************/ void cubic_spline_sp(int size1, int size2, const double *grid1, const double *grid2, const double *data1, double *data2 ); void cubic_spline(int size1, int size2, const double *grid1, const double *grid2, const double *data1, diff --git a/sorc/fre-nctools.fd/shared_lib/mosaic.F90 b/sorc/fre-nctools.fd/shared_lib/mosaic.F90 index 794c8219a..820c5a4b6 100644 --- a/sorc/fre-nctools.fd/shared_lib/mosaic.F90 +++ b/sorc/fre-nctools.fd/shared_lib/mosaic.F90 @@ -1,3 +1,7 @@ +!> @file +!! @brief Read information from the mosaic file. +!! @author Zhi.Liang@noaa.gov +!! module mosaic_mod ! diff --git a/sorc/fre-nctools.fd/shared_lib/mosaic_util.c b/sorc/fre-nctools.fd/shared_lib/mosaic_util.c index 61a5d85db..99868ba71 100644 --- a/sorc/fre-nctools.fd/shared_lib/mosaic_util.c +++ b/sorc/fre-nctools.fd/shared_lib/mosaic_util.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Compute various grid statistics. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/mosaic_util.h b/sorc/fre-nctools.fd/shared_lib/mosaic_util.h index 7ea07bda9..052243aa7 100644 --- a/sorc/fre-nctools.fd/shared_lib/mosaic_util.h +++ b/sorc/fre-nctools.fd/shared_lib/mosaic_util.h @@ -1,10 +1,7 @@ -/** @file */ -/*********************************************************************** - mosaic_util.h - This header file provide some utilities routine that will be used in many tools. - - contact: Zhi.Liang@noaa.gov -***********************************************************************/ +/** @file + @brief Function declarations for mosaic_util.c. + @author Zhi.Liang@noaa.gov +*/ #ifndef MOSAIC_UTIL_H_ #define MOSAIC_UTIL_H_ diff --git a/sorc/fre-nctools.fd/shared_lib/mpp.c b/sorc/fre-nctools.fd/shared_lib/mpp.c index 49fdf614a..87e143850 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp.c +++ b/sorc/fre-nctools.fd/shared_lib/mpp.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief MPI utility routines +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/mpp.h b/sorc/fre-nctools.fd/shared_lib/mpp.h index 01df53e0c..fae05d05f 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp.h +++ b/sorc/fre-nctools.fd/shared_lib/mpp.h @@ -1,11 +1,10 @@ -/** @file */ +/** @file -/********************************************************************* - mpp.h - This header contains subroutine for parallel programming. - only MPI parallel is implemented. - Contact: Zhi.Liang@noaa.gov - ********************************************************************/ + @brief Function declarations for parallel programming. Only + MPI parallel is implemented. + + @author Zhi.Liang@noaa.gov +*/ #ifndef MPP_H_ #define MPP_H_ diff --git a/sorc/fre-nctools.fd/shared_lib/mpp_domain.c b/sorc/fre-nctools.fd/shared_lib/mpp_domain.c index 482701754..722951907 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp_domain.c +++ b/sorc/fre-nctools.fd/shared_lib/mpp_domain.c @@ -1,10 +1,8 @@ -/** @file */ -/* - **** MppDomain.cpp **** - MppDomain package - NOTE: only mpi is implemented here. if needed, shmem version - will be added on in the future. - Contact: Zhi.Liang@noaa.gov +/** @file + @brief MppDomain package + @note Only mpi is implemented here. If needed, shmem version + will be added on in the future. + @author Zhi.Liang@noaa.gov */ #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/mpp_domain.h b/sorc/fre-nctools.fd/shared_lib/mpp_domain.h index d6d18b202..3b95661aa 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp_domain.h +++ b/sorc/fre-nctools.fd/shared_lib/mpp_domain.h @@ -1,14 +1,15 @@ -/** @file */ -/**************************************************************** - mpp_domain.h - This headers define interface to define domain layout, - define domain decomposition and global field to root pe, - some utilities routine to return domain decomposition. - Currently it only used in tools and assume only one domain is created. - If more domains are needed, we may define a struct to hold domain informaiton. - contact: Zhi.Liang@noaa.gov +/** @file + + @brief Headers that define interface, domain layout, + domain decomposition and global field to root pe. + Some routines return domain decomposition. -****************************************************************/ + @note Currently it only used in tools and assumes only one domain is created. + If more domains are needed, we may define a struct to hold domain informaiton. + + @author Zhi.Liang@noaa.gov + +*/ #ifndef MPP_DOMAIN_H_ #define MPP_DOMAIN_H_ #define max(a,b) (a>b ? a:b) diff --git a/sorc/fre-nctools.fd/shared_lib/mpp_io.c b/sorc/fre-nctools.fd/shared_lib/mpp_io.c index 08067caab..a226343d7 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp_io.c +++ b/sorc/fre-nctools.fd/shared_lib/mpp_io.c @@ -1,4 +1,7 @@ -/** @file */ +/** @file + @brief Utility routines to read/write netcdf. + @author Zhi.Liang@noaa.gov +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/mpp_io.h b/sorc/fre-nctools.fd/shared_lib/mpp_io.h index 9905588c7..ae08654b9 100644 --- a/sorc/fre-nctools.fd/shared_lib/mpp_io.h +++ b/sorc/fre-nctools.fd/shared_lib/mpp_io.h @@ -1,12 +1,7 @@ -/** @file */ -/**************************************************************** - mpp_io.h - This headers defines interface to read and write netcdf file. All the data -will be written out from root pe. - - contact: Zhi.Liang@noaa.gov - -****************************************************************/ +/** @file + @brief Define constants and function declarations for mpp_io.c + @author Zhi.Liang@noaa.gov +*/ #ifndef MPP_IO_H_ #define MPP_IO_H_ #include diff --git a/sorc/fre-nctools.fd/shared_lib/read_mosaic.c b/sorc/fre-nctools.fd/shared_lib/read_mosaic.c index 10db07643..582110af1 100644 --- a/sorc/fre-nctools.fd/shared_lib/read_mosaic.c +++ b/sorc/fre-nctools.fd/shared_lib/read_mosaic.c @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Utilities to read the mosaic file. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/read_mosaic.h b/sorc/fre-nctools.fd/shared_lib/read_mosaic.h index 1f6934e9c..11abbcbba 100644 --- a/sorc/fre-nctools.fd/shared_lib/read_mosaic.h +++ b/sorc/fre-nctools.fd/shared_lib/read_mosaic.h @@ -1,4 +1,6 @@ -/** @file */ +/** @file + @brief Function declarations for read_mosaic.c +*/ #ifndef READ_MOSAIC_H_ #define READ_MOSAIC_H_ diff --git a/sorc/fre-nctools.fd/shared_lib/tool_util.c b/sorc/fre-nctools.fd/shared_lib/tool_util.c index c68469717..dbe120cd5 100644 --- a/sorc/fre-nctools.fd/shared_lib/tool_util.c +++ b/sorc/fre-nctools.fd/shared_lib/tool_util.c @@ -1,4 +1,7 @@ -/** @file */ +/** @file + @brief Utility routines used by many tools. + @author Zhi.Liang@noaa.gov +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/shared_lib/tool_util.h b/sorc/fre-nctools.fd/shared_lib/tool_util.h index 288e29501..873bc5ae7 100644 --- a/sorc/fre-nctools.fd/shared_lib/tool_util.h +++ b/sorc/fre-nctools.fd/shared_lib/tool_util.h @@ -1,6 +1,5 @@ /** @file - This header file provide some utilities routine that will be used in many tools. - + @brief Function declarations for tool_util.c @author Zhi.Liang@noaa.gov */ #ifndef TOOL_UTIL_H_ diff --git a/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.c b/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.c index 4767dc1f1..745bb03ab 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.c +++ b/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.c @@ -1,3 +1,6 @@ +/** @file + @brief Routines to perform bilinear interpolation. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.h b/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.h index faead206a..8c4cc3b8e 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.h +++ b/sorc/fre-nctools.fd/tools/fregrid/bilinear_interp.h @@ -1,3 +1,6 @@ +/** @file + @brief Function declarations for bilinear interpolation module. +*/ #ifndef BILINEAR_INTERP_H_ #define BILINEAR_INTERP_H_ void setup_bilinear_interp(int ntiles_in, const Grid_config *grid_in, int ntiles_out, const Grid_config *grid_out, diff --git a/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.c b/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.c index 78c766b16..3ce31af13 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.c +++ b/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.c @@ -1,3 +1,6 @@ +/** @file + @brief Routines to perform conservative interpolation. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.h b/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.h index 18d7bbd8e..3489c6da9 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.h +++ b/sorc/fre-nctools.fd/tools/fregrid/conserve_interp.h @@ -1,3 +1,6 @@ +/** @file + @brief Function declarations for conservative interpolation module. +*/ #ifndef CONSERVE_INTERP_H_ #define CONSERVE_INTERP_H_ #include "globals.h" diff --git a/sorc/fre-nctools.fd/tools/fregrid/fregrid.c b/sorc/fre-nctools.fd/tools/fregrid/fregrid.c index 151813f6b..80f1df331 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/fregrid.c +++ b/sorc/fre-nctools.fd/tools/fregrid/fregrid.c @@ -1,24 +1,10 @@ -/* - This program remaps (scalar or vector) data from the input grid +/** @file + + @brief This program remaps (scalar or vector) data from the input grid to the output grid - AUTHOR: Zhi Liang (Zhi.Liang@noaa.gov) + @author Zhi Liang (Zhi.Liang@noaa.gov) NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - For the full text of the GNU General Public License, - write to: Free Software Foundation, Inc., - 675 Mass Ave, Cambridge, MA 02139, USA. ------------------------------------------------------------------------ */ #include #include diff --git a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c index 199529c55..13434216a 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c +++ b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.c @@ -1,3 +1,6 @@ +/** @file + @brief Utilities for the fregrid program. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.h b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.h index dfd27b07b..42bbf13ba 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.h +++ b/sorc/fre-nctools.fd/tools/fregrid/fregrid_util.h @@ -1,3 +1,6 @@ +/** @file + @brief Function declarations for the fregrid utility module. +*/ #ifndef FREGRID_UTIL_H_ #define FREGRID_UTIL_H_ #include "globals.h" diff --git a/sorc/fre-nctools.fd/tools/fregrid/globals.h b/sorc/fre-nctools.fd/tools/fregrid/globals.h index 5ed598d83..a4ed1cb88 100644 --- a/sorc/fre-nctools.fd/tools/fregrid/globals.h +++ b/sorc/fre-nctools.fd/tools/fregrid/globals.h @@ -1,3 +1,6 @@ +/** @file + @brief Define global constants and type definitions. +*/ #ifndef GLOBALS_H_ #define GLOBALS_H_ #include diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_conformal_cubic_grid.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_conformal_cubic_grid.c index 4e9c9dea9..364cf2d62 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_conformal_cubic_grid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_conformal_cubic_grid.c @@ -1,3 +1,6 @@ +/** @file + @brief Create conformal cubic grids. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c index 9d4b68b70..078e7f257 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_gnomonic_cubic_grid.c @@ -1,3 +1,6 @@ +/** @file + @brief Create gnomonic cubic grids. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c index 9d08aac9d..7ff06e218 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_grid_from_file.c @@ -1,7 +1,5 @@ -/* - Copyright 2011 NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ - This program is distributed under the terms of the GNU General Public - License. See the file COPYING contained in this directory +/** @file + @brief Create grid from a file. */ #include #include diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_hgrid.h b/sorc/fre-nctools.fd/tools/make_hgrid/create_hgrid.h index 599fc1aab..2b807b3f1 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_hgrid.h +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_hgrid.h @@ -1,12 +1,12 @@ -/******************************************************************************* - create_hgrid.h +/** @file + This header file provide interface to create different types of horizontal - grid. geographical grid location, cell length, cell area and rotation + grid. Geographical grid location, cell length, cell area and rotation angle are returned. All the returned data are on supergrid. - contact: Zhi.Liang@noaa.gov + @author Zhi.Liang@noaa.gov -*******************************************************************************/ +*/ #ifndef CREATE_HGRID_H_ #define CREATE_HGRID_H_ void create_regular_lonlat_grid( int *nxbnds, int *nybnds, double *xbnds, double *ybnds, diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/create_lonlat_grid.c b/sorc/fre-nctools.fd/tools/make_hgrid/create_lonlat_grid.c index 6b7a0a1aa..665cf5d94 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/create_lonlat_grid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/create_lonlat_grid.c @@ -1,3 +1,7 @@ +/** @file + @brief Routines to create regular lat/lon, spectral, tripolar + and f-plane grids. +*/ #include #include #include diff --git a/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c b/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c index ccce0aec9..7543ba14b 100644 --- a/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c +++ b/sorc/fre-nctools.fd/tools/make_hgrid/make_hgrid.c @@ -1,11 +1,8 @@ -/* - Copyright 2011 NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ - This program is distributed under the terms of the GNU General Public - License. See the file COPYING contained in this directory +/** @file - This program generates various types of horizontal grids in netCDF file format + @brief This program generates various types of horizontal grids in netCDF file format - AUTHOR: Zhi Liang (Zhi.Liang@noaa.gov) + @author Zhi Liang (Zhi.Liang@noaa.gov) NOAA Geophysical Fluid Dynamics Lab, Princeton, NJ */ #include diff --git a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c index 2923b7180..1850e2e7d 100644 --- a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c +++ b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.c @@ -1,3 +1,6 @@ +/** @file + @brief Determine contacts between tiles. +*/ #include #include #include "mosaic_util.h" diff --git a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.h b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.h index 120d24634..3ae5f6917 100644 --- a/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.h +++ b/sorc/fre-nctools.fd/tools/make_solo_mosaic/get_contact.h @@ -1,3 +1,6 @@ +/** @file + @brief Function declarations for computing contacts between tiles. +*/ #ifndef GET_CONTACT_ #define GET_CONTACT_ /********************************************************************** diff --git a/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c b/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c index f78ec54a5..2321e0546 100644 --- a/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c +++ b/sorc/fre-nctools.fd/tools/make_solo_mosaic/make_solo_mosaic.c @@ -1,3 +1,6 @@ +/** @file + @brief Generate mosaic information between tiles. +*/ #include #include #include diff --git a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt index 5e38c7a35..9ed6f78cc 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt +++ b/sorc/orog_mask_tools.fd/orog.fd/CMakeLists.txt @@ -1,4 +1,5 @@ set(fortran_src + machine.f90 mtnlm7_oclsm.f netcdf_io.F90) diff --git a/sorc/orog_mask_tools.fd/orog.fd/machine.f90 b/sorc/orog_mask_tools.fd/orog.fd/machine.f90 new file mode 100644 index 000000000..134331577 --- /dev/null +++ b/sorc/orog_mask_tools.fd/orog.fd/machine.f90 @@ -0,0 +1,14 @@ +!> @file +!! @brief Machine dependant constants + module machine +! + integer kind_io2,kind_io4,kind_io8 + integer kind_evod +! + parameter (kind_io2 =2) + parameter (kind_io4 =4) + parameter (kind_io8 =8) + parameter (kind_evod=8) + real(kind=kind_evod) mprec !< machine precision to restrict dep + parameter(mprec = 1.e-12 ) + end module machine diff --git a/sorc/orog_mask_tools.fd/orog.fd/machine.h b/sorc/orog_mask_tools.fd/orog.fd/machine.h deleted file mode 100644 index a9316ed4b..000000000 --- a/sorc/orog_mask_tools.fd/orog.fd/machine.h +++ /dev/null @@ -1,11 +0,0 @@ -cc Machine dependant constants (*j*) added io2 20051101 -cc - integer kind_io2,kind_io4,kind_io8 - integer kind_evod -cc - parameter (kind_io2 =2) - parameter (kind_io4 =4) - parameter (kind_io8 =8) - parameter (kind_evod=8) - real(kind=kind_evod) mprec ! machine precision to restrict dep - parameter(mprec = 1.e-12 ) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f index 2f6da24ca..98a0df836 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f @@ -163,8 +163,8 @@ SUBROUTINE TERSUB(IMN,JMN,IM,JM,NM,NR,NF0,NF1,NW,EFAC,BLAT, & OUTGRID,INPUTOROG) !jaa use ipfort + use machine implicit none - include 'machine.h' include 'netcdf.inc' C integer :: IMN,JMN,IM,JM,NW @@ -3895,10 +3895,8 @@ subroutine read_g(glob,ITOPO) ! --- tiles in the output working dir. The glob array can not be ! --- acted on with grads, but the tiles can be if lat/lon are reduced slightly cc + use machine implicit none -cc - include 'machine.h' - include 'resevod.h' cc integer*2 glob(360*120,180*120) cc diff --git a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 index aecc63dc2..f3c188434 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 +++ b/sorc/orog_mask_tools.fd/orog.fd/netcdf_io.F90 @@ -1,6 +1,6 @@ !> @file -!------------------------------------------------------------------------------- -! write out data in netcdf format +!! @brief Write out data in netcdf format +!! subroutine write_netcdf(im, jm, slm, land_frac, oro, orf, hprime, ntiles, tile, geolon, geolat, lon, lat) implicit none integer, intent(in):: im, jm, ntiles, tile diff --git a/sorc/orog_mask_tools.fd/orog.fd/resevod.h b/sorc/orog_mask_tools.fd/orog.fd/resevod.h deleted file mode 100644 index 5943e28be..000000000 --- a/sorc/orog_mask_tools.fd/orog.fd/resevod.h +++ /dev/null @@ -1,7 +0,0 @@ - integer latg,latg2 - integer lonf - real(kind=kind_evod) rerth -cc - parameter ( lonf = 192 ) - parameter ( latg = 94 ) - parameter ( latg2 = latg/2 ) From 2300658a0ffe0cb82e2b0dbc47999a2ee3c8df98 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 07:27:39 -0700 Subject: [PATCH 03/47] updated workflow --- .github/workflows/build_and_test.yml | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 17007f467..520e73c68 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -16,18 +16,21 @@ jobs: sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config sudo apt-get install libpng-dev sudo apt-get install libjpeg-dev - - - name: checkout-esmf - uses: actions/checkout@v2 + sudo apt-get install wget + - name: cache-esmf + id: cache-esmf + uses: actions/cache@v2 with: - repository: esmf-org/esmf - path: esmf - ref: ESMF_8_0_1 - + path: ~/esmf + key: esmf-${{ runner.os }}-8.0.1 + - name: build-esmf + if: steps.cache-esmf.outputs.cache-hit != 'true' run: | - export ESMF_DIR=`pwd`/esmf - cd esmf + export ESMF_DIR=`pwd`/esmf-ESMF_8_0_1 + wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l + tar zxf ESMF_8_0_1.tar.gz && ls -l + cd esmf-ESMF_8_0_1 export ESMF_COMM=mpich3 export ESMF_INSTALL_BINDIR=bin export ESMF_INSTALL_LIBDIR=lib @@ -78,6 +81,7 @@ jobs: - name: build-ufs-utils run: | export ESMFMKFILE=~/lib/esmf.mk + export ESMF_DIR=`pwd`/esmf-ESMF_8_0_1 cd ufs_utils mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH=~ From 699d5bb3593730a03618ffe45a336339d1ea7290 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 07:51:48 -0700 Subject: [PATCH 04/47] now testing esmf cache --- .github/workflows/build_and_test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 520e73c68..41200ee51 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -68,6 +68,7 @@ jobs: - name: build-nceplibs run: | export ESMFMKFILE=~/lib/esmf.mk + wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs mkdir build && cd build cmake .. -DCMAKE_INSTALL_PREFIX=~ -DFLAT=ON From da42732d23ce1fcd14c201fea114a00c226b75de Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 08:10:41 -0700 Subject: [PATCH 05/47] trying to fix esmf caching --- .github/workflows/build_and_test.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 41200ee51..3f1d6d569 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -22,7 +22,7 @@ jobs: uses: actions/cache@v2 with: path: ~/esmf - key: esmf-${{ runner.os }}-8.0.1 + key: esmf-${{ runner.os }}-8.0.1-1 - name: build-esmf if: steps.cache-esmf.outputs.cache-hit != 'true' @@ -36,7 +36,7 @@ jobs: export ESMF_INSTALL_LIBDIR=lib export ESMF_INSTALL_MODDIR=mod export ESMF_COMPILER=gfortran - export ESMF_INSTALL_PREFIX=~ + export ESMF_INSTALL_PREFIX=~/esmf export ESMF_NETCDF=split export ESMF_NETCDF_INCLUDE=/usr/include export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu @@ -67,7 +67,7 @@ jobs: - name: build-nceplibs run: | - export ESMFMKFILE=~/lib/esmf.mk + export ESMFMKFILE=~/esmf/lib/esmf.mk wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs mkdir build && cd build From ed23b8fa078c4d30be3877c3c3d851da53fa8f7c Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 11:38:57 -0700 Subject: [PATCH 06/47] working on finding esmf --- .github/workflows/build_and_test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 3f1d6d569..9f74110d8 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -22,12 +22,12 @@ jobs: uses: actions/cache@v2 with: path: ~/esmf - key: esmf-${{ runner.os }}-8.0.1-1 + key: esmf-${{ runner.os }}-8.0.1-2 - name: build-esmf if: steps.cache-esmf.outputs.cache-hit != 'true' run: | - export ESMF_DIR=`pwd`/esmf-ESMF_8_0_1 + export ESMF_DIR=~/esmf-ESMF_8_0_1 wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l tar zxf ESMF_8_0_1.tar.gz && ls -l cd esmf-ESMF_8_0_1 From 4f24e73369e9e51b3123d8b5a16c3ba1a3491011 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 12:05:24 -0700 Subject: [PATCH 07/47] working on finding esmf --- .github/workflows/build_and_test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 9f74110d8..a3cda70b1 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -27,6 +27,8 @@ jobs: - name: build-esmf if: steps.cache-esmf.outputs.cache-hit != 'true' run: | + set -x + pushd ~ export ESMF_DIR=~/esmf-ESMF_8_0_1 wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l tar zxf ESMF_8_0_1.tar.gz && ls -l From 0cd1796ad69755fef33bf94af2236b76bebbccf6 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 12:29:11 -0700 Subject: [PATCH 08/47] working on finding esmf --- .github/workflows/build_and_test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index a3cda70b1..abf91d68f 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -83,8 +83,8 @@ jobs: - name: build-ufs-utils run: | - export ESMFMKFILE=~/lib/esmf.mk - export ESMF_DIR=`pwd`/esmf-ESMF_8_0_1 + export ESMFMKFILE=~/esmf/lib/esmf.mk + export ESMF_DIR=~/esmf-ESMF_8_0_1 cd ufs_utils mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH=~ From 3e8ae5dcaf950ddec1aaa09159b274d4b799534a Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 12:48:28 -0700 Subject: [PATCH 09/47] testing esmf cache --- .github/workflows/build_and_test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index abf91d68f..2c49d540e 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -69,6 +69,7 @@ jobs: - name: build-nceplibs run: | + set -x export ESMFMKFILE=~/esmf/lib/esmf.mk wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs From c3161bf5ff2150ade2f7b1a61422c46dab3fb326 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Tue, 9 Feb 2021 14:36:53 -0700 Subject: [PATCH 10/47] attempted removal of setting ESMF_DIR --- .github/workflows/build_and_test.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 3f1d6d569..dd2aa88fb 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -82,7 +82,6 @@ jobs: - name: build-ufs-utils run: | export ESMFMKFILE=~/lib/esmf.mk - export ESMF_DIR=`pwd`/esmf-ESMF_8_0_1 cd ufs_utils mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH=~ From 989878997622c2301195ab7c7df733d4f2fff5d2 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:00:22 -0700 Subject: [PATCH 11/47] starting to use cacheing on jasper build --- .github/workflows/build_and_test.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 53799c772..1f9af9ba1 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -54,6 +54,9 @@ jobs: - name: build-jasper run: | + set -x + pwd + wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l cd jasper mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ From 884a8fe5a4de15e227c32bb5685dcfddf85de329 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:05:23 -0700 Subject: [PATCH 12/47] starting to use cacheing on jasper build --- .github/workflows/build_and_test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 1f9af9ba1..04bd14427 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -55,8 +55,8 @@ jobs: - name: build-jasper run: | set -x - pwd - wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l + pwd + wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l cd jasper mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ From 61ba3f181c96db3e0b25d07d57e03c2d6bc2ec1b Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:07:18 -0700 Subject: [PATCH 13/47] starting to use cacheing on jasper build --- .github/workflows/build_and_test.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 04bd14427..915f68c14 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -57,6 +57,8 @@ jobs: set -x pwd wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l + tar zxf version-2.0.22.tar.gz + ls -l cd jasper mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ From 83c990c7f3fab361e202779b953cfc1674948556 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:08:24 -0700 Subject: [PATCH 14/47] new line weirdness --- .github/workflows/build_and_test.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 915f68c14..04bd14427 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -57,8 +57,6 @@ jobs: set -x pwd wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l - tar zxf version-2.0.22.tar.gz - ls -l cd jasper mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ From 5452d701e5bb3fa61769fc1007a4f8f83ce884af Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:09:02 -0700 Subject: [PATCH 15/47] new line weirdness --- .github/workflows/build_and_test.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 04bd14427..596d33a0b 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -57,6 +57,7 @@ jobs: set -x pwd wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l + tar zxf version-2.0.22.tar.gz && ls -l cd jasper mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ From 43a7e9cd401e4b16674ae7d2f46ff430a4682356 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:13:44 -0700 Subject: [PATCH 16/47] new line weirdness --- .github/workflows/build_and_test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 596d33a0b..e4eb3e495 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -58,7 +58,7 @@ jobs: pwd wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l tar zxf version-2.0.22.tar.gz && ls -l - cd jasper + cd jasper-version-2.0.22 mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~ make -j2 From 9ced94eaf8780d45ba62d55d9165255fb41b5a0a Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:24:15 -0700 Subject: [PATCH 17/47] cacheing jasper build --- .github/workflows/build_and_test.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index e4eb3e495..cc5cb4d23 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -44,15 +44,15 @@ jobs: export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu make -j2 make install - - - name: checkout-jasper - uses: actions/checkout@v2 + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 with: - repository: jasper-software/jasper - path: jasper - ref: version-2.0.22 + path: ~/jasper + key: jasper-${{ runner.os }}-2.0.22 - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' run: | set -x pwd @@ -60,7 +60,7 @@ jobs: tar zxf version-2.0.22.tar.gz && ls -l cd jasper-version-2.0.22 mkdir build-jasper && cd build-jasper - cmake .. -DCMAKE_INSTALL_PREFIX=~ + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper make -j2 make install From 93552a9653307b4510382a6b408f82f8e95938a0 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:31:24 -0700 Subject: [PATCH 18/47] cacheing jasper build --- .github/workflows/build_and_test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index cc5cb4d23..35faea353 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -91,7 +91,7 @@ jobs: export ESMFMKFILE=~/esmf/lib/esmf.mk cd ufs_utils mkdir build && cd build - cmake .. -DCMAKE_PREFIX_PATH=~ + cmake .. -DCMAKE_PREFIX_PATH=~;~/jasper make -j2 From 5f1cd9c1c785247de1470a0b62049bfa1be21c80 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:37:23 -0700 Subject: [PATCH 19/47] cacheing jasper build still --- .github/workflows/build_and_test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 35faea353..fee5d4914 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -78,7 +78,7 @@ jobs: wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs mkdir build && cd build - cmake .. -DCMAKE_INSTALL_PREFIX=~ -DFLAT=ON + cmake .. -DCMAKE_INSTALL_PREFIX=~;~/jasper -DFLAT=ON make -j2 - name: checkout-ufs-utils From 18fc87444a768e93310f9858a8ce01ef216e301f Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:41:53 -0700 Subject: [PATCH 20/47] cacheing jasper build still --- .github/workflows/build_and_test.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index fee5d4914..875b102f2 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -78,7 +78,7 @@ jobs: wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs mkdir build && cd build - cmake .. -DCMAKE_INSTALL_PREFIX=~;~/jasper -DFLAT=ON + cmake .. -DCMAKE_INSTALL_PREFIX='~;~/jasper' -DFLAT=ON make -j2 - name: checkout-ufs-utils @@ -91,7 +91,7 @@ jobs: export ESMFMKFILE=~/esmf/lib/esmf.mk cd ufs_utils mkdir build && cd build - cmake .. -DCMAKE_PREFIX_PATH=~;~/jasper + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' make -j2 From 1273c749f603de07d43b24b3a3e376b089f7048e Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 07:52:56 -0700 Subject: [PATCH 21/47] switched to nceplibs 1.3.0 --- .github/workflows/build_and_test.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index 875b102f2..ae6ff6c34 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -69,7 +69,7 @@ jobs: with: repository: NOAA-EMC/NCEPLIBS path: nceplibs - ref: v1.2.0 + ref: v1.3.0 - name: build-nceplibs run: | From 09186247d19c9b5614aaa4a3f237cbad69df1ad7 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 08:13:25 -0700 Subject: [PATCH 22/47] adding new workflow --- .github/workflows/build_and_test.yml | 1 - ...smf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 102 ++++++++++++++++++ 2 files changed, 102 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/build_and_test.yml index ae6ff6c34..a72a0e553 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/build_and_test.yml @@ -69,7 +69,6 @@ jobs: with: repository: NOAA-EMC/NCEPLIBS path: nceplibs - ref: v1.3.0 - name: build-nceplibs run: | diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml new file mode 100644 index 000000000..f8020a3f7 --- /dev/null +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -0,0 +1,102 @@ +name: esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0 +on: [push, pull_request] + +jobs: + build: + runs-on: ubuntu-20.04 + env: + FC: gfortran-9 + CC: gcc-9 + + steps: + - name: install-dependencies + run: | + sudo apt-get update + sudo apt-get install libmpich-dev + sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config + sudo apt-get install libpng-dev + sudo apt-get install libjpeg-dev + sudo apt-get install wget + - name: cache-esmf + id: cache-esmf + uses: actions/cache@v2 + with: + path: ~/esmf + key: esmf-${{ runner.os }}-8.0.1-2 + + - name: build-esmf + if: steps.cache-esmf.outputs.cache-hit != 'true' + run: | + set -x + pushd ~ + export ESMF_DIR=~/esmf-ESMF_8_0_1 + wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l + tar zxf ESMF_8_0_1.tar.gz && ls -l + cd esmf-ESMF_8_0_1 + export ESMF_COMM=mpich3 + export ESMF_INSTALL_BINDIR=bin + export ESMF_INSTALL_LIBDIR=lib + export ESMF_INSTALL_MODDIR=mod + export ESMF_COMPILER=gfortran + export ESMF_INSTALL_PREFIX=~/esmf + export ESMF_NETCDF=split + export ESMF_NETCDF_INCLUDE=/usr/include + export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + make -j2 + make install + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/jasper + key: jasper-${{ runner.os }}-2.0.22 + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + set -x + pwd + wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l + tar zxf version-2.0.22.tar.gz && ls -l + cd jasper-version-2.0.22 + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper + make -j2 + make install + + - name: checkout-nceplibs + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS + path: nceplibs + ref: v1.3.0 + + - name: build-nceplibs + run: | + set -x + export ESMFMKFILE=~/esmf/lib/esmf.mk + wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null + tar zxf v1.3.0.tar.gz && ls -l + cd nceplibs + mkdir build && cd build + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' -DCMAKE_INSTALL_PREFIX='~/nceplibs' -DFLAT=ON + make -j2 + + - name: checkout-ufs-utils + uses: actions/checkout@v2 + with: + path: ufs_utils + + - name: build-ufs-utils + run: | + export ESMFMKFILE=~/esmf/lib/esmf.mk + cd ufs_utils + mkdir build && cd build + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper;~/nceplibs' + make -j2 + + + + + + From edb5b50c96074602799ff3f4f1d8624adaa6d9ab Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 08:18:12 -0700 Subject: [PATCH 23/47] more work on workflows --- ...est.yml => esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml} | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) rename .github/workflows/{build_and_test.yml => esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml} (93%) diff --git a/.github/workflows/build_and_test.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml similarity index 93% rename from .github/workflows/build_and_test.yml rename to .github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml index a72a0e553..4eeebdc72 100644 --- a/.github/workflows/build_and_test.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml @@ -1,4 +1,4 @@ -name: Build and Test +name: esmf-8.0.1_jasper-2.0.22_nceplibs-develop on: [push, pull_request] jobs: @@ -74,10 +74,9 @@ jobs: run: | set -x export ESMFMKFILE=~/esmf/lib/esmf.mk - wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null && ls -l cd nceplibs mkdir build && cd build - cmake .. -DCMAKE_INSTALL_PREFIX='~;~/jasper' -DFLAT=ON + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' -DCMAKE_INSTALL_PREFIX='~' -DFLAT=ON make -j2 - name: checkout-ufs-utils From 42a527aadfa8fa26e44cf7e5dd9685b1faa1dbfb Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 08:30:17 -0700 Subject: [PATCH 24/47] turning on cache for nceplibs-1.3.0 build --- .../esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml index f8020a3f7..646516abf 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -63,21 +63,21 @@ jobs: cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper make -j2 make install - - - name: checkout-nceplibs - uses: actions/checkout@v2 + - name: cache-nceplibs + id: cache-nceplibs + uses: actions/cache@v2 with: - repository: NOAA-EMC/NCEPLIBS - path: nceplibs - ref: v1.3.0 + path: ~/nceplibs + key: nceplibs-${{ runner.os }}-1.3.0 - name: build-nceplibs + if: steps.cache-nceplibs.outputs.cache-hit != 'true' run: | set -x export ESMFMKFILE=~/esmf/lib/esmf.mk wget https://github.com/NOAA-EMC/NCEPLIBS/archive/v1.3.0.tar.gz &> /dev/null tar zxf v1.3.0.tar.gz && ls -l - cd nceplibs + cd NCEPLIBS-1.3.0 mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' -DCMAKE_INSTALL_PREFIX='~/nceplibs' -DFLAT=ON make -j2 From 42205b8050808e08adad0ffa336871b95085657b Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Wed, 10 Feb 2021 08:42:07 -0700 Subject: [PATCH 25/47] clean up and test caching --- .../workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml index 646516abf..ec4da9073 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -30,8 +30,8 @@ jobs: set -x pushd ~ export ESMF_DIR=~/esmf-ESMF_8_0_1 - wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l - tar zxf ESMF_8_0_1.tar.gz && ls -l + wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null + tar zxf ESMF_8_0_1.tar.gz cd esmf-ESMF_8_0_1 export ESMF_COMM=mpich3 export ESMF_INSTALL_BINDIR=bin @@ -56,8 +56,8 @@ jobs: run: | set -x pwd - wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l - tar zxf version-2.0.22.tar.gz && ls -l + wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null + tar zxf version-2.0.22.tar.gz cd jasper-version-2.0.22 mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper From ea2bce4d87088a1d82fca62d03ed5f44b0f3a959 Mon Sep 17 00:00:00 2001 From: Kyle Gerheiser <3209794+kgerheiser@users.noreply.github.com> Date: Thu, 11 Feb 2021 09:46:43 -0500 Subject: [PATCH 26/47] Fix problem with orog program when using MacOS Rearrange the allocation of the "hgt_1d" array in mtnlm7_oclsm.f to fix errors on MacOS. Add matching deallocate statement. Fix subroutine name in comment. Fixes #243 #245 #277 --- sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f index 98a0df836..88e0dd1b6 100644 --- a/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f +++ b/sorc/orog_mask_tools.fd/orog.fd/mtnlm7_oclsm.f @@ -1772,7 +1772,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,land_frac,VAR,VAR4, implicit none real, parameter :: D2R = 3.14159265358979/180. integer, parameter :: MAXSUM=20000000 - real hgt_1d(MAXSUM) + real, dimension(:), allocatable :: hgt_1d integer IM, JM, IMN, JMN real GLAT(JMN), GLON(IMN) INTEGER ZAVG(IMN,JMN),ZSLM(IMN,JMN) @@ -1797,6 +1797,7 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,land_frac,VAR,VAR4, ! --- 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)) C---- GLOBAL XLAT AND XLON ( DEGREE ) C JM1 = JM - 1 @@ -1892,9 +1893,9 @@ SUBROUTINE MAKEMT2(ZAVG,ZSLM,ORO,SLM,land_frac,VAR,VAR4, ENDDO ENDDO !$omp end parallel do - WRITE(6,*) "! MAKEMT ORO SLM VAR VAR4 DONE" + WRITE(6,*) "! MAKEMT2 ORO SLM VAR VAR4 DONE" C - + deallocate(hgt_1d) RETURN END From 540cdf1bc6a648a230cd4011eeaa0b4236175fcd Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Thu, 11 Feb 2021 09:58:33 -0700 Subject: [PATCH 27/47] Start to list and describe all utilities in user_guide.md Also include some documentation clean up. Part of #217 Part of #191 Fixes #219 Fixes #214 Fixes #213 Fixes #268 Fixes #254 --- CMakeLists.txt | 1 + build_all.sh | 7 + docs/user_guide.md | 55 +++++- sorc/chgres_cube.fd/CMakeLists.txt | 4 + sorc/fre-nctools.fd/shared_lib/COPYING | 159 ------------------ .../{readme.md => fvcom_readme.md} | 2 + ...ERS_GUIDE => global_chgres_users_guide.md} | 2 +- 7 files changed, 68 insertions(+), 162 deletions(-) delete mode 100644 sorc/fre-nctools.fd/shared_lib/COPYING rename sorc/fvcom_tools.fd/{readme.md => fvcom_readme.md} (95%) rename sorc/global_chgres.fd/{USERS_GUIDE => global_chgres_users_guide.md} (98%) diff --git a/CMakeLists.txt b/CMakeLists.txt index 4827e5e8e..9677e6c2a 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -14,6 +14,7 @@ list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") # User options. option(OPENMP "use OpenMP threading" ON) +option(ENABLE_DOCS "Enable generation of doxygen-based documentation." OFF) if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") message(STATUS "Setting build type to 'Release' as none was specified.") diff --git a/build_all.sh b/build_all.sh index 27181e98b..85cfce9f9 100755 --- a/build_all.sh +++ b/build_all.sh @@ -1,4 +1,11 @@ #! /usr/bin/env bash +# +# This build script is only used on NOAA WCOSS systems. All other +# users should set module files as needed, and build directly with +# CMake. +# +# George Gayno + set -eux target=${target:-"NULL"} diff --git a/docs/user_guide.md b/docs/user_guide.md index 591bf2724..71a33f9e5 100644 --- a/docs/user_guide.md +++ b/docs/user_guide.md @@ -1,9 +1,60 @@ @mainpage -## UFS_UTILS +# UFS_UTILS Utilities for the NCEP models. This is part of the [NCEPLIBS](https://github.com/NOAA-EMC/NCEPLIBS) project. -The UFS_UTILS code here: https://github.com/NOAA-EMC/UFS_UTILS. +The UFS_UTILS code can be found here: +https://github.com/NOAA-EMC/UFS_UTILS. + +## The Utilities + +- chgres_cube - Creates cold start initial conditions for FV3 model + runs. + +- emcsfc_ice_blend - Blends National Ice Center sea ice cover and EMC + sea ice concentration data to create a global sea ice analysis used + to update the GFS once per day. + +- emcsfc_snow2mdl - Blends National Ice Center snow cover and Air + Force snow depth data to create a global depth analysis used to + update the GFS snow field once per day. + +- fre-nctools - Tools to remap data; and to create the geo-reference + fields (latitude, longitude, etc.) for an FV3 grid. + +- fvcom_tools - - Replaces lake surface and lake ice temperature along + with aerial ice concentration generated from the Great Lakes + Operational Forecast System (GLOFS) in an FV3 surface restart + file. See [fvcom documentation](@ref fvcom_readme). + +- global_chgres - Creates cold start initial conditions for FV3 model + runs. Deprecated by the chgres_cube utility. See [global_chgres + documentation](@ref global_chgres_users_guide). + +- global_cycle - Updates the GFS surface conditions using external + snow and sea ice analyses. Updates monthly climatological fields + such as plant greenness fraction and albedo. Runs as part of the GFS + and GDAS cycles. + +- grid_tools - Utilities to filter topography, to create regional + extended Schmidt gnomonic grids, and to compute the equivalent + global resolution of a regional grid. + +- nst_tf_chg - Initializes the reference temperature used by the NSST + model. + +- orog_mask_tools - Utilities to create land mask, terrain and gravity + wave drag fields; set lake fraction and depth; creates an inland + land mask. + +- sfc_climo_gen - Creates surface climatological fields, such as + vegetation type and albedo, for an FV3 grid. + +- vcoord_gen - Generates hybrid coordinate parameters from fields such + as surface pressure, model top and the number of vertical + levels. Outputs the 'ak' and 'bk' parameters used by the forecast + model to define the hybrid levels. + diff --git a/sorc/chgres_cube.fd/CMakeLists.txt b/sorc/chgres_cube.fd/CMakeLists.txt index dd7dc4a6c..2d5350738 100644 --- a/sorc/chgres_cube.fd/CMakeLists.txt +++ b/sorc/chgres_cube.fd/CMakeLists.txt @@ -1,3 +1,7 @@ +# This is the CMake build file for the chgres_cube utility in the UFS_UTILS package. +# +# George Gayno, Mark Potts + set(fortran_src atmosphere.F90 chgres.F90 diff --git a/sorc/fre-nctools.fd/shared_lib/COPYING b/sorc/fre-nctools.fd/shared_lib/COPYING deleted file mode 100644 index 93a221957..000000000 --- a/sorc/fre-nctools.fd/shared_lib/COPYING +++ /dev/null @@ -1,159 +0,0 @@ -TERMS AND CONDITIONS -0. Definitions. - -“This License” refers to version 3 of the GNU General Public License. - -“Copyright” also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. - -“The Program” refers to any copyrightable work licensed under this License. Each licensee is addressed as “you”. “Licensees” and “recipients” may be individuals or organizations. - -To “modify” a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a “modified version” of the earlier work or a work “based on” the earlier work. - -A “covered work” means either the unmodified Program or a work based on the Program. - -To “propagate” a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. - -To “convey” a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. - -An interactive user interface displays “Appropriate Legal Notices” to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. -1. Source Code. - -The “source code” for a work means the preferred form of the work for making modifications to it. “Object code” means any non-source form of a work. - -A “Standard Interface” means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. - -The “System Libraries” of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A “Major Component”, in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. - -The “Corresponding Source” for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. - -The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. - -The Corresponding Source for a work in source code form is that same work. -2. Basic Permissions. - -All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. - -You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. - -Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. -3. Protecting Users' Legal Rights From Anti-Circumvention Law. - -No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. - -When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. -4. Conveying Verbatim Copies. - -You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. - -You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. -5. Conveying Modified Source Versions. - -You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified it, and giving a relevant date. - b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to “keep intact all notices”. - c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. - d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. - -A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an “aggregate” if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. -6. Conveying Non-Source Forms. - -You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: - - a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. - b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. - c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. - d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. - e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. - -A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. - -A “User Product” is either (1) a “consumer product”, which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, “normally used” refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. - -“Installation Information” for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. - -If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). - -The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. - -Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. -7. Additional Terms. - -“Additional permissions” are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. - -When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. - -Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or - b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or - c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or - d) Limiting the use for publicity purposes of names of licensors or authors of the material; or - e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or - f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. - -All other non-permissive additional terms are considered “further restrictions” within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. - -If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. - -Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. -8. Termination. - -You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). - -However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. - -Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. - -Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. -9. Acceptance Not Required for Having Copies. - -You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. -10. Automatic Licensing of Downstream Recipients. - -Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. - -An “entity transaction” is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. - -You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. -11. Patents. - -A “contributor” is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's “contributor version”. - -A contributor's “essential patent claims” are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, “control” includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. - -Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. - -In the following three paragraphs, a “patent license” is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To “grant” such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. - -If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. “Knowingly relying” means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. - -If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. - -A patent license is “discriminatory” if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. - -Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. -12. No Surrender of Others' Freedom. - -If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. -13. Use with the GNU Affero General Public License. - -Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. -14. Revised Versions of this License. - -The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License “or any later version” applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. - -If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. - -Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. -15. Disclaimer of Warranty. - -THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM “AS IS” WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. -16. Limitation of Liability. - -IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. -17. Interpretation of Sections 15 and 16. - -If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. diff --git a/sorc/fvcom_tools.fd/readme.md b/sorc/fvcom_tools.fd/fvcom_readme.md similarity index 95% rename from sorc/fvcom_tools.fd/readme.md rename to sorc/fvcom_tools.fd/fvcom_readme.md index 252c7ddf0..0eae64652 100644 --- a/sorc/fvcom_tools.fd/readme.md +++ b/sorc/fvcom_tools.fd/fvcom_readme.md @@ -1,3 +1,5 @@ +@brief replaces lake surface and lake ice temperature @anchor fvcom_readme + **fvcom_to_FV3.exe** **Introduction:** diff --git a/sorc/global_chgres.fd/USERS_GUIDE b/sorc/global_chgres.fd/global_chgres_users_guide.md similarity index 98% rename from sorc/global_chgres.fd/USERS_GUIDE rename to sorc/global_chgres.fd/global_chgres_users_guide.md index 5ec2542a6..f4fd94187 100755 --- a/sorc/global_chgres.fd/USERS_GUIDE +++ b/sorc/global_chgres.fd/global_chgres_users_guide.md @@ -1,4 +1,4 @@ - HOW TO CONVERT A SURFACE RESTART FILE +@brief HOW TO CONVERT A SURFACE RESTART FILE @anchor global_chgres_users_guide 1.0 INTRODUCTION From f955ba1f0217cd48fda4e9fc4795e9523456dc6a Mon Sep 17 00:00:00 2001 From: Kyle Gerheiser <3209794+kgerheiser@users.noreply.github.com> Date: Thu, 11 Feb 2021 14:43:54 -0500 Subject: [PATCH 28/47] Create macOS Action Resolves #243. --- ...smf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 60 ++++++++++++++----- ...f-8.0.1_jasper-2.0.22_nceplibs-develop.yml | 44 ++++++++++---- 2 files changed, 79 insertions(+), 25 deletions(-) diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml index ec4da9073..efb87d9cd 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -3,20 +3,38 @@ on: [push, pull_request] jobs: build: - runs-on: ubuntu-20.04 + runs-on: ${{ matrix.os }} env: - FC: gfortran-9 CC: gcc-9 + FC: gfortran-9 + CXX: g++-9 + strategy: + matrix: + os: [macos-10.15, ubuntu-20.04] + compiler: [gcc-9] steps: - name: install-dependencies run: | - sudo apt-get update - sudo apt-get install libmpich-dev - sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config - sudo apt-get install libpng-dev - sudo apt-get install libjpeg-dev - sudo apt-get install wget + if [[ ${{ matrix.os }} == "ubuntu-20.04" ]]; then + sudo apt-get update + sudo apt-get install doxygen + sudo apt-get install libmpich-dev + sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config + sudo apt-get install libpng-dev + sudo apt-get install libjpeg-dev + elif [[ ${{ matrix.os }} == "macos-10.15" ]]; then + brew install doxygen + brew install mpich + brew install netcdf + brew install wget + if [[ ${{ matrix.compiler }} == "gcc-9" ]]; then + sudo ln -sf /usr/local/bin/gfortran-9 /usr/local/bin/gfortran + elif [[ ${{ matrix.compiler }} == "gcc-10" ]]; then + sudo ln -sf /usr/local/bin/gfortran-10 /usr/local/bin/gfortran + fi + fi + - name: cache-esmf id: cache-esmf uses: actions/cache@v2 @@ -30,8 +48,8 @@ jobs: set -x pushd ~ export ESMF_DIR=~/esmf-ESMF_8_0_1 - wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null - tar zxf ESMF_8_0_1.tar.gz + wget https://github.com/esmf-org/esmf/archive/ESMF_8_0_1.tar.gz &> /dev/null && ls -l + tar zxf ESMF_8_0_1.tar.gz && ls -l cd esmf-ESMF_8_0_1 export ESMF_COMM=mpich3 export ESMF_INSTALL_BINDIR=bin @@ -40,10 +58,16 @@ jobs: export ESMF_COMPILER=gfortran export ESMF_INSTALL_PREFIX=~/esmf export ESMF_NETCDF=split - export ESMF_NETCDF_INCLUDE=/usr/include - export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + if [[ ${{ matrix.os }} == "ubuntu-20.04" ]]; then + export ESMF_NETCDF_INCLUDE=/usr/include + export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + elif [[ ${{ matrix.os }} == "macos-10.15" ]]; then + export ESMF_NETCDF_INCLUDE=/usr/local/include + export ESMF_NETCDF_LIBPATH=/usr/local/lib + fi make -j2 make install + - name: cache-jasper id: cache-jasper uses: actions/cache@v2 @@ -56,13 +80,20 @@ jobs: run: | set -x pwd - wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null - tar zxf version-2.0.22.tar.gz + wget https://github.com/jasper-software/jasper/archive/version-2.0.22.tar.gz &> /dev/null && ls -l + tar zxf version-2.0.22.tar.gz && ls -l cd jasper-version-2.0.22 mkdir build-jasper && cd build-jasper cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper make -j2 make install + + - name: checkout-nceplibs + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS + path: nceplibs + - name: cache-nceplibs id: cache-nceplibs uses: actions/cache@v2 @@ -71,7 +102,6 @@ jobs: key: nceplibs-${{ runner.os }}-1.3.0 - name: build-nceplibs - if: steps.cache-nceplibs.outputs.cache-hit != 'true' run: | set -x export ESMFMKFILE=~/esmf/lib/esmf.mk diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml index 4eeebdc72..3ff50dc7d 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml @@ -3,20 +3,38 @@ on: [push, pull_request] jobs: build: - runs-on: ubuntu-20.04 + runs-on: ${{ matrix.os }} env: - FC: gfortran-9 CC: gcc-9 + FC: gfortran-9 + CXX: g++-9 + strategy: + matrix: + os: [macos-10.15, ubuntu-20.04] + compiler: [gcc-9] steps: - name: install-dependencies run: | - sudo apt-get update - sudo apt-get install libmpich-dev - sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config - sudo apt-get install libpng-dev - sudo apt-get install libjpeg-dev - sudo apt-get install wget + if [[ ${{ matrix.os }} == "ubuntu-20.04" ]]; then + sudo apt-get update + sudo apt-get install doxygen + sudo apt-get install libmpich-dev + sudo apt-get install libnetcdf-dev libnetcdff-dev netcdf-bin pkg-config + sudo apt-get install libpng-dev + sudo apt-get install libjpeg-dev + elif [[ ${{ matrix.os }} == "macos-10.15" ]]; then + brew install doxygen + brew install mpich + brew install netcdf + brew install wget + if [[ ${{ matrix.compiler }} == "gcc-9" ]]; then + sudo ln -sf /usr/local/bin/gfortran-9 /usr/local/bin/gfortran + elif [[ ${{ matrix.compiler }} == "gcc-10" ]]; then + sudo ln -sf /usr/local/bin/gfortran-10 /usr/local/bin/gfortran + fi + fi + - name: cache-esmf id: cache-esmf uses: actions/cache@v2 @@ -40,10 +58,16 @@ jobs: export ESMF_COMPILER=gfortran export ESMF_INSTALL_PREFIX=~/esmf export ESMF_NETCDF=split - export ESMF_NETCDF_INCLUDE=/usr/include - export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + if [[ ${{ matrix.os }} == "ubuntu-20.04" ]]; then + export ESMF_NETCDF_INCLUDE=/usr/include + export ESMF_NETCDF_LIBPATH=/usr/x86_64-linux-gnu + elif [[ ${{ matrix.os }} == "macos-10.15" ]]; then + export ESMF_NETCDF_INCLUDE=/usr/local/include + export ESMF_NETCDF_LIBPATH=/usr/local/lib + fi make -j2 make install + - name: cache-jasper id: cache-jasper uses: actions/cache@v2 From edc1af775210a7ce75c48b3600f4855942514c91 Mon Sep 17 00:00:00 2001 From: lgannoaa <37596169+lgannoaa@users.noreply.github.com> Date: Fri, 12 Feb 2021 08:33:45 -0500 Subject: [PATCH 29/47] Feature/unit tests for chgres_cube.fd/utils.f90 (#276) * Create unit-tests for testing to_upper and to_lower. This commit references issue #257 * Add unit test to_upper_lower into CMake build * Clean up build and push for draft pull request * Making following improvement: - Using env parameter to assign source code - Add auther name - Modify comment - Change test failing procedure - rename directory for unit test * turned on testing in workflows * added test as test in cmake * added test as test in cmake * clean up test cmake file * renamed test * cleanup output * cleanup output * moved to new test directory * added tests subdirectory Co-authored-by: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Co-authored-by: Edward Hartnett --- ...smf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 1 + ...f-8.0.1_jasper-2.0.22_nceplibs-develop.yml | 1 + CMakeLists.txt | 8 ++++ tests/CMakeLists.txt | 8 ++++ tests/chres_cube/CMakeLists.txt | 42 ++++++++++++++++ tests/chres_cube/ftst_utils.F90 | 48 +++++++++++++++++++ 6 files changed, 108 insertions(+) create mode 100644 tests/CMakeLists.txt create mode 100644 tests/chres_cube/CMakeLists.txt create mode 100644 tests/chres_cube/ftst_utils.F90 diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml index efb87d9cd..6883a6cec 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -124,6 +124,7 @@ jobs: mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper;~/nceplibs' make -j2 + make test diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml index 3ff50dc7d..cd2beb295 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml @@ -115,6 +115,7 @@ jobs: mkdir build && cd build cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' make -j2 + make test diff --git a/CMakeLists.txt b/CMakeLists.txt index 9677e6c2a..266ec8c27 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -23,6 +23,8 @@ if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") CACHE STRING "Choose the type of build." FORCE) set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") + message(STATUS "Set BUILD_TESTING to YES and build unit testing package under tests") + set(BUILD_TESTING "YES") endif() # Set compiler flags. @@ -73,6 +75,12 @@ endif() add_subdirectory(sorc) +# Run unit tests. +include(CTest) +if(BUILD_TESTING) + add_subdirectory(tests) +endif() + # If doxygen documentation we enabled, build it. if(ENABLE_DOCS) find_package(Doxygen REQUIRED) diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt new file mode 100644 index 000000000..e1478e2e5 --- /dev/null +++ b/tests/CMakeLists.txt @@ -0,0 +1,8 @@ +# This is the CMake file for the tests directory of the UFS_UTILS +# project. +# +# Ed Hartnett 2/11/21 + +# Add the test subdirecotries. +add_subdirectory(chres_cube) + diff --git a/tests/chres_cube/CMakeLists.txt b/tests/chres_cube/CMakeLists.txt new file mode 100644 index 000000000..f7c3b64ae --- /dev/null +++ b/tests/chres_cube/CMakeLists.txt @@ -0,0 +1,42 @@ +# This is the cmake build file for the tests directory of the +# UFS_UTILS project. +# +# George Gayno, Lin Gan, Ed Hartnett + +set(fortran_src + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/utils.f90" + ftst_utils.F90) + +if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian -assume byterecl") +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffree-line-length-0 -fdefault-real-8 -fconvert=big-endian") +endif() + +include_directories( + ${PROJECT_SOURCE_DIR} +) + +set(exe_name ftst_utils) +add_executable(${exe_name} ${fortran_src}) +add_test(NAME ftst_utils COMMAND ftst_utils) +target_link_libraries( + ftst_utils + nemsio::nemsio + sfcio::sfcio + sigio::sigio + bacio::bacio_4 + sp::sp_d + w3nco::w3nco_d + esmf + wgrib2::wgrib2_lib + wgrib2::wgrib2_api + MPI::MPI_Fortran + NetCDF::NetCDF_Fortran) +if(OpenMP_Fortran_FOUND) + target_link_libraries(ftst_utils OpenMP::OpenMP_Fortran) +endif() + + + + diff --git a/tests/chres_cube/ftst_utils.F90 b/tests/chres_cube/ftst_utils.F90 new file mode 100644 index 000000000..696552dd1 --- /dev/null +++ b/tests/chres_cube/ftst_utils.F90 @@ -0,0 +1,48 @@ +! Unit test for to_upper() and to_lower() functions under UFS_UTILS +! package, chres_cube utility. +! +! Lin Gan NCEP/EMC + +program ftst_utils + + + implicit none + + logical :: match_result + + character(len=12) :: test_input_char_1, test_input_char_2, u_st_base, l_st_base + + u_st_base="STAGGERLOCCE" + l_st_base="staggerlocce" + test_input_char_1="sTAGGErLOCCE" + test_input_char_2="staGGErLOCCE" + + print*, "Starting Unit Testing to_upper_lower." + print*, "testing to_lower and to_upper..." + +!------------------------------------------------------------------------- +! Execute testing below by running target function with testing string +! When match_result set to be T - compare to base line is identical +! When match_result set to be F - compare to base line is NOT identical +!------------------------------------------------------------------------- + + call to_lower(test_input_char_1) + match_result = test_input_char_1 == l_st_base + if (.not.match_result) then + stop + endif + + call to_upper(test_input_char_2) + match_result = test_input_char_2 == u_st_base + if (.not.match_result) then + stop + endif + +!------------------------------------------------------------------------- +! Display final result +!------------------------------------------------------------------------- + + print*, "OK" + print*, "SUCCESS!" + +end program ftst_utils From ae8c9c5b2cf0cee223d1232b9645c359c323bcdc Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Thu, 18 Feb 2021 07:29:53 -0700 Subject: [PATCH 30/47] added documentation build to workflows, turned on doxygen warnings for missing documentation (#297) * turning on docs build in existing workflows Also turned on warnings in doxygen. --- .../workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml | 2 +- .../workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml | 2 +- docs/Doxyfile.in | 6 +++++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml index 6883a6cec..4aee5679a 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-1.3.0.yml @@ -122,7 +122,7 @@ jobs: export ESMFMKFILE=~/esmf/lib/esmf.mk cd ufs_utils mkdir build && cd build - cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper;~/nceplibs' + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper;~/nceplibs' -DENABLE_DOCS=On make -j2 make test diff --git a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml index cd2beb295..083bd389f 100644 --- a/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml +++ b/.github/workflows/esmf-8.0.1_jasper-2.0.22_nceplibs-develop.yml @@ -113,7 +113,7 @@ jobs: export ESMFMKFILE=~/esmf/lib/esmf.mk cd ufs_utils mkdir build && cd build - cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' + cmake .. -DCMAKE_PREFIX_PATH='~;~/jasper' -DENABLE_DOCS=On make -j2 make test diff --git a/docs/Doxyfile.in b/docs/Doxyfile.in index fe5ab4adc..20e6fbc7e 100644 --- a/docs/Doxyfile.in +++ b/docs/Doxyfile.in @@ -697,7 +697,7 @@ WARNINGS = YES # will automatically be disabled. # The default value is: YES. -WARN_IF_UNDOCUMENTED = NO +WARN_IF_UNDOCUMENTED = YES # If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for # potential errors in the documentation, such as not documenting some parameters @@ -731,6 +731,10 @@ WARN_FORMAT = "$file:$line: $text" WARN_LOGFILE = +# WARN_AS_ERROR causes warnings to be treated as errors. + +WARN_AS_ERROR = NO + #--------------------------------------------------------------------------- # Configuration options related to the input files #--------------------------------------------------------------------------- From f4750a59130a4d3d8e1ff69924e42a5c43a64454 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Thu, 18 Feb 2021 08:31:15 -0700 Subject: [PATCH 31/47] updated doxygen docs for chgres_cube.fd/input_data.F90 (#285) * updated doxygen docs * update doxygen for chgres_cube/input_data.F90 * fixed doxygen * fixed doxygen Co-authored-by: George Gayno --- sorc/chgres_cube.fd/input_data.F90 | 391 ++++++++++++++++------------- 1 file changed, 223 insertions(+), 168 deletions(-) diff --git a/sorc/chgres_cube.fd/input_data.F90 b/sorc/chgres_cube.fd/input_data.F90 index 78005194c..66c05c0f5 100644 --- a/sorc/chgres_cube.fd/input_data.F90 +++ b/sorc/chgres_cube.fd/input_data.F90 @@ -1,6 +1,6 @@ !> @file !! @brief Read input data -!! @author gayno NCEP/EMC +!! @author George Gayno NCEP/EMC !! !! Read atmospheric, surface and nst data on the input grid. !! Supported formats include fv3 tiled 'restart' files, fv3 tiled @@ -49,56 +49,56 @@ module input_data ! Fields associated with the atmospheric model. - type(esmf_field), public :: dzdt_input_grid ! vert velocity - type(esmf_field) :: dpres_input_grid ! pressure thickness - type(esmf_field), public :: pres_input_grid ! 3-d pressure - type(esmf_field), public :: ps_input_grid ! surface pressure - type(esmf_field), public :: terrain_input_grid ! terrain height - type(esmf_field), public :: temp_input_grid ! temperature - type(esmf_field) :: u_input_grid ! u/v wind at grid - type(esmf_field) :: v_input_grid ! box center - type(esmf_field), public :: wind_input_grid ! 3-component wind - type(esmf_field), allocatable, public :: tracers_input_grid(:) ! tracers + type(esmf_field), public :: dzdt_input_grid !< vert velocity + type(esmf_field) :: dpres_input_grid !< pressure thickness + type(esmf_field), public :: pres_input_grid !< 3-d pressure + type(esmf_field), public :: ps_input_grid !< surface pressure + type(esmf_field), public :: terrain_input_grid !< terrain height + type(esmf_field), public :: temp_input_grid !< temperature + type(esmf_field) :: u_input_grid !< u/v wind at grid + type(esmf_field) :: v_input_grid !< box center + type(esmf_field), public :: wind_input_grid !< 3-component wind + type(esmf_field), allocatable, public :: tracers_input_grid(:) !< tracers - integer, public :: lev_input ! # of atmospheric layers - integer, public :: levp1_input ! # of atmos layer interfaces + integer, public :: lev_input !< number of atmospheric layers + integer, public :: levp1_input !< number of atmos layer interfaces ! Fields associated with the land-surface model. - integer, public :: veg_type_landice_input = 15 ! NOAH land ice option - ! defined at this veg type. - ! Default is igbp. - - type(esmf_field), public :: canopy_mc_input_grid ! canopy moist content - type(esmf_field), public :: f10m_input_grid ! log((z0+10)*1/z0) - type(esmf_field), public :: ffmm_input_grid ! log((z0+z1)*1/z0) - ! See sfc_diff.f for details. - type(esmf_field), public :: landsea_mask_input_grid ! land sea mask; - ! 0-water, 1-land, 2-ice - type(esmf_field), public :: q2m_input_grid ! 2-m spec hum - type(esmf_field), public :: seaice_depth_input_grid ! sea ice depth - type(esmf_field), public :: seaice_fract_input_grid ! sea ice fraction - type(esmf_field), public :: seaice_skin_temp_input_grid ! sea ice skin temp - type(esmf_field), public :: skin_temp_input_grid ! skin temp/sst - type(esmf_field), public :: snow_depth_input_grid ! snow dpeth - type(esmf_field), public :: snow_liq_equiv_input_grid ! snow liq equiv depth - type(esmf_field), public :: soil_temp_input_grid ! 3-d soil temp - type(esmf_field), public :: soil_type_input_grid ! soil type - type(esmf_field), public :: soilm_liq_input_grid ! 3-d liquid soil moisture - type(esmf_field), public :: soilm_tot_input_grid ! 3-d total soil moisture - type(esmf_field), public :: srflag_input_grid ! snow/rain flag - type(esmf_field), public :: t2m_input_grid ! 2-m temperature - type(esmf_field), public :: tprcp_input_grid ! precip - type(esmf_field), public :: ustar_input_grid ! fric velocity - type(esmf_field), public :: veg_type_input_grid ! vegetation type - type(esmf_field), public :: z0_input_grid ! roughness length - type(esmf_field), public :: veg_greenness_input_grid ! vegetation fraction - type(esmf_field), public :: lai_input_grid ! leaf area index - type(esmf_field), public :: max_veg_greenness_input_grid ! shdmax - type(esmf_field), public :: min_veg_greenness_input_grid ! shdmin - - integer, public :: lsoil_input=4 ! # of soil layers, no longer hardwired to allow - ! # for 7 layers of soil for the RUC LSM + integer, public :: veg_type_landice_input = 15 !< NOAH land ice option + !< defined at this veg type. + !< Default is igbp. + + type(esmf_field), public :: canopy_mc_input_grid !< canopy moist content + type(esmf_field), public :: f10m_input_grid !< log((z0+10)*1/z0) + type(esmf_field), public :: ffmm_input_grid !< log((z0+z1)*1/z0) + !! See sfc_diff.f for details. + type(esmf_field), public :: landsea_mask_input_grid !< land sea mask; + !! 0-water, 1-land, 2-ice + type(esmf_field), public :: q2m_input_grid !< 2-m spec hum + type(esmf_field), public :: seaice_depth_input_grid !< sea ice depth + type(esmf_field), public :: seaice_fract_input_grid !< sea ice fraction + type(esmf_field), public :: seaice_skin_temp_input_grid !< sea ice skin temp + type(esmf_field), public :: skin_temp_input_grid !< skin temp/sst + type(esmf_field), public :: snow_depth_input_grid !< snow dpeth + type(esmf_field), public :: snow_liq_equiv_input_grid !< snow liq equiv depth + type(esmf_field), public :: soil_temp_input_grid !< 3-d soil temp + type(esmf_field), public :: soil_type_input_grid !< soil type + type(esmf_field), public :: soilm_liq_input_grid !< 3-d liquid soil moisture + type(esmf_field), public :: soilm_tot_input_grid !< 3-d total soil moisture + type(esmf_field), public :: srflag_input_grid !< snow/rain flag + type(esmf_field), public :: t2m_input_grid !< 2-m temperature + type(esmf_field), public :: tprcp_input_grid !< precip + type(esmf_field), public :: ustar_input_grid !< fric velocity + type(esmf_field), public :: veg_type_input_grid !< vegetation type + type(esmf_field), public :: z0_input_grid !< roughness length + type(esmf_field), public :: veg_greenness_input_grid !< vegetation fraction + type(esmf_field), public :: lai_input_grid !< leaf area index + type(esmf_field), public :: max_veg_greenness_input_grid !< shdmax + type(esmf_field), public :: min_veg_greenness_input_grid !< shdmin + + integer, public :: lsoil_input=4 !< number of soil layers, no longer hardwired to allow + !! for 7 layers of soil for the RUC LSM character(len=50), private, allocatable :: slevs(:) @@ -110,7 +110,7 @@ module input_data type(esmf_field), public :: dt_cool_input_grid type(esmf_field), public :: ifd_input_grid type(esmf_field), public :: qrain_input_grid - type(esmf_field), public :: tref_input_grid ! reference temperature + type(esmf_field), public :: tref_input_grid !< reference temperature type(esmf_field), public :: w_d_input_grid type(esmf_field), public :: w_0_input_grid type(esmf_field), public :: xs_input_grid @@ -132,9 +132,10 @@ module input_data contains -!> @brief -!! Read input grid atmospheric data driver +!> Read input grid atmospheric data driver. !! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_data(localpet) implicit none @@ -201,9 +202,10 @@ subroutine read_input_atm_data(localpet) end subroutine read_input_atm_data -!> @brief -!! Driver to read input grid nst data. +!> Driver to read input grid nst data. !! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_nst_data(localpet) implicit none @@ -362,9 +364,10 @@ subroutine read_input_nst_data(localpet) end subroutine read_input_nst_data -!> @brief -!! Driver to read input grid surface data. +!> Driver to read input grid surface data. !! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_data(localpet) implicit none @@ -622,10 +625,9 @@ subroutine read_input_sfc_data(localpet) end subroutine read_input_sfc_data -!--------------------------------------------------------------------------- -! Create atmospheric esmf fields. -!--------------------------------------------------------------------------- - +!> Create atmospheric esmf fields. +!! +!! @author George Gayno NCEP/EMC subroutine init_atm_esmf_fields implicit none @@ -717,11 +719,11 @@ subroutine init_atm_esmf_fields end subroutine init_atm_esmf_fields -!--------------------------------------------------------------------------- -! Read input atmospheric data from spectral gfs (old sigio format). -! Used prior to July 19, 2017. -!--------------------------------------------------------------------------- - +!> Read input atmospheric data from spectral gfs (old sigio format). +!! +!! @note Format used prior to July 19, 2017. +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_gfs_sigio_file(localpet) use sigio_module @@ -956,11 +958,11 @@ subroutine read_input_atm_gfs_sigio_file(localpet) end subroutine read_input_atm_gfs_sigio_file -!--------------------------------------------------------------------------- -! Read input atmospheric data from spectral gfs (global gaussian in -! nemsio format. Starting July 19, 2017). -!--------------------------------------------------------------------------- - +!> Read input atmospheric data from spectral gfs (global gaussian in +!! nemsio format. Starting July 19, 2017). +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_gfs_gaussian_nemsio_file(localpet) implicit none @@ -1210,10 +1212,10 @@ subroutine read_input_atm_gfs_gaussian_nemsio_file(localpet) end subroutine read_input_atm_gfs_gaussian_nemsio_file -!--------------------------------------------------------------------------- -! Read input grid atmospheric fv3 gaussian nemsio files. -!--------------------------------------------------------------------------- - +!> Read input grid atmospheric fv3 gaussian nemsio files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_gaussian_nemsio_file(localpet) implicit none @@ -1489,15 +1491,14 @@ subroutine read_input_atm_gaussian_nemsio_file(localpet) end subroutine read_input_atm_gaussian_nemsio_file -!--------------------------------------------------------------------------- -! Read input grid fv3 atmospheric data 'warm' restart files. -! -! Routine reads tiled files in parallel. Tile 1 is read by -! localpet 0; tile 2 by localpet 1, etc. The number of pets -! must be equal to or greater than the number of tiled files. -! Logic only tested with global input data of six tiles. -!--------------------------------------------------------------------------- - +!> Read input grid fv3 atmospheric data 'warm' restart files. +!! +!! @note Routine reads tiled files in parallel. Tile 1 is read by +!! localpet 0; tile 2 by localpet 1, etc. The number of pets +!! must be equal to or greater than the number of tiled files. +!! Logic only tested with global input data of six tiles. +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_restart_file(localpet) implicit none @@ -1752,11 +1753,11 @@ subroutine read_input_atm_restart_file(localpet) end subroutine read_input_atm_restart_file -!--------------------------------------------------------------------------- -! Read fv3 netcdf gaussian history file. Each task reads a horizontal -! slice. -!--------------------------------------------------------------------------- - +!> Read fv3 netcdf gaussian history file. Each task reads a horizontal +!! slice. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_gaussian_netcdf_file(localpet) use mpi @@ -2132,14 +2133,15 @@ subroutine read_input_atm_gaussian_netcdf_file(localpet) end subroutine read_input_atm_gaussian_netcdf_file -!--------------------------------------------------------------------------- -! Read input grid fv3 atmospheric tiled history files in netcdf format. -! -! Routine reads tiled files in parallel. Tile 1 is read by -! localpet 0; tile 2 by localpet 1, etc. The number of pets -! must be equal to or greater than the number of tiled files. -!--------------------------------------------------------------------------- - +!> Read input grid fv3 atmospheric tiled history files in netcdf +!! format. +!! +!! @note Routine reads tiled files in parallel. Tile 1 is read by +!! localpet 0; tile 2 by localpet 1, etc. The number of pets +!! must be equal to or greater than the number of tiled files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_tiled_history_file(localpet) use mpi @@ -2427,10 +2429,10 @@ subroutine read_input_atm_tiled_history_file(localpet) end subroutine read_input_atm_tiled_history_file -!--------------------------------------------------------------------------- -! Read input grid atmospheric fv3gfs grib2 files. -!--------------------------------------------------------------------------- - +!> Read input grid atmospheric fv3gfs grib2 files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_atm_grib2_file(localpet) use wgrib2api @@ -2966,11 +2968,13 @@ subroutine read_input_atm_grib2_file(localpet) end subroutine read_input_atm_grib2_file -!--------------------------------------------------------------------------- -! Read input grid surface data from a spectral gfs gaussian sfcio file. -! Prior to July 19, 2017. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from a spectral gfs gaussian sfcio +!! file. +!! +!! @note Prior to July 19, 2017. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_gfs_sfcio_file(localpet) use sfcio_module @@ -3188,11 +3192,13 @@ subroutine read_input_sfc_gfs_sfcio_file(localpet) end subroutine read_input_sfc_gfs_sfcio_file -!--------------------------------------------------------------------------- -! Read input grid surface data from a spectral gfs gaussian nemsio file. -! Format used by gfs starting July 19, 2017. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from a spectral gfs gaussian nemsio +!! file. +!! +!! @note Format used by gfs starting July 19, 2017. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_gfs_gaussian_nemsio_file(localpet) implicit none @@ -3538,10 +3544,10 @@ subroutine read_input_sfc_gfs_gaussian_nemsio_file(localpet) end subroutine read_input_sfc_gfs_gaussian_nemsio_file -!--------------------------------------------------------------------------- -! Read input grid surface data from an fv3 gaussian nemsio file. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from an fv3 gaussian nemsio file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_gaussian_nemsio_file(localpet) implicit none @@ -3887,10 +3893,10 @@ subroutine read_input_sfc_gaussian_nemsio_file(localpet) end subroutine read_input_sfc_gaussian_nemsio_file -!--------------------------------------------------------------------------- -! Read input grid surface data tiled warm 'restart' files. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from fv3 tiled warm 'restart' files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_restart_file(localpet) implicit none @@ -4203,11 +4209,11 @@ subroutine read_input_sfc_restart_file(localpet) end subroutine read_input_sfc_restart_file -!--------------------------------------------------------------------------- -! Read input grid surface data from tiled 'history' files (netcdf) or -! gaussian netcdf files. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from tiled 'history' files (netcdf) or +!! gaussian netcdf files. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_sfc_netcdf_file(localpet) implicit none @@ -4565,10 +4571,10 @@ subroutine read_input_sfc_netcdf_file(localpet) end subroutine read_input_sfc_netcdf_file -!--------------------------------------------------------------------------- -! Read surface data from an fv3gfs grib2 file. -!--------------------------------------------------------------------------- - +!> Read input grid surface data from a grib2 file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author Larissa Reames subroutine read_input_sfc_grib2_file(localpet) use wgrib2api @@ -5406,11 +5412,11 @@ subroutine read_input_sfc_grib2_file(localpet) end subroutine read_input_sfc_grib2_file -!--------------------------------------------------------------------------- -! Read nst data from these netcdf formatted fv3 files: tiled history, -! tiled warm restart, and gaussian history. -!--------------------------------------------------------------------------- - +!> Read nst data from these netcdf formatted fv3 files: tiled history, +!! tiled warm restart, and gaussian history. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_nst_netcdf_file(localpet) implicit none @@ -5686,13 +5692,15 @@ subroutine read_input_nst_netcdf_file(localpet) end subroutine read_input_nst_netcdf_file -!-------------------------------------------------------------------------- -! Read input grid nst data from fv3 gaussian nemsio history file or -! spectral GFS nemsio file. The spectral GFS nst data is in a separate -! file from the surface data. The fv3 surface and nst data are in a -! single file. -!-------------------------------------------------------------------------- - +!> Read input grid nst data from fv3 gaussian nemsio history file or +!! spectral GFS nemsio file. +!! +!! @note The spectral GFS nst data is in a separate file from +!! the surface data. The fv3 surface and nst data are in a +!! single file. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine read_input_nst_nemsio_file(localpet) implicit none @@ -5958,6 +5966,16 @@ subroutine read_input_nst_nemsio_file(localpet) end subroutine read_input_nst_nemsio_file +!> Read a record from a netcdf file +!! +!! @param [in] field name of field to be read +!! @param [in] tile_num grid tile number +!! @param [in] imo i-dimension of field +!! @param [in] jmo j-dimension of field +!! @param [in] lmo number of vertical levels of field +!! @param [out] sfcdata 1-d array containing field data +!! @param [out] sfcdata_3d 3-d array containing field data +!! @author George Gayno NCEP/EMC SUBROUTINE READ_FV3_GRID_DATA_NETCDF(FIELD,TILE_NUM,IMO,JMO,LMO, & SFCDATA, SFCDATA_3D) @@ -5996,10 +6014,15 @@ SUBROUTINE READ_FV3_GRID_DATA_NETCDF(FIELD,TILE_NUM,IMO,JMO,LMO, & END SUBROUTINE READ_FV3_GRID_DATA_NETCDF - !--------------------------------------------------------------------------- -! Read winds from a grib2 file -!--------------------------------------------------------------------------- - +!> Read winds from a grib2 file. Rotate winds +!! to be earth relative if necessary. +!! +!! @param [in] file grib2 file to be read +!! @param [in] inv grib2 inventory file +!! @param [inout] u u-component wind +!! @param [inout] v v-component wind +!! @param[in] localpet ESMF local persistent execution thread +!! @author Larissa Reames subroutine read_winds(file,inv,u,v,localpet) use wgrib2api @@ -6156,10 +6179,9 @@ subroutine read_winds(file,inv,u,v,localpet) end subroutine read_winds -!--------------------------------------------------------------------------- -! Convert from 2-d to 3-d winds. -!--------------------------------------------------------------------------- - +!> Convert winds from 2-d to 3-d components. +!! +!! @author George Gayno NCEP/EMC subroutine convert_winds implicit none @@ -6223,14 +6245,19 @@ subroutine convert_winds end subroutine convert_winds -!--------------------------------------------------------------------------- -! Compute grid rotation angle for non-latlon grids -!--------------------------------------------------------------------------- - -!# NG The original gridrot subroutine was specific to polar stereographic grids. -! We need to compute it for Lambert Conformal grids. So we need lat1,lat2 -! Note this follows the ncl_ncarg source code -! ncl_ncarg-6.6.2/ni/src/ncl/GetGrids.c +!> Compute grid rotation angle for non-latlon grids. +!! +!! @note The original gridrot subroutine was specific to polar +!! stereographic grids. We need to compute it for Lambert Conformal +!! grids. So we need lat1,lat2. This follows the ncl_ncarg source +!! code: ncl_ncarg-6.6.2/ni/src/ncl/GetGrids.c +!! +!! @param [in] lov orientation angle +!! @param [in] latin1 first tangent latitude +!! @param [in] latin2 second tangent latitude +!! @param [in] lon longitude +!! @param [inout] rot rotation angle +!! @author Larissa Reames subroutine gridrot(lov,latin1,latin2,lon,rot) use model_grid, only : i_input,j_input @@ -6263,9 +6290,15 @@ subroutine gridrot(lov,latin1,latin2,lon,rot) end subroutine gridrot -! Subroutine calcalpha_rotlatlon calculates rotation angle -! specific to rotated latlon grids, needed to convert to -! earth-relative winds +!> Calculate rotation angle for rotated latlon grids. +!! Needed to convert to earth-relative winds. +!! +!! @param [in] latgrid grid latitudes +!! @param [in] longrid grid longitudes +!! @param [in] cenlat center latitude +!! @param [in] cenlon center longitude +!! @param [out] alpha grid rotation angle +!! @author Larissa Reames subroutine calcalpha_rotlatlon(latgrid,longrid,cenlat,cenlon,alpha) use model_grid, only : i_input,j_input @@ -6301,7 +6334,20 @@ subroutine calcalpha_rotlatlon(latgrid,longrid,cenlat,cenlon,alpha) alpha = -asin(sinalpha)/D2R ! returns alpha in degrees end subroutine calcalpha_rotlatlon - + +!> Handle GRIB2 read error based on the user selected +!! method in the varmap file. +!! +!! @param [in] vname grib2 variable name +!! @param [in] lev grib2 variable level +!! @param [in] method how missing data is handled +!! @param [in] value fill value for missing data +!! @param [in] varnum grib2 variable number +!! @param [inout] iret return status code +!! @param [inout] var 4-byte array of corrected data +!! @param [inout] var8 8-byte array of corrected data +!! @param [inout] var3d 3-d array of corrected data +!! @author Larissa Reames subroutine handle_grib_error(vname,lev,method,value,varnum, iret,var,var8,var3d) use, intrinsic :: ieee_arithmetic @@ -6355,6 +6401,15 @@ subroutine handle_grib_error(vname,lev,method,value,varnum, iret,var,var8,var3d) end subroutine handle_grib_error +!> Read soil temperature and soil moisture fields from a GRIB2 file. +!! +!! @param [in] the_file grib2 file name +!! @param [in] inv_file grib2 inventory file name +!! @param [in] vname variable name in varmap table +!! @param [in] vname_file variable name in grib2 file +!! @param [inout] dummy3d array of soil data +!! @param [out] rc read error status code +!! @author George Gayno NCEP/EMC subroutine read_grib_soil(the_file,inv_file,vname,vname_file,dummy3d,rc) use wgrib2api @@ -6414,9 +6469,9 @@ subroutine read_grib_soil(the_file,inv_file,vname,vname_file,dummy3d,rc) end subroutine read_grib_soil -!> @brief -!! Free up memory associated with atm data +!> Free up memory associated with atm data. !! +!! @author George Gayno NCEP/EMC subroutine cleanup_input_atm_data implicit none @@ -6439,9 +6494,9 @@ subroutine cleanup_input_atm_data end subroutine cleanup_input_atm_data -!> @brief -!! Free up memory associated with nst data +!> Free up memory associated with nst data. !! +!! @author George Gayno NCEP/EMC subroutine cleanup_input_nst_data implicit none @@ -6472,9 +6527,9 @@ subroutine cleanup_input_nst_data end subroutine cleanup_input_nst_data -!> @brief -!! Free up memory associated with sfc data +!> Free up memory associated with sfc data. !! +!! @author George Gayno NCEP/EMC subroutine cleanup_input_sfc_data implicit none @@ -6520,12 +6575,12 @@ subroutine cleanup_input_sfc_data end subroutine cleanup_input_sfc_data -! Jili Dong add sort subroutine -! quicksort.f -*-f90-*- -! Author: t-nissie -! License: GPLv3 -! Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea +!> Sort an array of values. !! +!! @param a the sorted array +!! @param first the first value of sorted array +!! @param last the last value of sorted array +!! @author Jili Dong NOAA/EMC recursive subroutine quicksort(a, first, last) implicit none real*8 a(*), x, t From a5ab334b8a3db22eedb9acd9094f22f37d526659 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Thu, 18 Feb 2021 11:48:13 -0700 Subject: [PATCH 32/47] doxygen for model_grid.F90 (#289) * doxygen for model_grid.F90 * doxygen updates * Update doxygen for each routine in module chgres_cube/model_grid.F90 Co-authored-by: George Gayno --- sorc/chgres_cube.fd/model_grid.F90 | 127 +++++++++++++++++++---------- 1 file changed, 86 insertions(+), 41 deletions(-) diff --git a/sorc/chgres_cube.fd/model_grid.F90 b/sorc/chgres_cube.fd/model_grid.F90 index 0e4221e03..c245ca5cb 100644 --- a/sorc/chgres_cube.fd/model_grid.F90 +++ b/sorc/chgres_cube.fd/model_grid.F90 @@ -1,10 +1,9 @@ !> @file -!! @brief Specify input and target model grids -!! -!! @author gayno NCEP/EMC +!! @brief Specify input and target model grids. !! !! Specify input and target model grids via ESMF grid objects. !! +!! @author George Gayno NCEP/EMC module model_grid use esmf @@ -102,14 +101,17 @@ module model_grid contains -!> @brief Setup the esmf grid object for the input grid. +!> Driver routine to setup the esmf grid object for the input grid. !! -!! If the input source is tiled fv3 restart or history data, the grid is -!! created by reading the mosaic and grid files. If the input source is -!! fv3 global gaussian nemsio, spectral gfs global gaussian nemsio, or -!! spectral gfs global gaussian sigio/sfcio, the grid is setup by -!! computing lat/lons using the sp library. +!! If the input source is tiled fv3 restart or history data, the grid +!! is created by reading the mosaic and grid files. If the input +!! source is fv3 global gaussian nemsio, spectral gfs global gaussian +!! nemsio, or spectral gfs global gaussian sigio/sfcio, the grid is +!! setup by computing lat/lons using the sp library. !! +!! @param [in] localpet ESMF local persistent execution thread +!! @param [in] npets Number of persistent execution threads +!! @author George Gayno NCEP/EMC subroutine define_input_grid(localpet, npets) use program_setup, only : input_type, external_model @@ -133,16 +135,17 @@ subroutine define_input_grid(localpet, npets) end subroutine define_input_grid -!-------------------------------------------------------------------------- -! Define grid object for input data on global gaussian grids. -! Recognized file formats: -! -! - fv3gfs nemsio -! - spectral gfs nemsio (starting July 19, 2017) -! - spectral gfs sigio (prior to July 19, 2017) -! - spectral gfs sfcio (prior to July 19, 2017) -!-------------------------------------------------------------------------- - +!> Define grid object for input data on global gaussian grids. +!! +!! Recognized file formats: +!! - fv3gfs nemsio +!! - spectral gfs nemsio (starting July 19, 2017) +!! - spectral gfs sigio (prior to July 19, 2017) +!! - spectral gfs sfcio (prior to July 19, 2017) +!! +!! @param [in] localpet ESMF local persistent execution thread +!! @param [in] npets Number of persistent execution threads. +!! @author George Gayno NCEP/EMC subroutine define_input_grid_gaussian(localpet, npets) use nemsio_module @@ -391,6 +394,12 @@ subroutine define_input_grid_gaussian(localpet, npets) end subroutine define_input_grid_gaussian +!> Define input grid for tiled data using the 'mosaic', +!! 'grid' and orography files. +!! +!! @param localpet ESMF local persistent execution thread +!! @param npets Total number of persistent execution threads +!! @author George Gayno NCEP/EMC subroutine define_input_grid_mosaic(localpet, npets) use netcdf @@ -598,11 +607,12 @@ subroutine define_input_grid_mosaic(localpet, npets) end subroutine define_input_grid_mosaic -!-------------------------------------------------------------------------- -! Define grid object for GFS grib2 data. Only works for data on -! global lat/lon or gaussian grids. -!-------------------------------------------------------------------------- - +!> Define input grid object for GFS grib2 data. Only works for data on +!! global lat/lon or gaussian grids. +!! +!! @param [in] localpet ESMF local persistent execution thread +!! @param [in] npets Number of persistent execution threads +!! @author George Gayno NCEP/EMC subroutine define_input_grid_gfs_grib2(localpet, npets) use wgrib2api @@ -786,6 +796,12 @@ subroutine define_input_grid_gfs_grib2(localpet, npets) end subroutine define_input_grid_gfs_grib2 +!> Define input grid object for non-GFS grib2 data. +!! +!! @param [in] localpet ESMF local persistent execution thread +!! @param [in] npets Number of persistent execution threads +!! @author Larissa Reames +!! @author Jeff Beck subroutine define_input_grid_grib2(localpet, npets) use mpi @@ -1079,9 +1095,11 @@ subroutine define_input_grid_grib2(localpet, npets) end subroutine define_input_grid_grib2 -!> @brief -!! Setup the esmf grid object for the target grid. +!> Setup the esmf grid object for the target grid. !! +!! @param [in] localpet ESMF local persistent execution thread +!! @param [in] npets Number of persistent execution threads +!! @author George Gayno NCEP/EMC subroutine define_target_grid(localpet, npets) use netcdf @@ -1352,10 +1370,24 @@ subroutine define_target_grid(localpet, npets) end subroutine define_target_grid -!----------------------------------------------------------------------- -! Read model lat/lons for a single tile from the "grid" file. -!----------------------------------------------------------------------- - +!> Read model lat/lons for a single tile from the "grid" +!! specificaton file. +!! +!! @param [in] mosaic_file The mosaic file associated with the 'grid' files. +!! @param [in] orog_dir Directory containing the 'grid' and orography files. +!! @param [in] num_tiles Total number of tiles +!! @param [in] tile Tile number to be read +!! @param [in] i_tile "i" dimension of the tile +!! @param [in] j_tile "j" dimension of the tile +!! @param [in] ip1_tile "i" dimension of the tile plus 1 +!! @param [in] jp1_tile "j" dimension of the tile plus 1 +!! @param [out] latitude grid box center latitude +!! @param [out] latitude_s latitude of 'south' edge of grid box +!! @param [out] latitude_w latitude of 'west' edge of grid box +!! @param [out] longitude grid box center longitude +!! @param [out] longitude_s longitude of 'south' edge of grid box +!! @param [out] longitude_w longitude of 'west' edge of grid box +!! @author George Gayno NCEP/EMC subroutine get_model_latlons(mosaic_file, orog_dir, num_tiles, tile, & i_tile, j_tile, ip1_tile, jp1_tile, & latitude, latitude_s, latitude_w, & @@ -1498,11 +1530,18 @@ subroutine get_model_latlons(mosaic_file, orog_dir, num_tiles, tile, & end subroutine get_model_latlons - !---------------------------------------------------------------------------------------- -! For grids with equal cell sizes (e.g., lambert conformal), get lat and on of the grid -! cell corners -!---------------------------------------------------------------------------------------- - +!> For grids with equal cell sizes (e.g., lambert conformal), get +!! latitude and longitude of the grid cell corners. +!! +!! @param [in] latitude grid box center latitude +!! @param [in] longitude grid box center longitude +!! @param [inout] latitude_sw latitude of the 'southwest' corner of grid box +!! @param [inout] longitude_sw longitude of the 'southwest' corner of grid box +!! @param [in] dx grid cell side size in meters +!! @param [in] clb lower bounds of indices processed by this mpi task +!! @param [in] cub upper bounds of indices processed by this mpi task +!! @author Larissa Reames +!! @author Jeff Beck subroutine get_cell_corners( latitude, longitude, latitude_sw, longitude_sw, dx,clb,cub) implicit none @@ -1510,7 +1549,7 @@ subroutine get_cell_corners( latitude, longitude, latitude_sw, longitude_sw, dx, real(esmf_kind_r8), intent(inout), pointer :: latitude_sw(:,:) real(esmf_kind_r8), intent(in) :: longitude(i_input, j_input) real(esmf_kind_r8), intent(inout), pointer :: longitude_sw(:,:) - real(esmf_kind_r8), intent(in) :: dx !grid cell side size (m) + real(esmf_kind_r8), intent(in) :: dx integer, intent(in) :: clb(2), cub(2) @@ -1576,10 +1615,15 @@ subroutine get_cell_corners( latitude, longitude, latitude_sw, longitude_sw, dx, end subroutine get_cell_corners -!----------------------------------------------------------------------- -! Read the model land mask and terrain for a single tile. -!----------------------------------------------------------------------- - +!> Read the model land mask and terrain for a single tile +!! from the orography file. +!! +!! @param [in] orog_file Path/name of orography file +!! @param [in] idim "i" dimension of tile +!! @param [in] jdim "j" dimension of tile +!! @param [out] mask land mask of tile +!! @param [out] terrain terrain height of tile +!! @author George Gayno NCEP/EMC subroutine get_model_mask_terrain(orog_file, idim, jdim, mask, terrain) use netcdf @@ -1644,8 +1688,9 @@ subroutine get_model_mask_terrain(orog_file, idim, jdim, mask, terrain) end subroutine get_model_mask_terrain -!> @brief Deallocate all esmf grid objects. +!> Deallocate all esmf grid objects. !! +!! @author George Gayno NCEP/EMC subroutine cleanup_input_target_grid_data implicit none From 44ec284571d18a17a9a7f602f405a273cdb4ee73 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 07:28:35 -0700 Subject: [PATCH 33/47] Start of testing for program_setup.F90 (#304) * adding program_setup test * more test on program_setup test --- tests/chres_cube/CMakeLists.txt | 40 +++++++++++++++++------ tests/chres_cube/config.nml | 23 ++++++++++++++ tests/chres_cube/ftst_program_setup.F90 | 42 +++++++++++++++++++++++++ 3 files changed, 96 insertions(+), 9 deletions(-) create mode 100644 tests/chres_cube/config.nml create mode 100644 tests/chres_cube/ftst_program_setup.F90 diff --git a/tests/chres_cube/CMakeLists.txt b/tests/chres_cube/CMakeLists.txt index f7c3b64ae..bf2dd2210 100644 --- a/tests/chres_cube/CMakeLists.txt +++ b/tests/chres_cube/CMakeLists.txt @@ -3,22 +3,20 @@ # # George Gayno, Lin Gan, Ed Hartnett -set(fortran_src - "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/utils.f90" - ftst_utils.F90) - if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian -assume byterecl") elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffree-line-length-0 -fdefault-real-8 -fconvert=big-endian") endif() -include_directories( - ${PROJECT_SOURCE_DIR} -) +include_directories(${PROJECT_SOURCE_DIR}) + +# Copy necessary test files. +execute_process( COMMAND ${CMAKE_COMMAND} -E copy + ${CMAKE_CURRENT_SOURCE_DIR}/config.nml + ${CMAKE_CURRENT_BINARY_DIR}/fort.41) -set(exe_name ftst_utils) -add_executable(${exe_name} ${fortran_src}) +add_executable(ftst_utils "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/utils.f90" ftst_utils.F90) add_test(NAME ftst_utils COMMAND ftst_utils) target_link_libraries( ftst_utils @@ -37,6 +35,30 @@ if(OpenMP_Fortran_FOUND) target_link_libraries(ftst_utils OpenMP::OpenMP_Fortran) endif() +add_executable(ftst_program_setup "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/input_data.F90" + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/model_grid.F90" + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/program_setup.f90" + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/grib2_util.F90" + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/search_util.f90" + "${CMAKE_SOURCE_DIR}/sorc/chgres_cube.fd/utils.f90" + ftst_program_setup.F90) +add_test(NAME ftst_program_setup COMMAND ftst_program_setup) +target_link_libraries( + ftst_program_setup + nemsio::nemsio + sfcio::sfcio + sigio::sigio + bacio::bacio_4 + sp::sp_d + w3nco::w3nco_d + esmf + wgrib2::wgrib2_lib + wgrib2::wgrib2_api + MPI::MPI_Fortran + NetCDF::NetCDF_Fortran) +if(OpenMP_Fortran_FOUND) + target_link_libraries(ftst_program_setup OpenMP::OpenMP_Fortran) +endif() diff --git a/tests/chres_cube/config.nml b/tests/chres_cube/config.nml new file mode 100644 index 000000000..7d47c9b8d --- /dev/null +++ b/tests/chres_cube/config.nml @@ -0,0 +1,23 @@ +&config + mosaic_file_target_grid="/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96/C96_mosaic.nc" + fix_dir_target_grid="/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96/fix_sfc" + orog_dir_target_grid="/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96" + orog_files_target_grid="C96_oro_data.tile1.nc","C96_oro_data.tile2.nc","C96_oro_data.tile3.nc","C96_oro_data.tile4.nc","C96_oro_data.tile5.nc","C96_oro_data.tile6.nc" + vcoord_file_target_grid="/scratch1/NCEPDEV/da/George.Gayno/ufs_utils.git/UFS_UTILS/reg_tests/chgres_cube/../../fix/fix_am/global_hyblev.l64.txt" + data_dir_input_grid="/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/input_data/fv3.nemsio" + atm_files_input_grid="gfs.t12z.atmf000.nemsio" + sfc_files_input_grid="gfs.t12z.sfcf000.nemsio" + cycle_mon=07 + cycle_day=04 + cycle_hour=12 + convert_atm=.true. + convert_sfc=.true. + convert_nst=.true. + input_type="gaussian_nemsio" + tracers="sphum","liq_wat","o3mr","ice_wat","rainwat","snowwat","graupel" + tracers_input="spfh","clwmr","o3mr","icmr","rwmr","snmr","grle" + regional=0 + halo_bndy=0 + halo_blend=0 + / + \ No newline at end of file diff --git a/tests/chres_cube/ftst_program_setup.F90 b/tests/chres_cube/ftst_program_setup.F90 new file mode 100644 index 000000000..8bb3b02c0 --- /dev/null +++ b/tests/chres_cube/ftst_program_setup.F90 @@ -0,0 +1,42 @@ +! Unit test for chres_cube utility, input_data.F90. +! +! Ed Hartnett 2/16/21 + +program ftst_program_setup + use esmf + use netcdf + use program_setup + implicit none + + print*, "Starting test of program_setup." + + print*, "testing read_setup_namelist..." + call read_setup_namelist() + if (cycle_mon .ne. 7 .or. cycle_day .ne. 4 .or. cycle_hour .ne. 12) stop 4 + if (.not. convert_atm .or. .not. convert_sfc .or. .not. convert_nst) stop 5 + if (regional .ne. 0 .or. halo_bndy .ne. 0 .or. halo_blend .ne. 0) stop 6 + if (trim(mosaic_file_target_grid) .ne. "/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96/C96_mosaic.nc") stop 7 + if (trim(fix_dir_target_grid) .ne. "/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96/fix_sfc") stop 8 + if (trim(orog_dir_target_grid) .ne. "/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/fix/C96/") stop 9 + if (trim(vcoord_file_target_grid) .ne. "/scratch1/NCEPDEV/da/George.Gayno/ufs_utils.git/UFS_UTILS/reg_tests/chgres_cube/../../fix/fix_am/global_hyblev.l64.txt") stop 10 + if (trim(data_dir_input_grid) .ne. "/scratch1/NCEPDEV/da/George.Gayno/noscrub/reg_tests/chgres_cube/input_data/fv3.nemsio") stop 11 + if (trim(atm_files_input_grid(1)) .ne. 'gfs.t12z.atmf000.nemsio') stop 12 + if (trim(sfc_files_input_grid(1)) .ne. 'gfs.t12z.sfcf000.nemsio') stop 13 + if (varmap_file .ne. "NULL") stop 14 + if (thomp_mp_climo_file .ne. "NULL") stop 16 + if (trim(cres_target_grid) .ne. "C96") stop 17 + if (atm_weight_file .ne. "NULL") stop 18 + if (trim(input_type) .ne. "gaussian_nemsio") stop 19 + if (trim(external_model) .ne. "GFS") stop 20 + if (num_tracers .ne. 7) stop 21 + if (tracers(1) .ne. "sphum" .or. tracers(2) .ne. "liq_wat" .or. tracers(3) .ne. "o3mr" .or. & + tracers(4) .ne. "ice_wat" .or. tracers(5) .ne. "rainwat" .or. tracers(6) .ne. "snowwat" .or. & + tracers(7) .ne. "graupel") stop 22 + if (tracers_input(1) .ne. "spfh" .or. tracers_input(2) .ne. "clwmr" .or. & + tracers_input(3) .ne. "o3mr" .or. tracers_input(4) .ne. "icmr" .or. & + tracers_input(5) .ne. "rwmr" .or. tracers_input(6) .ne. "snmr" .or. & + tracers_input(7) .ne. "grle") stop 23 + print*, "OK" + + print*, "SUCCESS!" +end program ftst_program_setup From 445b0b8a2118e1f3f2aca9dd27cbd5dcea647736 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 09:13:33 -0700 Subject: [PATCH 34/47] updated readme (#323) --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index fa9ebf34e..f397054d5 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,9 @@ Utilities for the NCEP models. This is part of the [NCEPLIBS](https://github.com/NOAA-EMC/NCEPLIBS) project. +Documentation for the chgres_cube utility can be found at +https://noaa-emcufs-utils.readthedocs.io/en/latest/. + Complete documentation can be found at https://noaa-emc.github.io/UFS_UTILS/. From 268516498c8567e8b253442ddb1a9067b6672e79 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 10:04:36 -0700 Subject: [PATCH 35/47] consolidated gitignore files (#322) * consolidated gitignore files * consolidated gitignore files --- .gitignore | 4 ++++ fix/.gitignore | 5 ----- sorc/chgres_cube.fd/.gitignore | 3 --- sorc/emcsfc_ice_blend.fd/.gitignore | 2 -- sorc/orog_mask_tools.fd/orog.fd/.gitignore | 1 - 5 files changed, 4 insertions(+), 11 deletions(-) delete mode 100644 fix/.gitignore delete mode 100644 sorc/chgres_cube.fd/.gitignore delete mode 100644 sorc/emcsfc_ice_blend.fd/.gitignore delete mode 100644 sorc/orog_mask_tools.fd/orog.fd/.gitignore diff --git a/.gitignore b/.gitignore index 53eb8fe30..22aa75a65 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,7 @@ exec/ *.x *.swp +*.o +emcsfc_ice_blend +ml01rg2.x + diff --git a/fix/.gitignore b/fix/.gitignore deleted file mode 100644 index 4636ed709..000000000 --- a/fix/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -fix_am -fix_fv3 -fix_fv3_gmted2010 -fix_orog -fix_sfc_climo diff --git a/sorc/chgres_cube.fd/.gitignore b/sorc/chgres_cube.fd/.gitignore deleted file mode 100644 index 865bc8b6c..000000000 --- a/sorc/chgres_cube.fd/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -*.o -*.mod -*exe diff --git a/sorc/emcsfc_ice_blend.fd/.gitignore b/sorc/emcsfc_ice_blend.fd/.gitignore deleted file mode 100644 index febadbf70..000000000 --- a/sorc/emcsfc_ice_blend.fd/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.o -emcsfc_ice_blend diff --git a/sorc/orog_mask_tools.fd/orog.fd/.gitignore b/sorc/orog_mask_tools.fd/orog.fd/.gitignore deleted file mode 100644 index 2c9c24081..000000000 --- a/sorc/orog_mask_tools.fd/orog.fd/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ml01rg2.x From ce385b215474751d3fb4e6af885d83738310eec9 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 10:29:25 -0700 Subject: [PATCH 36/47] doxygen for program_setup.f90 (#290) * doxygen for program_setup.f90 * update doxygen for all routines in chgres_cube.fd/program_setup.f90. Remove unused f11 soil variable. Issue #191 * Begin the move of variable definitions out of the prolog. (chgres_cube.fd/program_setup.f90) Co-authored-by: George Gayno --- sorc/chgres_cube.fd/program_setup.f90 | 79 +++++++++++++++++---------- 1 file changed, 51 insertions(+), 28 deletions(-) diff --git a/sorc/chgres_cube.fd/program_setup.f90 b/sorc/chgres_cube.fd/program_setup.f90 index 7bf070e93..919661f7c 100644 --- a/sorc/chgres_cube.fd/program_setup.f90 +++ b/sorc/chgres_cube.fd/program_setup.f90 @@ -1,15 +1,12 @@ !> @file !! @brief Set up program execution !! -!! @author gayno NCEP/EMC +!! @author George Gayno NCEP/EMC !! !! Set up program execution !! !! Public variables: !! -!! - atm_files_input_grid - File names of input atmospheric data. -!! Not used for "grib2" or "restart" -!! input types. !! - atm_core_files_input_grid - File names of input atmospheric restart !! core files. Only used for 'restart' !! input type. @@ -100,7 +97,7 @@ !! MP climatological tracers. False, !! when 'thomp_mp_climo_file' is NULL. !! - vcoord_file_target_grid - Vertical coordinate definition file -!! - wltsmc_input/target - Wilting point soil moisture content +!! - wltsmc_input/target - Plant wilting point soil moisture content !! input/target grids !! - nsoill_out - Number of soil levels desired in the output data. !! chgres_cube can interpolate from 9 input to 4 output @@ -158,7 +155,10 @@ module program_setup private character(len=500), public :: varmap_file = "NULL" - character(len=500), public :: atm_files_input_grid(6) = "NULL" + character(len=500), public :: atm_files_input_grid(6) = "NULL" !< File names of input + !< atmospheric data. Not used + !< for "grib2" or "restart" + !< input types. character(len=500), public :: atm_core_files_input_grid(7) = "NULL" character(len=500), public :: atm_tracer_files_input_grid(6) = "NULL" character(len=500), public :: data_dir_input_grid = "NULL" @@ -234,10 +234,9 @@ module program_setup contains -!> @brief Reads configuration namelist. -!! -!! @author gayno NCEP/EMC +!> Reads program configuration namelist. !! +!! @author George Gayno NCEP/EMC subroutine read_setup_namelist implicit none @@ -412,6 +411,11 @@ subroutine read_setup_namelist end subroutine read_setup_namelist +!> Reads the variable mapping table, which is +!! required for initializing with GRIB2 data. +!! +!! @author Larissa Reames +!! @author Jeff Beck subroutine read_varmap implicit none @@ -469,16 +473,24 @@ subroutine read_varmap endif end subroutine read_varmap -! ---------------------------------------------------------------------------------------- -! Find conditions for handling missing variables from varmap arrays -! ---------------------------------------------------------------------------------------- - +!> Search the variable mapping table to find conditions for handling +!! missing variables. Only applicable when using GRIB2 data as +!! input. +!! +!! @param [in] var_name table variable name to search for +!! @param [out] this_miss_var_method the method used to replace missing data +!! @param [out] this_miss_var_value the value used to replace missing data +!! @param [out] this_field_var_name name of variable in output file. not +!! currently implemented. +!! @param [out] loc variable table location index +!! @author Larissa Reames +!! @author Jeff Beck subroutine get_var_cond(var_name,this_miss_var_method,this_miss_var_value, & this_field_var_name, loc) use esmf implicit none - character(len=20) :: var_name + character(len=20), intent(in) :: var_name character(len=20), optional, intent(out) :: this_miss_var_method, & this_field_var_name @@ -512,10 +524,11 @@ subroutine get_var_cond(var_name,this_miss_var_method,this_miss_var_value, & end subroutine get_var_cond -!> @brief Compute soil parameters. -!! -!! @author gayno NCEP/EMC +!> Driver routine to compute soil parameters for each +!! soil type. Works for Zobler and STATSGO soil categories. !! +!! @param [in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine calc_soil_params_driver(localpet) implicit none @@ -545,7 +558,6 @@ subroutine calc_soil_params_driver(localpet) real, allocatable :: bb(:) real :: smlow, smhigh - real, allocatable :: f11(:) real, allocatable :: satdk(:) real, allocatable :: satpsi(:) real, allocatable :: satdw(:) @@ -600,7 +612,6 @@ subroutine calc_soil_params_driver(localpet) allocate(satdk(num_soil_cats)) allocate(satpsi(num_soil_cats)) allocate(satdw(num_soil_cats)) - allocate(f11(num_soil_cats)) select case (trim(input_type)) case ("gfs_sigio") @@ -620,9 +631,9 @@ subroutine calc_soil_params_driver(localpet) end select call calc_soil_params(num_soil_cats, smlow, smhigh, satdk, maxsmc_input, & - bb, satpsi, satdw, f11, refsmc_input, drysmc_input, wltsmc_input) + bb, satpsi, satdw, refsmc_input, drysmc_input, wltsmc_input) - deallocate(bb, satdk, satpsi, satdw, f11) + deallocate(bb, satdk, satpsi, satdw) if (localpet == 0) print*,'maxsmc input grid ',maxsmc_input if (localpet == 0) print*,'wltsmc input grid ',wltsmc_input @@ -643,7 +654,6 @@ subroutine calc_soil_params_driver(localpet) allocate(satpsi_target(num_soil_cats)) allocate(satdk(num_soil_cats)) allocate(satdw(num_soil_cats)) - allocate(f11(num_soil_cats)) smlow = smlow_statsgo smhigh = smhigh_statsgo @@ -653,17 +663,33 @@ subroutine calc_soil_params_driver(localpet) satpsi_target = satpsi_statsgo call calc_soil_params(num_soil_cats, smlow, smhigh, satdk, maxsmc_target, & - bb_target, satpsi_target, satdw, f11, refsmc_target, drysmc_target, wltsmc_target) + bb_target, satpsi_target, satdw, refsmc_target, drysmc_target, wltsmc_target) - deallocate(satdk, satdw, f11) + deallocate(satdk, satdw) if (localpet == 0) print*,'maxsmc target grid ',maxsmc_target if (localpet == 0) print*,'wltsmc input grid ',wltsmc_target end subroutine calc_soil_params_driver +!> Compute soil parameters. Will be used to rescale soil moisture +!! differences in soil type between the input grid and target +!! model grid. +!! +!! @param [in] num_soil_cats number of soil type categories +!! @param [in] smlow reference parameter for wltsmc +!! @param [in] smhigh reference parameter for refsmc +!! @param [in] satdk saturated soil moisture hydraulic conductivity +!! @param [in] maxsmc maximum soil moisture (porosity) +!! @param [in] bb soil 'b' parameter +!! @param [in] satpsi saturated soil potential +!! @param [out] satdw saturated soil diffusivity/conductivity coefficient +!! @param [out] refsmc onset of soil moisture stress (field capacity) +!! @param [out] drysmc air dry soil moisture limit +!! @param [out] wltsmc plant soil moisture wilting point +!! @author George Gayno NCEP/EMC subroutine calc_soil_params(num_soil_cats, smlow, smhigh, satdk, & - maxsmc, bb, satpsi, satdw, f11, refsmc, drysmc, wltsmc) + maxsmc, bb, satpsi, satdw, refsmc, drysmc, wltsmc) implicit none @@ -675,7 +701,6 @@ subroutine calc_soil_params(num_soil_cats, smlow, smhigh, satdk, & real, intent(in) :: satdk(num_soil_cats) real, intent(in) :: satpsi(num_soil_cats) - real, intent(out) :: f11(num_soil_cats) real, intent(out) :: satdw(num_soil_cats) real, intent(out) :: refsmc(num_soil_cats) real, intent(out) :: drysmc(num_soil_cats) @@ -687,7 +712,6 @@ subroutine calc_soil_params(num_soil_cats, smlow, smhigh, satdk, & real :: wltsmc1 satdw = 0.0 - f11 = 0.0 refsmc = 0.0 wltsmc = 0.0 drysmc = 0.0 @@ -697,7 +721,6 @@ subroutine calc_soil_params(num_soil_cats, smlow, smhigh, satdk, & if (maxsmc(i) > 0.0) then SATDW(I) = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I)) - F11(I) = ALOG10(SATPSI(I)) + BB(I)*ALOG10(MAXSMC(I)) + 2.0 REFSMC1 = MAXSMC(I)*(5.79E-9/SATDK(I)) **(1.0/(2.0*BB(I)+3.0)) REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH WLTSMC1 = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I)) From 6579ed60be137bf8a185eb890e7b3ba2382e6c86 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 10:53:44 -0700 Subject: [PATCH 37/47] trying to build test for fre-nctools.fd/shared_lib/create_xgrid.c (#301) * trying to build test * adding test * adding test * getting tst_create_xgrid working --- sorc/fre-nctools.fd/shared_lib/create_xgrid.c | 538 ------------------ tests/CMakeLists.txt | 1 + tests/fre-nctools/CMakeLists.txt | 13 + tests/fre-nctools/shared_lib/CMakeLists.txt | 16 + .../fre-nctools/shared_lib/tst_create_xgrid.c | 535 +++++++++++++++++ 5 files changed, 565 insertions(+), 538 deletions(-) create mode 100644 tests/fre-nctools/CMakeLists.txt create mode 100644 tests/fre-nctools/shared_lib/CMakeLists.txt create mode 100644 tests/fre-nctools/shared_lib/tst_create_xgrid.c diff --git a/sorc/fre-nctools.fd/shared_lib/create_xgrid.c b/sorc/fre-nctools.fd/shared_lib/create_xgrid.c index 858c5b5c4..4f4cb71c8 100644 --- a/sorc/fre-nctools.fd/shared_lib/create_xgrid.c +++ b/sorc/fre-nctools.fd/shared_lib/create_xgrid.c @@ -2264,541 +2264,3 @@ int inside_edge(double x0, double y0, double x1, double y1, double x, double y) return (product<=SMALL) ? 1:0; }; /* inside_edge */ - - -/* The following is a test program to test subroutines in create_xgrid.c */ - -#ifdef test_create_xgrid - -#include "create_xgrid.h" -#include - -#define D2R (M_PI/180) -#define R2D (180/M_PI) -#define MAXPOINT 1000 - -int main(int argc, char* argv[]) -{ - - double lon1_in[MAXPOINT], lat1_in[MAXPOINT]; - double lon2_in[MAXPOINT], lat2_in[MAXPOINT]; - double x1_in[MAXPOINT], y1_in[MAXPOINT], z1_in[MAXPOINT]; - double x2_in[MAXPOINT], y2_in[MAXPOINT], z2_in[MAXPOINT]; - double lon_out[20], lat_out[20]; - double x_out[20], y_out[20], z_out[20]; - int n1_in, n2_in, n_out, i, j; - int nlon1=0, nlat1=0, nlon2=0, nlat2=0; - int n; - int ntest = 11; - - - for(n=11; n<=ntest; n++) { - - switch (n) { - case 1: - /**************************************************************** - - test clip_2dx2d_great_cirle case 1: - box 1: (20,10), (20,12), (22,12), (22,10) - box 2: (21,11), (21,14), (24,14), (24,11) - out : (21, 12.0018), (22, 12), (22, 11.0033), (21, 11) - - ****************************************************************/ - n1_in = 4; n2_in = 4; - /* first a simple lat-lon grid box to clip another lat-lon grid box */ - lon1_in[0] = 20; lat1_in[0] = 10; - lon1_in[1] = 20; lat1_in[1] = 12; - lon1_in[2] = 22; lat1_in[2] = 12; - lon1_in[3] = 22; lat1_in[3] = 10; - lon2_in[0] = 21; lat2_in[0] = 11; - lon2_in[1] = 21; lat2_in[1] = 14; - lon2_in[2] = 24; lat2_in[2] = 14; - lon2_in[3] = 24; lat2_in[3] = 11; - break; - - case 2: - /**************************************************************** - - test clip_2dx2d_great_cirle case 2: two identical box - box 1: (20,10), (20,12), (22,12), (22,10) - box 2: (20,10), (20,12), (22,12), (22,10) - out : (20,10), (20,12), (22,12), (22,10) - - ****************************************************************/ - lon1_in[0] = 20; lat1_in[0] = 10; - lon1_in[1] = 20; lat1_in[1] = 12; - lon1_in[2] = 22; lat1_in[2] = 12; - lon1_in[3] = 22; lat1_in[3] = 10; - - for(i=0; i 10 ) { - int nxgrid; - int *i1, *j1, *i2, *j2; - double *xarea, *xclon, *xclat, *mask1; - - mask1 = (double *)malloc(nlon1*nlat1*sizeof(double)); - i1 = (int *)malloc(MAXXGRID*sizeof(int)); - j1 = (int *)malloc(MAXXGRID*sizeof(int)); - i2 = (int *)malloc(MAXXGRID*sizeof(int)); - j2 = (int *)malloc(MAXXGRID*sizeof(int)); - xarea = (double *)malloc(MAXXGRID*sizeof(double)); - xclon = (double *)malloc(MAXXGRID*sizeof(double)); - xclat = (double *)malloc(MAXXGRID*sizeof(double)); - - for(i=0; i +#include +#include + +#define D2R (M_PI/180) +#define R2D (180/M_PI) +#define MAXPOINT 1000 + +int main(int argc, char* argv[]) +{ + + double lon1_in[MAXPOINT], lat1_in[MAXPOINT]; + double lon2_in[MAXPOINT], lat2_in[MAXPOINT]; + double x1_in[MAXPOINT], y1_in[MAXPOINT], z1_in[MAXPOINT]; + double x2_in[MAXPOINT], y2_in[MAXPOINT], z2_in[MAXPOINT]; + double lon_out[20], lat_out[20]; + double x_out[20], y_out[20], z_out[20]; + int n1_in, n2_in, n_out, i, j; + int nlon1=0, nlat1=0, nlon2=0, nlat2=0; + int n; + int ntest = 11; + + printf("Testing create_xgrid.\n"); + + for(n=11; n<=ntest; n++) { + + switch (n) { + case 1: + /**************************************************************** + + test clip_2dx2d_great_cirle case 1: + box 1: (20,10), (20,12), (22,12), (22,10) + box 2: (21,11), (21,14), (24,14), (24,11) + out : (21, 12.0018), (22, 12), (22, 11.0033), (21, 11) + + ****************************************************************/ + n1_in = 4; n2_in = 4; + /* first a simple lat-lon grid box to clip another lat-lon grid box */ + lon1_in[0] = 20; lat1_in[0] = 10; + lon1_in[1] = 20; lat1_in[1] = 12; + lon1_in[2] = 22; lat1_in[2] = 12; + lon1_in[3] = 22; lat1_in[3] = 10; + lon2_in[0] = 21; lat2_in[0] = 11; + lon2_in[1] = 21; lat2_in[1] = 14; + lon2_in[2] = 24; lat2_in[2] = 14; + lon2_in[3] = 24; lat2_in[3] = 11; + break; + + case 2: + /**************************************************************** + + test clip_2dx2d_great_cirle case 2: two identical box + box 1: (20,10), (20,12), (22,12), (22,10) + box 2: (20,10), (20,12), (22,12), (22,10) + out : (20,10), (20,12), (22,12), (22,10) + + ****************************************************************/ + lon1_in[0] = 20; lat1_in[0] = 10; + lon1_in[1] = 20; lat1_in[1] = 12; + lon1_in[2] = 22; lat1_in[2] = 12; + lon1_in[3] = 22; lat1_in[3] = 10; + + for(i=0; i 10 ) { + int nxgrid; + int *i1, *j1, *i2, *j2; + double *xarea, *xclon, *xclat, *mask1; + + mask1 = (double *)malloc(nlon1*nlat1*sizeof(double)); + i1 = (int *)malloc(MAXXGRID*sizeof(int)); + j1 = (int *)malloc(MAXXGRID*sizeof(int)); + i2 = (int *)malloc(MAXXGRID*sizeof(int)); + j2 = (int *)malloc(MAXXGRID*sizeof(int)); + xarea = (double *)malloc(MAXXGRID*sizeof(double)); + xclon = (double *)malloc(MAXXGRID*sizeof(double)); + xclat = (double *)malloc(MAXXGRID*sizeof(double)); + + for(i=0; i Date: Fri, 19 Feb 2021 12:40:37 -0700 Subject: [PATCH 38/47] improved docs in write_data (#306) * improved docs in write_data * Update author in chgres_cube.fd/write_data.F90 Fixes #305 Part of #191 Co-authored-by: George Gayno --- sorc/chgres_cube.fd/write_data.F90 | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/sorc/chgres_cube.fd/write_data.F90 b/sorc/chgres_cube.fd/write_data.F90 index c4014bbae..ff142ec23 100644 --- a/sorc/chgres_cube.fd/write_data.F90 +++ b/sorc/chgres_cube.fd/write_data.F90 @@ -1,16 +1,16 @@ !> @file !! @brief Write model coldstart files. !! -!! @author gayno NCEP/EMC +!! @author George Gayno NCEP/EMC !! !! Write out target grid data into appropriate files for !! the forecast model. !! -!> @brief Writes atmospheric header file in netcdf format -!! -!! @author gayno NCEP/EMC +!> Writes atmospheric header file in netcdf format. !! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine write_fv3_atm_header_netcdf(localpet) use esmf @@ -79,12 +79,11 @@ subroutine write_fv3_atm_header_netcdf(localpet) end subroutine write_fv3_atm_header_netcdf -!> @brief -!! Writes atmospheric fields along the lateral boundary. -!! For regional grids only. Output in netcdf format. +!> Writes atmospheric fields along the lateral boundary. +!! For regional grids only. Output in netcdf format. !! -!! @author gayno NCEP/EMC -!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine write_fv3_atm_bndy_data_netcdf(localpet) !--------------------------------------------------------------------------- @@ -1183,14 +1182,14 @@ subroutine write_fv3_atm_bndy_data_netcdf(localpet) end subroutine write_fv3_atm_bndy_data_netcdf -!> @brief Write atmospheric coldstart files (netcdf format). -!! -!! @author gayno NCEP/EMC +!> Write atmospheric coldstart files (netcdf format). !! !! Routine writes tiled files in parallel. Tile 1 is written by !! localpet 0; tile 2 by localpet 1, etc. The number of pets !! must be equal to or greater than the number of tiled files. !! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine write_fv3_atm_data_netcdf(localpet) use esmf @@ -1800,10 +1799,10 @@ subroutine write_fv3_atm_data_netcdf(localpet) end subroutine write_fv3_atm_data_netcdf -!> @brief Writes surface and nst data into a 'coldstart' file (netcdf). +!> Writes surface and nst data into a 'coldstart' file (netcdf). !! -!! @author gayno NCEP/EMC -!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine write_fv3_sfc_data_netcdf(localpet) use esmf From fd9054680bba361474a6946316a46fdb1a213f7f Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Fri, 19 Feb 2021 14:06:21 -0700 Subject: [PATCH 39/47] doxygen improvements for chgres_cube.fd/atmosphere.F90 and grib2_util.F90, turn on doxygen cross-references (#287) * doxygen improvements * cleanup * adding comments to grib2_util.F90 * more doxygen fixes * update doxygen for ./chgres_cube.fd/grib2_util.F90 Part of #191 Fixes #288 * Minor doxygen updates to ./chgres_cube.fd/atmosphere.F90 Part of #191 Fixes #288 Co-authored-by: George Gayno --- sorc/CMakeLists.txt | 4 + sorc/chgres_cube.fd/CMakeLists.txt | 3 +- sorc/chgres_cube.fd/atmosphere.F90 | 517 ++++++++++++----------------- sorc/chgres_cube.fd/grib2_util.F90 | 24 +- 4 files changed, 248 insertions(+), 300 deletions(-) diff --git a/sorc/CMakeLists.txt b/sorc/CMakeLists.txt index 7a8c64347..d7f473dc2 100644 --- a/sorc/CMakeLists.txt +++ b/sorc/CMakeLists.txt @@ -1,3 +1,7 @@ +# This is the cmake build file for the chgres_cube utility in the +# UFS_UTILS project. +# +# George Gayno add_subdirectory(emcsfc_ice_blend.fd) add_subdirectory(emcsfc_snow2mdl.fd) if (OpenMP_FOUND) diff --git a/sorc/chgres_cube.fd/CMakeLists.txt b/sorc/chgres_cube.fd/CMakeLists.txt index 2d5350738..8366f4771 100644 --- a/sorc/chgres_cube.fd/CMakeLists.txt +++ b/sorc/chgres_cube.fd/CMakeLists.txt @@ -1,4 +1,5 @@ -# This is the CMake build file for the chgres_cube utility in the UFS_UTILS package. +# This is the CMake build file for the chgres_cube utility in the +# UFS_UTILS package. # # George Gayno, Mark Potts diff --git a/sorc/chgres_cube.fd/atmosphere.F90 b/sorc/chgres_cube.fd/atmosphere.F90 index 7f5b4cbcf..5d0bacf35 100644 --- a/sorc/chgres_cube.fd/atmosphere.F90 +++ b/sorc/chgres_cube.fd/atmosphere.F90 @@ -1,8 +1,6 @@ !> @file !! @brief Process atmospheric fields !! -!! @author gayno NCEP/EMC -!! !! Process atmospheric fields: Horizontally interpolate input !! fields to the target grid. Adjust surface pressure according to !! terrain difference between input and target grids. Vertically @@ -15,6 +13,8 @@ !! on the 'south' edge of the grid box. "_w" indicate fields on the !! 'west' edge of the grid box. Otherwise, fields are at the center !! of the grid box. +!! +!! @author gayno NCEP/EMC module atmosphere use esmf @@ -55,84 +55,57 @@ module atmosphere private - integer, public :: lev_target ! num vertical levels - integer, public :: levp1_target ! num levels plus 1 - integer, public :: nvcoord_target ! num vertical coordinate - ! variables - - real(esmf_kind_r8), allocatable, public :: vcoord_target(:,:) ! vertical coordinate - - type(esmf_field), public :: delp_target_grid - ! pressure thickness - type(esmf_field), public :: dzdt_target_grid - ! vertical velocity - type(esmf_field) :: dzdt_b4adj_target_grid - ! vertical vel before vert adj - type(esmf_field), allocatable, public :: tracers_target_grid(:) - ! tracers - type(esmf_field), allocatable :: tracers_b4adj_target_grid(:) - ! tracers before vert adj - type(esmf_field), public :: ps_target_grid - ! surface pressure - type(esmf_field) :: ps_b4adj_target_grid - ! sfc pres before terrain adj - type(esmf_field) :: pres_target_grid - ! 3-d pressure - type(esmf_field) :: pres_b4adj_target_grid - ! 3-d pres before terrain adj - type(esmf_field), public :: temp_target_grid - ! temperautre - type(esmf_field) :: temp_b4adj_target_grid - ! temp before vert adj - type(esmf_field) :: terrain_interp_to_target_grid - ! Input grid terrain - ! interpolated to target grid. - type(esmf_field), public :: u_s_target_grid - ! u-wind, 'south' edge - type(esmf_field), public :: v_s_target_grid - ! v-wind, 'south' edge - type(esmf_field) :: wind_target_grid - ! 3-d wind, grid box center - type(esmf_field) :: wind_b4adj_target_grid - ! 3-d wind before vert adj - type(esmf_field) :: wind_s_target_grid - ! 3-d wind, 'south' edge - type(esmf_field), public :: u_w_target_grid - ! u-wind, 'west' edge - type(esmf_field), public :: v_w_target_grid - ! v-wind, 'west' edge - type(esmf_field) :: wind_w_target_grid - ! 3-d wind, 'west' edge - type(esmf_field), public :: zh_target_grid - ! 3-d height + integer, public :: lev_target !< num vertical levels + integer, public :: levp1_target !< num levels plus 1 + integer, public :: nvcoord_target !< num vertical coordinate variables + + real(esmf_kind_r8), allocatable, public :: vcoord_target(:,:) !< vertical coordinate + + type(esmf_field), public :: delp_target_grid !< pressure thickness + type(esmf_field), public :: dzdt_target_grid !< vertical velocity + type(esmf_field) :: dzdt_b4adj_target_grid !< vertical vel before vert adj + type(esmf_field), allocatable, public :: tracers_target_grid(:) !< tracers + type(esmf_field), allocatable :: tracers_b4adj_target_grid(:) !< tracers before vert adj + type(esmf_field), public :: ps_target_grid !< surface pressure + type(esmf_field) :: ps_b4adj_target_grid !< sfc pres before terrain adj + type(esmf_field) :: pres_target_grid !< 3-d pressure + type(esmf_field) :: pres_b4adj_target_grid !< 3-d pres before terrain adj + type(esmf_field), public :: temp_target_grid !< temperautre + type(esmf_field) :: temp_b4adj_target_grid !< temp before vert adj + type(esmf_field) :: terrain_interp_to_target_grid !< Input grid terrain interpolated to target grid. + type(esmf_field), public :: u_s_target_grid !< u-wind, 'south' edge + type(esmf_field), public :: v_s_target_grid !< v-wind, 'south' edge + type(esmf_field) :: wind_target_grid !< 3-d wind, grid box center + type(esmf_field) :: wind_b4adj_target_grid !< 3-d wind before vert adj + type(esmf_field) :: wind_s_target_grid !< 3-d wind, 'south' edge + type(esmf_field), public :: u_w_target_grid !< u-wind, 'west' edge + type(esmf_field), public :: v_w_target_grid !< v-wind, 'west' edge + type(esmf_field) :: wind_w_target_grid !< 3-d wind, 'west' edge + type(esmf_field), public :: zh_target_grid !< 3-d height ! Fields associated with thompson microphysics climatological tracers. - type(esmf_field) :: qnifa_climo_b4adj_target_grid - ! number concentration of ice - ! friendly aerosols before vert adj - type(esmf_field), public :: qnifa_climo_target_grid - ! number concentration of ice - ! friendly aerosols on target - ! horiz/vert grid. - type(esmf_field) :: qnwfa_climo_b4adj_target_grid - ! number concentration of water - ! friendly aerosols before vert adj - type(esmf_field), public :: qnwfa_climo_target_grid - ! number concentration of water - ! friendly aerosols on target - ! horiz/vert grid. - type(esmf_field) :: thomp_pres_climo_b4adj_target_grid - ! pressure of each level on - ! target grid + type(esmf_field) :: qnifa_climo_b4adj_target_grid !< number concentration of ice + !! friendly aerosols before vert adj + type(esmf_field), public :: qnifa_climo_target_grid !< number concentration of ice + !! friendly aerosols on target + !! horiz/vert grid. + type(esmf_field) :: qnwfa_climo_b4adj_target_grid !< number concentration of water + !! friendly aerosols before vert adj + type(esmf_field), public :: qnwfa_climo_target_grid !< number concentration of water + !! friendly aerosols on target + !! horiz/vert grid. + type(esmf_field) :: thomp_pres_climo_b4adj_target_grid !< pressure of each level on + !! target grid public :: atmosphere_driver contains -!> @brief -!! Driver routine for atmospheric fields. +!> Driver routine to process for atmospheric fields. !! +!! @param localpet ESMF local persistent execution thread +!! @author George Gayno subroutine atmosphere_driver(localpet) use mpi @@ -450,11 +423,11 @@ subroutine atmosphere_driver(localpet) end subroutine atmosphere_driver -!----------------------------------------------------------------------------------- -! Create target grid field objects to hold data before vertical interpolation. -! These will be defined with the same number of vertical levels as the input grid. -!----------------------------------------------------------------------------------- - +!> Create target grid field objects to hold data before vertical interpolation. +!! These will be defined with the same number of vertical levels as +!! the input grid. +!! +!! @author George Gayno subroutine create_atm_b4adj_esmf_fields implicit none @@ -526,10 +499,9 @@ subroutine create_atm_b4adj_esmf_fields end subroutine create_atm_b4adj_esmf_fields -!----------------------------------------------------------------------------------- -! Create target grid field objects. -!----------------------------------------------------------------------------------- - +!> Create target grid field objects. +!! +!! @author George Gayno subroutine create_atm_esmf_fields implicit none @@ -666,6 +638,9 @@ subroutine create_atm_esmf_fields end subroutine create_atm_esmf_fields +!> Convert 3-d component winds to u and v. +!! +!! @author George Gayno subroutine convert_winds implicit none @@ -779,44 +754,36 @@ subroutine convert_winds end subroutine convert_winds +!> Compute model level pressures. +!! +!! PROGRAM HISTORY LOG: +!! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- +!! - PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 +!! - PRGMMR: Fanglin Yang ORG: W/NMC23 DATE: 2006-11-28 +!! - PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2006-12-12 +!! - PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2007-01-02 +!! +!! INPUT ARGUMENT LIST: +!! IM INTEGER NUMBER OF POINTS TO COMPUTE +!! KM INTEGER NUMBER OF LEVELS +!! IDVC INTEGER VERTICAL COORDINATE ID +!! (1 FOR SIGMA AND 2 FOR HYBRID) +!! IDSL INTEGER TYPE OF SIGMA STRUCTURE +!! (1 FOR PHILLIPS OR 2 FOR MEAN) +!! NVCOORD INTEGER NUMBER OF VERTICAL COORDINATES +!! VCOORD REAL (KM+1,NVCOORD) VERTICAL COORDINATE VALUES +!! FOR IDVC=1, NVCOORD=1: SIGMA INTERFACE +!! FOR IDVC=2, NVCOORD=2: HYBRID INTERFACE A AND B +!! FOR IDVC=3, NVCOORD=3: JUANG GENERAL HYBRID INTERFACE +!! AK REAL (KM+1) HYBRID INTERFACE A +!! BK REAL (KM+1) HYBRID INTERFACE B +!! PS REAL (IX) SURFACE PRESSURE (PA) +!! OUTPUT ARGUMENT LIST: +!! PM REAL (IX,KM) MID-LAYER PRESSURE (PA) +!! DP REAL (IX,KM) LAYER DELTA PRESSURE (PA) +!! +!! @author HANN_MING HENRY JUANG, JUANG, Fanglin Yang, S. Moorthi subroutine newpr1(localpet) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPR1 COMPUTE MODEL PRESSURES -! PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 -! PRGMMR: Fanglin Yang ORG: W/NMC23 DATE: 2006-11-28 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2006-12-12 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2007-01-02 -! -! ABSTRACT: COMPUTE MODEL PRESSURES. -! -! PROGRAM HISTORY LOG: -! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- -! -! USAGE: CALL NEWPR1(IM,IX,KM,KMP,IDVC,IDSL,NVCOORD,VCOORD,PP,TP,QP,P -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! KM INTEGER NUMBER OF LEVELS -! IDVC INTEGER VERTICAL COORDINATE ID -! (1 FOR SIGMA AND 2 FOR HYBRID) -! IDSL INTEGER TYPE OF SIGMA STRUCTURE -! (1 FOR PHILLIPS OR 2 FOR MEAN) -! NVCOORD INTEGER NUMBER OF VERTICAL COORDINATES -! VCOORD REAL (KM+1,NVCOORD) VERTICAL COORDINATE VALUES -! FOR IDVC=1, NVCOORD=1: SIGMA INTERFACE -! FOR IDVC=2, NVCOORD=2: HYBRID INTERFACE A AND B -! FOR IDVC=3, NVCOORD=3: JUANG GENERAL HYBRID INTERFACE -! AK REAL (KM+1) HYBRID INTERFACE A -! BK REAL (KM+1) HYBRID INTERFACE B -! PS REAL (IX) SURFACE PRESSURE (PA) -! OUTPUT ARGUMENT LIST: -! PM REAL (IX,KM) MID-LAYER PRESSURE (PA) -! DP REAL (IX,KM) LAYER DELTA PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ implicit none integer, intent(in) :: localpet @@ -914,24 +881,21 @@ subroutine newpr1(localpet) end subroutine newpr1 +!> Compute new surface pressure. +!! +!! Computes a new surface pressure given a new orography. The new +!! pressure is computed assuming a hydrostatic balance and a constant +!! temperature lapse rate. Below ground, the lapse rate is assumed to +!! be -6.5 k/km. +!! +!! program history log: +!! - 91-10-31 mark iredell +!! - 2018-apr adapt for fv3. george gayno +!! +!! @param [in] localpet ESMF local persistent execution thread +!! @author iredell org: w/nmc23, George Gayno @date 92-10-31 subroutine newps(localpet) -!$$$ subprogram documentation block -! -! subprogram: newps compute new surface pressure -! prgmmr: iredell org: w/nmc23 date: 92-10-31 -! -! abstract: computes a new surface pressure given a new orography. -! the new pressure is computed assuming a hydrostatic balance -! and a constant temperature lapse rate. below ground, the -! lapse rate is assumed to be -6.5 k/km. -! -! program history log: -! 91-10-31 mark iredell -! 2018-apr adapt for fv3. george gayno -! -!c$$$ - implicit none integer, intent(in) :: localpet @@ -1123,12 +1087,9 @@ subroutine newps(localpet) end subroutine newps +!> Read vertical coordinate information. +!! @author George Gayno subroutine read_vcoord_info - -!--------------------------------------------------------------------------------- -! Read vertical coordinate information. -!--------------------------------------------------------------------------------- - implicit none integer :: istat, n, k @@ -1159,10 +1120,10 @@ subroutine read_vcoord_info end subroutine read_vcoord_info -!----------------------------------------------------------------------------------- -! Horizontally interpolate thompson microphysics data to the target model grid. -!----------------------------------------------------------------------------------- - +!> Horizontally interpolate thompson microphysics data to the target +!! model grid. +!! +!! @author George Gayno subroutine horiz_interp_thomp_mp_climo implicit none @@ -1269,10 +1230,9 @@ subroutine horiz_interp_thomp_mp_climo end subroutine horiz_interp_thomp_mp_climo -!----------------------------------------------------------------------------------- -! Vertically interpolate thompson mp climo tracers to the target model levels. -!----------------------------------------------------------------------------------- - +!> Vertically interpolate thompson microphysics climo tracers to the target +!! model levels. +!! @author George Gayno SUBROUTINE VINTG_THOMP_MP_CLIMO implicit none @@ -1383,35 +1343,20 @@ SUBROUTINE VINTG_THOMP_MP_CLIMO END SUBROUTINE VINTG_THOMP_MP_CLIMO +!> Vertically interpolate upper-air fields. +!! +!! Vertically interpolate upper-air fields. Wind, temperature, +!! humidity and other tracers are interpolated. The interpolation is +!! cubic lagrangian in log pressure with a monotonic constraint in the +!! center of the domain. In the outer intervals it is linear in log +!! pressure. Outside the domain, fields are generally held constant, +!! except for temperature and humidity below the input domain, where +!! the temperature lapse rate is held fixed at -6.5 k/km and the +!! relative humidity is held constant. This routine expects fields +!! ordered from bottom to top of atmosphere. +!! +!! @author IREDELL ORG: W/NMC23 @date 92-10-31 SUBROUTINE VINTG -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. THIS ROUTINE EXPECTS -! FIELDS ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL VINTG -! -! SUBPROGRAMS CALLED: -! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -! use mpi IMPLICIT NONE @@ -1608,61 +1553,44 @@ SUBROUTINE VINTG END SUBROUTINE VINTG +!> Cubically interpolate in one dimension. +!! +!! Interpolate field(s) in one dimension along the column(s). The +!! interpolation is cubic lagrangian with a monotonic constraint in +!! the center of the domain. In the outer intervals it is linear. +!! Outside the domain, fields are held constant. +!! +!! PROGRAM HISTORY LOG: +!! - 98-05-01 MARK IREDELL +!! - 1999-01-04 IREDELL USE ESSL SEARCH +!! +!! @param[in] im integer number of columns +!! @param[in] ixz1 integer column skip number for z1 +!! @param[in] ixq1 integer column skip number for q1 +!! @param[in] ixz2 integer column skip number for z2 +!! @param[in] ixq2 integer column skip number for q2 +!! @param[in] nm integer number of fields per column +!! @param[in] nxq1 integer field skip number for q1 +!! @param[in] nxq2 integer field skip number for q2 +!! @param[in] km1 integer number of input points +!! @param[in] kxz1 integer point skip number for z1 +!! @param[in] kxq1 integer point skip number for q1 +!! @param[in] z1 real (1+(im-1)*ixz1+(km1-1)*kxz1) +!! input coordinate values in which to interpolate +!! (z1 must be strictly monotonic in either direction) +!! @param[in] q1 real (1+(im-1)*ixq1+(km1-1)*kxq1+(nm-1)*nxq1) +!! input fields to interpolate +!! @param[in] km2 integer number of output points +!! @param[in] kxz2 integer point skip number for z2 +!! @param[in] kxq2 integer point skip number for q2 +!! @param[in] z2 real (1+(im-1)*ixz2+(km2-1)*kxz2) +!! output coordinate values to which to interpolate +!! (z2 need not be monotonic) +!! @param[out] q2 real (1+(im-1)*ixq2+(km2-1)*kxq2+(nm-1)*nxq2) +!! output interpolated fields +!! @author Mark Iredell @date 98-05-01 SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). -! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT -! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. -! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 98-05-01 MARK IREDELL -! 1999-01-04 IREDELL USE ESSL SEARCH -! -! USAGE: CALL TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, -! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF COLUMNS -! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 -! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 -! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 -! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 -! NM INTEGER NUMBER OF FIELDS PER COLUMN -! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 -! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 -! KM1 INTEGER NUMBER OF INPUT POINTS -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE -! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) -! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) -! INPUT FIELDS TO INTERPOLATE -! KM2 INTEGER NUMBER OF OUTPUT POINTS -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE -! (Z2 NEED NOT BE MONOTONIC) -! -! OUTPUT ARGUMENT LIST: -! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS -! J2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS CHANGE WRT Z2 -! -! SUBPROGRAMS CALLED: -! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ IMPLICIT NONE INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2 INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2 @@ -1799,77 +1727,66 @@ SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & END SUBROUTINE TERP3 +!> Search for a surrounding real interval. +!! +!! This subprogram searches monotonic sequences of real numbers for +!! intervals that surround a given search set of real numbers. The +!! sequences may be monotonic in either direction; the real numbers +!! may be single or double precision; the input sequences and sets and +!! the output locations may be arbitrarily dimensioned. +!! +!! If the array z1 is dimensioned (im,km1), then the skip numbers are +!! ixz1=1 and kxz1=im; if it is dimensioned (km1,im), then the skip +!! numbers are ixz1=km1 and kxz1=1; if it is dimensioned (im,jm,km1), +!! then the skip numbers are ixz1=1 and kxz1=im*jm; etcetera. Similar +!! examples apply to the skip numbers for z2 and l2. +!! +!! Returned values of 0 or km1 indicate that the given search value +!! is outside the range of the sequence. +!! +!! If a search value is identical to one of the sequence values then +!! the location returned points to the identical value. If the +!! sequence is not strictly monotonic and a search value is identical +!! to more than one of the sequence values, then the location returned +!! may point to any of the identical values. +!! +!! to be exact, for each i from 1 to im and for each k from 1 to km2, +!! z=z2(1+(i-1)*ixz2+(k-1)*kxz2) is the search value and +!! l=l2(1+(i-1)*ixl2+(k-1)*kxl2) is the location returned. if l=0, +!! then z is less than the start point z1(1+(i-1)*ixz1) for ascending +!! sequences (or greater than for descending sequences). if l=km1, +!! then z is greater than or equal to the end point +!! z1(1+(i-1)*ixz1+(km1-1)*kxz1) for ascending sequences (or less than +!! or equal to for descending sequences). otherwise z is between the +!! values z1(1+(i-1)*ixz1+(l-1)*kxz1) and z1(1+(i-1)*ixz1+(l-0)*kxz1) +!! and may equal the former. +!! +!! PROGRAM HISTORY LOG: +!! - 1999-01-05 MARK IREDELL +!! +!! @param[in] im integer number of sequences to search +!! @param[in] km1 integer number of points in each sequence +!! @param[in] ixz1 integer sequence skip number for z1 +!! @param[in] kxz1 integer point skip number for z1 +!! @param[in] z1 real (1+(im-1)*ixz1+(km1-1)*kxz1) +!! sequence values to search +!! (z1 must be monotonic in either direction) +!! @param[in] km2 integer number of points to search for +!! in each respective sequence +!! @param[in] ixz2 integer sequence skip number for z2 +!! @param[in] kxz2 integer point skip number for z2 +!! @param[in] z2 real (1+(im-1)*ixz2+(km2-1)*kxz2) +!! set of values to search for +!! (z2 need not be monotonic) +!! @param[in] ixl2 integer sequence skip number for l2 +!! @param[in] kxl2 integer point skip number for l2 +!! +!! @param[out] l2 integer (1+(im-1)*ixl2+(km2-1)*kxl2) +!! interval locations having values from 0 to km1 +!! (z2 will be between z1(l2) and z1(l2+1)) +!! +!! @author Mark Iredell @date 98-05-01 SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,L2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS -! FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. -! THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS -! MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS -! AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. -! -! PROGRAM HISTORY LOG: -! 1999-01-05 MARK IREDELL -! -! USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, -! & L2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF SEQUENCES TO SEARCH -! KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE -! IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! SEQUENCE VALUES TO SEARCH -! (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) -! KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR -! IN EACH RESPECTIVE SEQUENCE -! IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! SET OF VALUES TO SEARCH FOR -! (Z2 NEED NOT BE MONOTONIC) -! IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 -! KXL2 INTEGER POINT SKIP NUMBER FOR L2 -! -! OUTPUT ARGUMENT LIST: -! L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 -! (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) -! -! REMARKS: -! IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE -! IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP -! NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), -! THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. -! SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. -! -! RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE -! IS OUTSIDE THE RANGE OF THE SEQUENCE. -! -! IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES -! THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. -! IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS -! IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE -! LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. -! -! TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, -! Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND -! L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. -! IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) -! FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). -! IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT -! Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES -! (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). -! OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND -! Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -! IMPLICIT NONE INTEGER,INTENT(IN) :: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 @@ -1915,6 +1832,8 @@ SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,L2) END SUBROUTINE RSEARCH +!> Compute vertical level height +!! @author George Gayno subroutine compute_zh implicit none @@ -2002,6 +1921,8 @@ subroutine compute_zh end subroutine compute_zh +!> Cleanup atmospheric field (before adjustment) objects +!! @author George Gayno subroutine cleanup_target_atm_b4adj_data implicit none @@ -2025,6 +1946,8 @@ subroutine cleanup_target_atm_b4adj_data end subroutine cleanup_target_atm_b4adj_data +!> Cleanup target grid atmospheric field objects. +!! @author George Gayno subroutine cleanup_target_atm_data implicit none diff --git a/sorc/chgres_cube.fd/grib2_util.F90 b/sorc/chgres_cube.fd/grib2_util.F90 index ebdb1dfc5..3f7be14f4 100644 --- a/sorc/chgres_cube.fd/grib2_util.F90 +++ b/sorc/chgres_cube.fd/grib2_util.F90 @@ -11,6 +11,12 @@ module grib2_util contains +!> Convert relative humidity to specific humidity +!! @param [inout] rh_sphum rel humidity on input. spec hum on output. +!! @param [in] p pressure in Pa +!! @param [in] t temperature +!! @author Larissa Reames +!! @author Jeff Beck subroutine rh2spfh(rh_sphum,p,t) implicit none @@ -42,6 +48,15 @@ subroutine rh2spfh(rh_sphum,p,t) end subroutine RH2SPFH +!> Convert omega to vertical velocity +!! @param [inout] omega on input, vertical velocity on output +!! @param [in] p pressure +!! @param [in] t temperature +!! @param [in] q specific humidity +!! @param [in] clb lower bounds of indices processed by this mpi task +!! @param [in] cub upper bounds of indices processed by this mpi task +!! @author Larissa Reames +!! @author Jeff Beck subroutine convert_omega(omega,p,t,q,clb,cub) implicit none @@ -70,9 +85,14 @@ subroutine convert_omega(omega,p,t,q,clb,cub) end subroutine convert_omega +!> Convert string from lower to uppercase. +!! @author Clive Page +!! +!! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) +!! +!! @param[in] strIn string to convert +!! @return strOut string in uppercase function to_upper(strIn) result(strOut) -! Adapted from http://www.star.le.ac.uk/~cgp/fortran.html (25 May 2012) -! Original author: Clive Page implicit none From d9ae8bd24209156ef3d51f04538556add67ff89b Mon Sep 17 00:00:00 2001 From: lgannoaa <37596169+lgannoaa@users.noreply.github.com> Date: Fri, 19 Feb 2021 16:43:01 -0500 Subject: [PATCH 40/47] doxygen updates for chgres_cube.fd/search_util.f90 and sfc_climo_gen.fd/interp.F90 (#302) * Create unit-tests for testing to_upper and to_lower. This commit references issue #257 * Add unit test to_upper_lower into CMake build * Clean up build and push for draft pull request * Making following improvement: - Using env parameter to assign source code - Add auther name - Modify comment - Change test failing procedure - rename directory for unit test * turned on testing in workflows * added test as test in cmake * added test as test in cmake * clean up test cmake file * renamed test * cleanup output * cleanup output * moved to new test directory * added tests subdirectory * Convert and add doxygen document to search_util.f90 * Modified doxygen more to have same style with https://github.com/NOAA-EMC/UFS_UTILS/issues/285 * Update doxygen information * Update more doxygen on file * Update more doxygen on file author tag * Doxygen update for interp.F90 * Update doxygen information Co-authored-by: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Co-authored-by: Edward Hartnett --- sorc/chgres_cube.fd/search_util.f90 | 25 ++++++++++-------- sorc/sfc_climo_gen.fd/interp.F90 | 39 ++++++++++------------------- 2 files changed, 28 insertions(+), 36 deletions(-) diff --git a/sorc/chgres_cube.fd/search_util.f90 b/sorc/chgres_cube.fd/search_util.f90 index 6239b8c9c..816a20a47 100644 --- a/sorc/chgres_cube.fd/search_util.f90 +++ b/sorc/chgres_cube.fd/search_util.f90 @@ -1,7 +1,7 @@ !> @file !! @brief Replace undefined surface values. !! -!! @author gayno NCEP/EMC +!! @author George Gayno NCEP/EMC !! !! Replace undefined values with a valid value. This can !! happen for an isolated lake or island that is unresolved by @@ -15,18 +15,18 @@ module search_util contains -!> @brief Replace undefined surface values. -!! +!! Replace undefined surface values. !! Replace undefined values on the model grid with a valid value at !! a nearby neighbor. Undefined values are typically associated !! with isolated islands where there is no source data. -!! !! Routine searches a neighborhood with a radius of 100 grid points. !! If no valid value is found, a default value is used. -!! -!! @note This routine works for one tile of a cubed sphere grid. It +!! This routine works for one tile of a cubed sphere grid. It !! does not consider valid values at adjacent faces. That is a !! future upgrade. +!! @param terrain_land - 2D field of terrain height points. +!! @param soilt_climo - 2D field of soil type points. + subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_land, soilt_climo) use mpi @@ -34,6 +34,7 @@ subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_l implicit none + integer, intent(in) :: idim, jdim, tile, field_num integer(esmf_kind_i8), intent(in) :: mask(idim,jdim) @@ -168,19 +169,19 @@ subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_l repl_default = repl_default + 1 endif elseif (field_num == 7 .and. PRESENT(terrain_land)) then - ! Terrain heights for isolated landice points never get a correct value, so replace - ! with terrain height from the input grid interpolated to the target grid + ! Terrain heights for isolated landice points never get a correct value, so replace + ! with terrain height from the input grid interpolated to the target grid field(i,j) = terrain_land(i,j) repl_default = repl_default + 1 elseif (field_num == 224 .and. PRESENT(soilt_climo)) then - ! When using input soil type fields instead of climatological data on the + ! When using input soil type fields instead of climatological data on the ! target grid, isolated land locations that exist in the target grid but ! not the input grid don't receiving proper soil type information, so replace ! with climatological values field(i,j) = soilt_climo(i,j) repl_default = repl_default + 1 else - field(i,j) = default_value ! Search failed. Use default value. + field(i,j) = default_value !< Search failed. Use default value. repl_default = repl_default + 1 endif @@ -198,6 +199,10 @@ subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_l end subroutine search +!> set sst values based on latitude +!! @author George Gayno NCEP/EMC +!! @param latitude - latitude input +!! @param sst - sst guess value to be set subroutine sst_guess(latitude, sst) use esmf diff --git a/sorc/sfc_climo_gen.fd/interp.F90 b/sorc/sfc_climo_gen.fd/interp.F90 index f1822f03b..4afe5a0be 100644 --- a/sorc/sfc_climo_gen.fd/interp.F90 +++ b/sorc/sfc_climo_gen.fd/interp.F90 @@ -1,8 +1,8 @@ !> @file -!! @author gayno @date 2018 +!! @brief Read the input source data and interpolate it to the +!! model grid. !! -!! Read the input source data and interpolate it to the -!! model grid. +!! @author gayno @date 2018 !! !! @param[in] input_flle filename of input source data. !! @param[in] localpet this mpi task @@ -259,30 +259,17 @@ subroutine interp(localpet, method, input_file) end subroutine interp - subroutine adjust_for_landice(field, vegt, idim, jdim, field_ch) +!> Ensure consistent fields at land ice points +!! Land ice is vegetation type 15 (variable landice). +!! @author George Gayno NCEP/EMC +!! Usage: call adjust_for_landice(field, vegt, idim, jdim, field_ch) +!! output is Model field +!! @param field - Model field before adjustments for land ice. +!! @param field_ch - Field name. +!! @param i/jdim - i/j dimension of model tile. +!! @param vegt - Vegetation type on the model tile. -!----------------------------------------------------------------------- -! subroutine documentation block -! -! Subroutine: adjust for landice -! prgmmr: gayno org: w/np2 date: 2018 -! -! Abstract: Ensure consistent fields at land ice points. -! Land ice is vegetation type 15 (variable landice). -! -! Usage: call adjust_for_landice(field, vegt, idim, jdim, field_ch) -! -! input argument list: -! field Model field before adjustments for -! land ice. -! field_ch Field name -! i/jdim i/j dimension of model tile. -! vegt Vegetation type on the model tile -! -! output argument list: -! field Model field after adjustments for -! land ice. -!----------------------------------------------------------------------- + subroutine adjust_for_landice(field, vegt, idim, jdim, field_ch) use esmf use mpi From 317636c031dd237de0bb6ad06b157a903c2a4a7b Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Sat, 20 Feb 2021 06:02:00 -0700 Subject: [PATCH 41/47] fixing more doxygen for sorc/chgres_cube.fd/static_data.F90 (#315) * updated doxygen * updated doxygen * Minor updates to ./chgres_cube.fd/static_data.F90 Fixes #314 Part of #191 * Minor doxygen updates to ./chgres_cube.fd/thompson_mp_climo_data.F90 Fixes #314 Part of #191 Co-authored-by: George Gayno --- sorc/chgres_cube.fd/static_data.F90 | 75 ++++++++----------- .../chgres_cube.fd/thompson_mp_climo_data.F90 | 10 ++- 2 files changed, 37 insertions(+), 48 deletions(-) diff --git a/sorc/chgres_cube.fd/static_data.F90 b/sorc/chgres_cube.fd/static_data.F90 index 5386e8dc7..5e5859bf5 100644 --- a/sorc/chgres_cube.fd/static_data.F90 +++ b/sorc/chgres_cube.fd/static_data.F90 @@ -1,31 +1,11 @@ !> @file !! @brief Process static surface data !! -!! @author gayno NCEP/EMC -!! !! Read pre-computed static/climatological data on the fv3 !! target grid. Time interpolate if necessary (for example a !! monthly climo field). !! -!! Public variables: -!! -!! - alnsf_target_grid - near ir black sky albedo -!! - alnwf_target_grid - near ir white sky albedo -!! - alvsf_target_grid - visible black sky albedo -!! - alvwf_target_grid - visible white sky albedo -!! - facsf_target_grid - fractional coverage for strong -!! zenith angle dependent albedo -!! - facwf_target_grid - fractional coverage for weak -!! zenith angle dependent albedo -!! - max_veg_greenness_target_grid - maximum annual greenness fraction -!! - min_veg_greenness_target_grid - minimum annual greenness fraction -!! - mxsno_albedo_target_grid - maximum snow albedo -!! - slope_type_target_grid - slope type -!! - soil_type_target_grid - soil type -!! - substrate_temp_target_grid - soil subtrate temperature -!! - veg_greenness_target_grid - vegetation greenness fraction -!! - veg_type_target_grid - vegetation type -!! +!! @author George Gayno NCEP/EMC module static_data use esmf @@ -34,31 +14,31 @@ module static_data private - type(esmf_field), public :: alvsf_target_grid - type(esmf_field), public :: alvwf_target_grid - type(esmf_field), public :: alnsf_target_grid - type(esmf_field), public :: alnwf_target_grid - type(esmf_field), public :: facsf_target_grid - type(esmf_field), public :: facwf_target_grid - type(esmf_field), public :: max_veg_greenness_target_grid - type(esmf_field), public :: min_veg_greenness_target_grid - type(esmf_field), public :: mxsno_albedo_target_grid - type(esmf_field), public :: slope_type_target_grid - type(esmf_field), public :: soil_type_target_grid - type(esmf_field), public :: substrate_temp_target_grid - type(esmf_field), public :: veg_greenness_target_grid - type(esmf_field), public :: veg_type_target_grid + type(esmf_field), public :: alvsf_target_grid !< visible black sky albedo + type(esmf_field), public :: alvwf_target_grid !< visible white sky albedo + type(esmf_field), public :: alnsf_target_grid !< near ir black sky albedo + type(esmf_field), public :: alnwf_target_grid !< near ir white sky albedo + type(esmf_field), public :: facsf_target_grid !< fractional coverage for strong zenith angle dependent albedo + type(esmf_field), public :: facwf_target_grid !< fractional coverage for weak zenith angle dependent albedo + type(esmf_field), public :: max_veg_greenness_target_grid !< maximum annual greenness fraction + type(esmf_field), public :: min_veg_greenness_target_grid !< minimum annual greenness fraction + type(esmf_field), public :: mxsno_albedo_target_grid !< maximum snow albedo + type(esmf_field), public :: slope_type_target_grid !< slope type + type(esmf_field), public :: soil_type_target_grid !< soil type + type(esmf_field), public :: substrate_temp_target_grid !< soil subtrate temperature + type(esmf_field), public :: veg_greenness_target_grid !< vegetation greenness fraction + type(esmf_field), public :: veg_type_target_grid !< vegetation type public :: get_static_fields public :: cleanup_static_fields contains -!> @brief Driver routine to read/time interpolate static/climo fields +!> Driver routine to read/time interpolate static/climo fields !! on the fv3 target grid. !! -!! @author gayno NCEP/EMC -!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author George Gayno NCEP/EMC subroutine get_static_fields(localpet) use model_grid, only : target_grid, & @@ -356,10 +336,18 @@ subroutine get_static_fields(localpet) end subroutine get_static_fields -!> @brief Read static climatological data file -!! -!! @author gayno NCEP/EMC +!> Read static climatological data file. !! +!! @param[in] field the name of the surface field to be processed +!! @param[in] i_target the "i" dimension of the target model tile +!! @param[in] j_target the "j" dimension of the target model tile +!! @param[in] tile the tile number of be processed +!! @param[out] data_one_tile the processed surface data on the tile +!! @param[out] max_data_one_tile for fields with multiple time periods, the max +!! yearly value on the tile +!! @param[out] min_data_one_tile for fields with multiple time periods, the min +!! yearly value on the tile +!! @author George Gayno NCEP/EMC subroutine read_static_file(field, i_target, j_target, tile, & data_one_tile, max_data_one_tile, & min_data_one_tile) @@ -494,10 +482,9 @@ subroutine read_static_file(field, i_target, j_target, tile, & end subroutine read_static_file -!> @brief Free up memory for fields in this module. -!! -!! @author gayno NCEP/EMC +!> Free up memory for fields in this module. !! +!! @author George Gayno NCEP/EMC subroutine cleanup_static_fields implicit none diff --git a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 index accd83382..23040a41f 100644 --- a/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 +++ b/sorc/chgres_cube.fd/thompson_mp_climo_data.F90 @@ -1,9 +1,10 @@ !> @file -!! @brief Process Thompson climatological MP data +!! @brief Process Thompson climatological MP data. !! !! Module to read the Thompson climatological MP data file !! and set up the associated esmf field and grid objects. !! +!! @author George Gayno NOAA/EMC module thompson_mp_climo_data use esmf @@ -40,9 +41,10 @@ module thompson_mp_climo_data contains -!> @brief Read Thompson climatological MP data file and time interpolate data to +!> Read Thompson climatological MP data file and time interpolate data !! to current cycle time. !! +!! @author George Gayno NOAA/EMC subroutine read_thomp_mp_climo_data implicit none @@ -318,9 +320,9 @@ subroutine read_thomp_mp_climo_data end subroutine read_thomp_mp_climo_data -!> @brief -!! Free up memory associated with this module. +!> Free up memory associated with this module. !! +!! @author George Gayno NOAA/EMC subroutine cleanup_thomp_mp_climo_input_data implicit none From 23e4e3a80fb761f42c2e63eeaa531ff015b0fd58 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Mon, 22 Feb 2021 06:23:44 -0700 Subject: [PATCH 42/47] doxygen fixes for sorc/chgres_cube.fd/chgres.F90 (#319) * doxygen fixes * Minor doxygen updates to chgres.F90. Fixes #318 Co-authored-by: George Gayno --- sorc/chgres_cube.fd/chgres.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/sorc/chgres_cube.fd/chgres.F90 b/sorc/chgres_cube.fd/chgres.F90 index 3aace4ba8..c3472867d 100644 --- a/sorc/chgres_cube.fd/chgres.F90 +++ b/sorc/chgres_cube.fd/chgres.F90 @@ -1,12 +1,19 @@ !> @file !! @brief Initialize an FV3 model run. !! -!! Program CHGRES_CUBE +!! Initialize an FV3 run using history or restart data from another +!! FV3 run, the spectral GFS, and a few other models. Converts +!! atmospheric, surface and nst data. !! -!! Initialize an FV3 run using history or restart data from -!! another FV3 run, the spectral GFS, and a few other models. -!! Converts atmospheric, surface and nst data. +!! This file reads a configuration namelist. !! +!! Usage: +!! Link the configuration namelist to ./fort.41. Then run the +!! program with a multiple of six mpi tasks (an ESMF library +!! requirement for fv3 cubed sphere grids). +!! +!! +!! @author George Gayno NOAA/EMC program chgres use mpi From 6e8ae7c1f84e419179d975a99170aba006ef95a9 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Mon, 22 Feb 2021 16:45:03 -0700 Subject: [PATCH 43/47] updating README (#333) * updating README * update reame.md Fixes #333 Co-authored-by: George Gayno --- README.md | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/README.md b/README.md index f397054d5..79e8e385e 100644 --- a/README.md +++ b/README.md @@ -51,6 +51,49 @@ make -j2 make install ``` +## Contents + +The UFS_UTILS package contains the following utilities (under the sorc +directory): +- chgres_cube +- emcsfc_ice_blend +- emcsfc_snow2mdl +- fre-nctools +- fvcom_tools +- global_chgres +- global_cycle +- grid_tools +- nst_tf_chg +- orog_mask_tools +- sfc_climo_gen +- vcoord_gen + +The reg_tests directory contains the regression test code. + +The fix directory is where we set links to directories containing +large, static data files used by UFS_UTILS programs. + +The tests directory contains unit tests. + +The ush directory contains scripts to run UFS_UTILS programs. Most are called from +driver scripts. + +The util directory contains utility scripts to create coldstart initial conditions +for GFS parallels, and to run the vertical coordinate generator. + +The parm directory contains variable mapping parameter tables used by the chgres_cube program. + +The driver_scripts directory contains high-level driver scripts to create a model +grid on officially supported HPC platforms. + +The modulefiles directory contains modules loaded when building UFS_UTILS on supported +HPC platforms. They are also loaded at runtime by utility and regression test scripts. + +The docs directory contains the control file for the doxygen +documentation build, as well as some markdown files which are part of +the documentation. It also contains (in the source subdirectory) the +ReadTheDocs documentation files. + ## Disclaimer The United States Department of Commerce (DOC) GitHub project code is From 7cb4339da7bb2e7e1dded367aba7e5c21b70dff7 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Mon, 22 Feb 2021 19:33:15 -0700 Subject: [PATCH 44/47] More chgres_cube doxygen (#329) * more doxygen changes * more doxygen * fixed comment * Minor doxygen updates to ./chgres_cube.fd/input_data.F90 Part of #191 Fixes #327 * More doxygen updates Part of #191 Fixes #327 * More doxygen updates to chgres_cube. Part of #191. Fixes #327. * More doxygen updates to ./chgres_cube.fd/surface.F90 Part of #191 Fixes #327 * Doxygen updates to ./chgres_cube.fd/surface.F90 Part of #191 Fixes #327 * More doxygen update to chgres_cube. Part of #191 Fixes #327 * Doxygen updates to ./chgres_cube.fd/search_util.f90 Part of #191 Fixes of #327 Co-authored-by: George Gayno --- sorc/chgres_cube.fd/chgres.F90 | 13 +- sorc/chgres_cube.fd/input_data.F90 | 37 ++-- sorc/chgres_cube.fd/program_setup.f90 | 306 +++++++++----------------- sorc/chgres_cube.fd/search_util.f90 | 29 ++- sorc/chgres_cube.fd/surface.F90 | 268 +++++++++++----------- 5 files changed, 296 insertions(+), 357 deletions(-) diff --git a/sorc/chgres_cube.fd/chgres.F90 b/sorc/chgres_cube.fd/chgres.F90 index c3472867d..5024cde6e 100644 --- a/sorc/chgres_cube.fd/chgres.F90 +++ b/sorc/chgres_cube.fd/chgres.F90 @@ -1,19 +1,22 @@ !> @file !! @brief Initialize an FV3 model run. !! +!! @author George Gayno NOAA/EMC + +!> Initialize an FV3 model run. +!! !! Initialize an FV3 run using history or restart data from another !! FV3 run, the spectral GFS, and a few other models. Converts !! atmospheric, surface and nst data. !! !! This file reads a configuration namelist. !! -!! Usage: -!! Link the configuration namelist to ./fort.41. Then run the -!! program with a multiple of six mpi tasks (an ESMF library -!! requirement for fv3 cubed sphere grids). -!! +!! Link the configuration namelist to ./fort.41. Then run the program +!! with a multiple of six mpi tasks (an ESMF library requirement for +!! fv3 cubed sphere grids). !! !! @author George Gayno NOAA/EMC +!! @return 0 for success, error code otherwise. program chgres use mpi diff --git a/sorc/chgres_cube.fd/input_data.F90 b/sorc/chgres_cube.fd/input_data.F90 index 66c05c0f5..8d8e8c4b2 100644 --- a/sorc/chgres_cube.fd/input_data.F90 +++ b/sorc/chgres_cube.fd/input_data.F90 @@ -104,24 +104,25 @@ module input_data ! Fields associated with the nst model. - type(esmf_field), public :: c_d_input_grid - type(esmf_field), public :: c_0_input_grid - type(esmf_field), public :: d_conv_input_grid - type(esmf_field), public :: dt_cool_input_grid - type(esmf_field), public :: ifd_input_grid - type(esmf_field), public :: qrain_input_grid - type(esmf_field), public :: tref_input_grid !< reference temperature - type(esmf_field), public :: w_d_input_grid - type(esmf_field), public :: w_0_input_grid - type(esmf_field), public :: xs_input_grid - type(esmf_field), public :: xt_input_grid - type(esmf_field), public :: xu_input_grid - type(esmf_field), public :: xv_input_grid - type(esmf_field), public :: xz_input_grid - type(esmf_field), public :: xtts_input_grid - type(esmf_field), public :: xzts_input_grid - type(esmf_field), public :: z_c_input_grid - type(esmf_field), public :: zm_input_grid + type(esmf_field), public :: c_d_input_grid !< Coefficient 2 to calculate d(tz)/d(ts) + type(esmf_field), public :: c_0_input_grid !< Coefficient 1 to calculate d(tz)/d(ts) + type(esmf_field), public :: d_conv_input_grid !< Thickness of free convection layer + type(esmf_field), public :: dt_cool_input_grid !< Sub-layer cooling amount + type(esmf_field), public :: ifd_input_grid !< Model mode index. 0-diurnal model not + !< started; 1-diurnal model started. + type(esmf_field), public :: qrain_input_grid !< Sensible heat flux due to rainfall + type(esmf_field), public :: tref_input_grid !< Reference temperature + type(esmf_field), public :: w_d_input_grid !< Coefficient 4 to calculate d(tz)/d(ts) + type(esmf_field), public :: w_0_input_grid !< Coefficient 3 to calculate d(tz)/d(ts) + type(esmf_field), public :: xs_input_grid !< Salinity content in diurnal thermocline layer + type(esmf_field), public :: xt_input_grid !< Heat content in diurnal thermocline layer + type(esmf_field), public :: xu_input_grid !< u-current content in diurnal thermocline layer + type(esmf_field), public :: xv_input_grid !< v-current content in diurnal thermocline layer + type(esmf_field), public :: xz_input_grid !< Diurnal thermocline layer thickness + type(esmf_field), public :: xtts_input_grid !< d(xt)/d(ts) + type(esmf_field), public :: xzts_input_grid !< d(xz)/d(ts) + type(esmf_field), public :: z_c_input_grid !< Sub-layer cooling thickness + type(esmf_field), public :: zm_input_grid !< Oceanic mixed layer depth public :: read_input_atm_data public :: cleanup_input_atm_data diff --git a/sorc/chgres_cube.fd/program_setup.f90 b/sorc/chgres_cube.fd/program_setup.f90 index 919661f7c..ef260e516 100644 --- a/sorc/chgres_cube.fd/program_setup.f90 +++ b/sorc/chgres_cube.fd/program_setup.f90 @@ -1,41 +1,41 @@ !> @file !! @brief Set up program execution !! -!! @author George Gayno NCEP/EMC -!! !! Set up program execution !! -!! Public variables: -!! -!! - atm_core_files_input_grid - File names of input atmospheric restart -!! core files. Only used for 'restart' -!! input type. -!! - atm_tracer_files_input_grid - File names of input atmospheric restart -!! tracer files. Only used for 'restart' -!! input type. -!! - atm_weight_file - File containing pre-computed weights -!! to horizontally interpolate -!! atmospheric fields. -!! - bb_target - Soil 'b' parameter, target grid -!! - convert_atm - Convert atmospheric data when true. -!! - convert_nst - Convert nst data when true. -!! - convert_sfc - Convert sfc data when true. -!! - cres_target_grid - Target grid resolution, i.e., C768. -!! - cycle_mon/day/hour - Cycle month/day/hour -!! - data_dir_input_grid - Directory containing input atm or sfc -!! files. -!! - drysmc_input/target - Air dry soil moisture content input/ -!! target grids. -!! - fix_dir_target_grid - Directory containing target grid -!! pre-computed fixed data (ex: soil type) -!! - halo_blend - Number of row/cols of blending halo, -!! where model tendencies and lateral -!! boundary tendencies are applied. -!! Regional target grids only. -!! - halo_bndy - Number of row/cols of lateral halo, -!! where pure lateral bndy conditions are -!! applied (regional target grids). -!! - input_type - Input data type: +!! @author George Gayno NCEP/EMC + module program_setup + + implicit none + + private + + character(len=500), public :: varmap_file = "NULL" !< REQUIRED. Full path of the relevant varmap file. + character(len=500), public :: atm_files_input_grid(6) = "NULL" !< File names of input + !< atmospheric data. Not used + !< for "grib2" or "restart" + !< input types. + character(len=500), public :: atm_core_files_input_grid(7) = "NULL" !< File names of input atmospheric restart core files. Only used for 'restart' input type. + character(len=500), public :: atm_tracer_files_input_grid(6) = "NULL" !< File names of input atmospheric restart tracer files. Only used for 'restart' input type. + character(len=500), public :: data_dir_input_grid = "NULL" !< Directory containing input atm or sfc files. + character(len=500), public :: fix_dir_target_grid = "NULL" !< Directory containing target grid pre-computed fixed data (ex: soil type). + character(len=500), public :: mosaic_file_input_grid = "NULL" !< Input grid mosaic file. Only used for "restart" or "history" input type. + character(len=500), public :: mosaic_file_target_grid = "NULL" !< Target grid mosaic file. + character(len=500), public :: nst_files_input_grid = "NULL" !< File name of input nst data. Only used for input_type "gfs_gaussian_nemsio". + character(len=500), public :: grib2_file_input_grid = "NULL" !< REQUIRED. File name of grib2 input data. Assumes atmospheric and surface data are in a single file. + character(len=500), public :: geogrid_file_input_grid = "NULL" !< Name of "geogrid" file, which contains static + !! surface fields on the input grid. GRIB2 option + !! only. + character(len=500), public :: orog_dir_input_grid = "NULL" !< Directory containing the input grid orography files. Only used for "restart" or "history" input types. + character(len=500), public :: orog_files_input_grid(6) = "NULL" !< Input grid orography files. Only used for "restart" or "history" input types. + character(len=500), public :: orog_dir_target_grid = "NULL" !< Directory containing the target grid orography files. + character(len=500), public :: orog_files_target_grid(6) = "NULL" !< Target grid orography files. + character(len=500), public :: sfc_files_input_grid(6) = "NULL" !< File names containing input surface data. Not used for 'grib2' input type. + character(len=500), public :: vcoord_file_target_grid = "NULL" !< Vertical coordinate definition file. + character(len=500), public :: thomp_mp_climo_file= "NULL" !< Path/name to the Thompson MP climatology file. + character(len=6), public :: cres_target_grid = "NULL" !< Target grid resolution, i.e., C768. + character(len=500), public :: atm_weight_file="NULL" !< File containing pre-computed weights to horizontally interpolate atmospheric fields. + character(len=25), public :: input_type="restart" !< Input data type: !! - "restart" for fv3 tiled warm restart !! files (netcdf). !! - "history" for fv3 tiled history files @@ -49,182 +49,90 @@ !! gaussian nemsio files !! - "gfs_sigio" for spectral gfs !! gfs sigio/sfcio files. -!! - max_tracers - Maximum number of atmospheric tracers -!! processed -!! - maxsmc_input/target - Maximum soil moisture content input/ -!! target grids -!! - mosaic_file_input_grid - Input grid mosaic file. Only used for -!! "restart" or "history" input type. -!! - mosaic_file_target_grid - Target grid mosaic file -!! - nst_files_input_grid - File name of input nst data. Only -!! used for input_type "gfs_gaussian_nemsio". -!! - num_tracers - Number of atmospheric tracers to -!! be processed. -!! - orog_dir_input_grid - Directory containing the input grid -!! orography files. Only used for "restart" -!! or "history" input types. -!! - orog_files_input_grid - Input grid orography files. Only used for -!! "restart" or "history" input types. -!! - orog_dir_target_grid - Directory containing the target grid -!! orography files. -!! - orog_files_target_grid - Target grid orography files. -!! - refsmc_input/target - Reference soil moisture content input/ -!! target grids (onset of soil moisture -!! stress). -!! - regional - For regional target grids. When '1' -!! remove boundary halo region from -!! atmospheric/surface data and -!! output atmospheric boundary file. -!! When '2' output boundary file only. -!! Default is '0' (global grids). -!! - satpsi_target - Saturated soil potential, target grid -!! - sfc_files_input_grid - File names containing input surface data. -!! Not used for 'grib2' input type. -!! - thomp_mp_climo_file - Path/name to the Thompson MP climatology -!! file. -!! - tracers - Name of each atmos tracer to be processed. -!! These names will be used to identify -!! the tracer records in the output files. -!! Follows the convention in the field table. -!! FOR GRIB2 FILES: Not used. Tracers instead taken -!! from the varmap file. -!! - tracers_input - Name of each atmos tracer record in -!! the input file. May be different from -!! value in 'tracers'. -!! FOR GRIB2 FILES: Not used. Tracers instead taken -!! from the varmap file. -!! - use_thomp_mp_climo - When true, read and process Thompson -!! MP climatological tracers. False, -!! when 'thomp_mp_climo_file' is NULL. -!! - vcoord_file_target_grid - Vertical coordinate definition file -!! - wltsmc_input/target - Plant wilting point soil moisture content -!! input/target grids -!! - nsoill_out - Number of soil levels desired in the output data. -!! chgres_cube can interpolate from 9 input to 4 output -!! levels. DEFAULT: 4 -!! -!! Variables that are relevant only for "grib2" input type: -!! -!! - grib2_file_input_grid - REQUIRED. File name of grib2 input data. -!! Assumes atmospheric and surface data are in a single -!! file. -!! -!! - varmap_file - REQUIRED. Full path of the relevant varmap file. -!! -!! - external_model - The model that the input data is derived from. Current -!! supported options are: "GFS", "HRRR", "NAM", "RAP". -!! Default: "GFS" -!! -!! - vgtyp_from_climo - If false, interpolate vegetation type from the input -!! data to the target grid instead of using data from -!! static data. Use with caution as vegetation categories -!! can vary. Default: True -!! -!! - sotyp_from_climo - If false, interpolate soil type from the input -!! data to the target grid instead of using data from -!! static data. Use with caution as the code assumes -!! input soil type use STATSGO soil categories. -!! Default: True -!! -!! - vgfrc_from_climo - If false, interpolate vegetation fraction from the input -!! data to the target grid instead of using data from -!! static data. Use with caution as vegetation categories -!! can vary. -!! Default: True -!! -!! - minmax_vgfrc_from_climo - If false, interpolate min/max vegetation fraction from -!! the input data to the target grid instead of using data -!! from static data. Use with caution as vegetation -!! categories can vary. -!! Default: True -!! -!! - lai_from_climo - If false, interpolate leaf area index from the input -!! data to the target grid instead of using data from -!! static data. -!! Default: True -!! -!! - tg3_from_soil - If false, use lowest level soil temperature for the -!! base soil temperature instead of using data from -!! static data. -!! Default: False -!! - module program_setup - - implicit none - - private - - character(len=500), public :: varmap_file = "NULL" - character(len=500), public :: atm_files_input_grid(6) = "NULL" !< File names of input - !< atmospheric data. Not used - !< for "grib2" or "restart" - !< input types. - character(len=500), public :: atm_core_files_input_grid(7) = "NULL" - character(len=500), public :: atm_tracer_files_input_grid(6) = "NULL" - character(len=500), public :: data_dir_input_grid = "NULL" - character(len=500), public :: fix_dir_target_grid = "NULL" - character(len=500), public :: mosaic_file_input_grid = "NULL" - character(len=500), public :: mosaic_file_target_grid = "NULL" - character(len=500), public :: nst_files_input_grid = "NULL" - character(len=500), public :: grib2_file_input_grid = "NULL" - character(len=500), public :: geogrid_file_input_grid = "NULL" - character(len=500), public :: orog_dir_input_grid = "NULL" - character(len=500), public :: orog_files_input_grid(6) = "NULL" - character(len=500), public :: orog_dir_target_grid = "NULL" - character(len=500), public :: orog_files_target_grid(6) = "NULL" - character(len=500), public :: sfc_files_input_grid(6) = "NULL" - character(len=500), public :: vcoord_file_target_grid = "NULL" - character(len=500), public :: thomp_mp_climo_file= "NULL" - character(len=6), public :: cres_target_grid = "NULL" - character(len=500), public :: atm_weight_file="NULL" - character(len=25), public :: input_type="restart" - character(len=20), public :: external_model="GFS" !Default assume gfs data - - + character(len=20), public :: external_model="GFS" !< The model that the input data is derived from. Current supported options are: "GFS", "HRRR", "NAM", "RAP". Default: "GFS" - character(len=500), public :: fix_dir_input_grid = "NULL" + character(len=500), public :: fix_dir_input_grid = "NULL" !< Directory containing files of latitude and + !! and longitude for certain GRIB2 input data. - integer, parameter, public :: max_tracers=100 - integer, public :: num_tracers, num_tracers_input + integer, parameter, public :: max_tracers=100 !< Maximum number of atmospheric tracers processed. + integer, public :: num_tracers !< Number of atmospheric tracers to be processed. + integer, public :: num_tracers_input !< Number of atmospheric tracers in input file. - logical, allocatable, public :: read_from_input(:) + logical, allocatable, public :: read_from_input(:) !< When false, variable was not read from GRIB2 + !! input file. - character(len=20), public :: tracers(max_tracers)="NULL" - character(len=20), public :: tracers_input(max_tracers)="NULL" - character(len=20), allocatable, public :: missing_var_methods(:) - character(len=20), allocatable, public :: chgres_var_names(:) - character(len=20), allocatable, public :: field_var_names(:) + character(len=20), public :: tracers(max_tracers)="NULL" !< Name of each atmos tracer to be processed. + !! These names will be used to identify + !! the tracer records in the output files. + !! Follows the convention in the field table. + !! FOR GRIB2 FILES: Not used. Tracers instead taken + !! from the varmap file. + character(len=20), public :: tracers_input(max_tracers)="NULL" !< Name of each atmos tracer record in + !! the input file. May be different from + !! value in 'tracers'. + !! FOR GRIB2 FILES: Not used. Tracers instead taken + !! from the varmap file. + character(len=20), allocatable, public :: missing_var_methods(:) !< Method to replace missing GRIB2 input + !! records. + character(len=20), allocatable, public :: chgres_var_names(:) !< Varmap table variable name as recognized + !! by this program. + character(len=20), allocatable, public :: field_var_names(:) !< The GRIB2 variable name in the varmap table. - integer, public :: cycle_mon = -999 - integer, public :: cycle_day = -999 - integer, public :: cycle_hour = -999 - integer, public :: regional = 0 - integer, public :: halo_bndy = 0 - integer, public :: halo_blend = 0 - integer, public :: nsoill_out = 4 - - logical, public :: convert_atm = .false. - logical, public :: convert_nst = .false. - logical, public :: convert_sfc = .false. + integer, public :: cycle_mon = -999 !< Cycle month. + integer, public :: cycle_day = -999 !< Cycle day. + integer, public :: cycle_hour = -999 !< Cycle hour. + integer, public :: regional = 0 !< For regional target grids. When '1' remove boundary halo region from atmospheric/surface data and + !! output atmospheric boundary file. When '2' output boundary file only. Default is '0' (global grids). + integer, public :: halo_bndy = 0 !< Number of row/cols of lateral halo, where pure lateral bndy conditions are applied (regional target grids). + integer, public :: halo_blend = 0 !< Number of row/cols of blending halo, where model tendencies and lateral boundary tendencies are applied. Regional target grids only. + integer, public :: nsoill_out = 4 !< Number of soil levels desired in the output data. chgres_cube can interpolate from 9 input to 4 output levels. DEFAULT: 4. + + logical, public :: convert_atm = .false. !< Convert atmospheric data when true. + logical, public :: convert_nst = .false. !< Convert nst data when true. + logical, public :: convert_sfc = .false. !< Convert sfc data when true. ! Options for replacing vegetation/soil type, veg fraction, and lai with data from the grib2 file ! Default is to use climatology instead - logical, public :: vgtyp_from_climo = .true. - logical, public :: sotyp_from_climo = .true. - logical, public :: vgfrc_from_climo = .true. - logical, public :: minmax_vgfrc_from_climo = .true. - logical, public :: lai_from_climo = .true. - logical, public :: tg3_from_soil = .false. - logical, public :: use_thomp_mp_climo=.false. - - real, allocatable, public :: drysmc_input(:), drysmc_target(:) - real, allocatable, public :: maxsmc_input(:), maxsmc_target(:) - real, allocatable, public :: refsmc_input(:), refsmc_target(:) - real, allocatable, public :: wltsmc_input(:), wltsmc_target(:) - real, allocatable, public :: bb_target(:), satpsi_target(:) - real, allocatable, public :: missing_var_values(:) + logical, public :: vgtyp_from_climo = .true. !< If false, interpolate vegetation type from the input + !! data to the target grid instead of using data from + !! static data. Use with caution as vegetation categories + !! can vary. Default: True. + logical, public :: sotyp_from_climo = .true. !< If false, interpolate soil type from the input + !! data to the target grid instead of using data from + !! static data. Use with caution as the code assumes + !! input soil type use STATSGO soil categories. + !! Default: True. + logical, public :: vgfrc_from_climo = .true. !< If false, interpolate vegetation fraction from the input + !! data to the target grid instead of using data from + !! static data. Use with caution as vegetation categories + !! can vary. Default: True. + + logical, public :: minmax_vgfrc_from_climo = .true. !< If false, interpolate min/max vegetation fraction from + !! the input data to the target grid instead of using data + !! from static data. Use with caution as vegetation + !! categories can vary. Default: True. + logical, public :: lai_from_climo = .true. !< If false, interpolate leaf area index from the input + !! data to the target grid instead of using data from + !! static data. Default: True. + logical, public :: tg3_from_soil = .false. !< If false, use lowest level soil temperature for the + !! base soil temperature instead of using data from + !! static data. Default: False. + logical, public :: use_thomp_mp_climo=.false. !< When true, read and process Thompson MP climatological tracers. False, when 'thomp_mp_climo_file' is NULL. + + real, allocatable, public :: drysmc_input(:) !< Air dry soil moisture content input grid. + real, allocatable, public :: drysmc_target(:) !< Air dry soil moisture content target grid. + real, allocatable, public :: maxsmc_input(:) !< Maximum soil moisture content input grid. + real, allocatable, public :: maxsmc_target(:) !< Maximum soil moisture content target grid. + real, allocatable, public :: refsmc_input(:) !< Reference soil moisture content input grid (onset of soil moisture stress). + real, allocatable, public :: refsmc_target(:) !< Reference soil moisture content target grid (onset of soil moisture stress). + real, allocatable, public :: wltsmc_input(:) !< Plant wilting point soil moisture content input grid. + real, allocatable, public :: wltsmc_target(:) !< Plant wilting point soil moisture content target grid. + real, allocatable, public :: bb_target(:) !< Soil 'b' parameter, target grid + real, allocatable, public :: satpsi_target(:) !< Saturated soil potential, target grid + real, allocatable, public :: missing_var_values(:) !< If input GRIB2 record is missing, the variable + !! is set to this value. public :: read_setup_namelist diff --git a/sorc/chgres_cube.fd/search_util.f90 b/sorc/chgres_cube.fd/search_util.f90 index 816a20a47..15d6750ce 100644 --- a/sorc/chgres_cube.fd/search_util.f90 +++ b/sorc/chgres_cube.fd/search_util.f90 @@ -1,12 +1,11 @@ !> @file !! @brief Replace undefined surface values. !! -!! @author George Gayno NCEP/EMC -!! !! Replace undefined values with a valid value. This can !! happen for an isolated lake or island that is unresolved by !! the input grid. !! +!! @author George Gayno NCEP/EMC module search_util private @@ -15,18 +14,29 @@ module search_util contains -!! Replace undefined surface values. +!> Replace undefined surface values. +!! !! Replace undefined values on the model grid with a valid value at !! a nearby neighbor. Undefined values are typically associated !! with isolated islands where there is no source data. +!! !! Routine searches a neighborhood with a radius of 100 grid points. !! If no valid value is found, a default value is used. +!! !! This routine works for one tile of a cubed sphere grid. It !! does not consider valid values at adjacent faces. That is a !! future upgrade. -!! @param terrain_land - 2D field of terrain height points. -!! @param soilt_climo - 2D field of soil type points. - +!! +!! @param [inout] field On input/output, surface data with undefined/no undefined values. +!! @param [in] mask land-mask of surface data. +!! @param [in] idim 'i' dimension of tile +!! @param [in] jdim 'j' dimension of tile +!! @param [in] tile tile number +!! @param [in] field_num surface field number +!! @param [in] latitude latitude of the surface data +!! @param [in] terrain_land terrain height +!! @param [in] soilt_climo climatological soil type +!! @author George Gayno NCEP/EMC subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_land, soilt_climo) use mpi @@ -199,10 +209,11 @@ subroutine search (field, mask, idim, jdim, tile, field_num, latitude, terrain_l end subroutine search -!> set sst values based on latitude +!> Set sst values based on latitude. +!! +!! @param latitude latitude input +!! @param sst sst guess value to be set !! @author George Gayno NCEP/EMC -!! @param latitude - latitude input -!! @param sst - sst guess value to be set subroutine sst_guess(latitude, sst) use esmf diff --git a/sorc/chgres_cube.fd/surface.F90 b/sorc/chgres_cube.fd/surface.F90 index a4d055b71..19ff3feb2 100644 --- a/sorc/chgres_cube.fd/surface.F90 +++ b/sorc/chgres_cube.fd/surface.F90 @@ -1,17 +1,17 @@ !> @file !! @brief Process surface and nst fields. !! -!! @author gayno NCEP/EMC -!! -!! Process surface and nst fields. Interpolates fields from -!! the input to target grids. Adjusts soil temperature according -!! to differences in input and target grid terrain. Rescales -!! soil moisture for soil type differences between input and target -!! grid. Computes frozen portion of total soil moisture. +!! Process surface and nst fields. Interpolates fields from the input +!! to target grids. Adjusts soil temperature according to differences +!! in input and target grid terrain. Rescales soil moisture for soil +!! type differences between input and target grid. Computes frozen +!! portion of total soil moisture. !! -!! Public variables are defined below. "target" indicates field +!! Public variables are defined below. "target" indicates field !! associated with the target grid. "input" indicates field associated !! with the input grid. +!! +!! @author gayno NCEP/EMC module surface use esmf @@ -25,87 +25,109 @@ module surface ! surface fields (not including nst) type(esmf_field), public :: canopy_mc_target_grid - ! canopy moisture content + !< canopy moisture content type(esmf_field), public :: f10m_target_grid - ! log((z0+10)*1/z0) - ! See sfc_diff.f for details + !< log((z0+10)*1/z0) + !< See sfc_diff.f for details type(esmf_field), public :: ffmm_target_grid - ! log((z0+z1)*1/z0) - ! See sfc_diff.f for details + !< log((z0+z1)*1/z0) + !< See sfc_diff.f for details type(esmf_field), public :: q2m_target_grid - ! 2-m specific humidity + !< 2-m specific humidity type(esmf_field), public :: seaice_depth_target_grid - ! sea ice depth + !< sea ice depth type(esmf_field), public :: seaice_fract_target_grid - ! sea ice fraction + !< sea ice fraction type(esmf_field), public :: seaice_skin_temp_target_grid - ! sea ice skin temperature + !< sea ice skin temperature type(esmf_field), public :: skin_temp_target_grid - ! skin temperature/sst + !< skin temperature/sst type(esmf_field), public :: srflag_target_grid - ! snow/rain flag + !< snow/rain flag type(esmf_field), public :: snow_liq_equiv_target_grid - ! liquid equiv snow depth + !< liquid equiv snow depth type(esmf_field), public :: snow_depth_target_grid - ! physical snow depth + !< physical snow depth type(esmf_field), public :: soil_temp_target_grid - ! 3-d soil temperature + !< 3-d soil temperature type(esmf_field), public :: soilm_liq_target_grid - ! 3-d liquid soil moisture + !< 3-d liquid soil moisture type(esmf_field), public :: soilm_tot_target_grid - ! 3-d total soil moisture + !< 3-d total soil moisture type(esmf_field), public :: t2m_target_grid - ! 2-m temperatrure + !< 2-m temperatrure type(esmf_field), public :: tprcp_target_grid - ! precip + !< precip type(esmf_field), public :: ustar_target_grid - ! friction velocity + !< friction velocity type(esmf_field), public :: z0_target_grid - ! roughness length + !< roughness length type(esmf_field), public :: lai_target_grid - ! leaf area index + !< leaf area index ! nst fields type(esmf_field), public :: c_d_target_grid + !< Coefficient 2 to calculate d(tz)/d(ts) type(esmf_field), public :: c_0_target_grid + !< Coefficient 1 to calculate d(tz)/d(ts) type(esmf_field), public :: d_conv_target_grid + !< Thickness of free convection layer type(esmf_field), public :: dt_cool_target_grid + !< Sub-layer cooling amount type(esmf_field), public :: ifd_target_grid + !< Model mode index. 0-diurnal model not + !< started; 1-diurnal model started. type(esmf_field), public :: qrain_target_grid + !< Sensible heat flux due to rainfall type(esmf_field), public :: tref_target_grid - ! reference temperature + !< reference temperature type(esmf_field), public :: w_d_target_grid + !< Coefficient 4 to calculate d(tz)/d(ts) type(esmf_field), public :: w_0_target_grid + !< Coefficient 3 to calculate d(tz)/d(ts) type(esmf_field), public :: xs_target_grid + !< Salinity content in diurnal + !< thermocline layer type(esmf_field), public :: xt_target_grid + !< Heat content in diurnal thermocline + !< layer type(esmf_field), public :: xu_target_grid + !< u-current content in diurnal + !< thermocline layer type(esmf_field), public :: xv_target_grid + !< v-current content in diurnal + !< thermocline layer type(esmf_field), public :: xz_target_grid + !< Diurnal thermocline layer thickness type(esmf_field), public :: xtts_target_grid + !< d(xt)/d(ts) type(esmf_field), public :: xzts_target_grid + !< d(xz)/d(ts) type(esmf_field), public :: z_c_target_grid + !< Sub-layer cooling thickness type(esmf_field), public :: zm_target_grid + !< Oceanic mixed layer depth type(esmf_field) :: soil_type_from_input_grid - ! soil type interpolated from - ! input grid + !< soil type interpolated from + !< input grid type(esmf_field) :: terrain_from_input_grid - ! terrain height interpolated - ! from input grid + !< terrain height interpolated + !< from input grid type(esmf_field) :: terrain_from_input_grid_land - ! terrain height interpolated - ! from input grid at all land points + !< terrain height interpolated + !< from input grid at all land points real, parameter, private :: blim = 5.5 - ! soil 'b' parameter limit + !< soil 'b' parameter limit real, parameter, private :: frz_h2o = 273.15 - ! melting pt water + !< melting pt water real, parameter, private :: frz_ice = 271.21 - ! melting pt sea ice + !< melting pt sea ice real, parameter, private :: grav = 9.81 - ! gravity + !< gravity real, parameter, private :: hlice = 3.335E5 - ! latent heat of fusion + !< latent heat of fusion public :: surface_driver @@ -268,10 +290,9 @@ subroutine surface_driver(localpet) end subroutine surface_driver -!--------------------------------------------------------------------------------------------- -! Horizontally interpolate surface fields using esmf routines. -!--------------------------------------------------------------------------------------------- - +!> Horizontally interpolate surface fields using esmf routines. +!! +!! @author George Gayno NOAA/EMC subroutine interp(localpet) use mpi @@ -2482,10 +2503,9 @@ subroutine interp(localpet) end subroutine interp -!--------------------------------------------------------------------------------------------- -! Compute liquid portion of the total soil moisture. -!--------------------------------------------------------------------------------------------- - +!> Compute liquid portion of the total soil moisture. +!! +!! @author George Gayno NOAA/EMC subroutine calc_liq_soil_moisture use esmf @@ -2749,14 +2769,16 @@ end subroutine calc_liq_soil_moisture ! !end subroutine check_smois_water - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> Check soil mositure +!! !! When using vegetation type from the input data instead of the orography file, there !! are frequently points with ~0 soil moisture at land points. For these points, set !! values in all relevant target grid surface arrays to fill values (done in !! check_smois_land) then run the search routine again to fill with appropriate values !! from nearby points (done in replace_land_sfcparams). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! @author Larissa Reames +!! @author Jeff Beck subroutine check_smois_land use model_grid, only : landmask_target_grid @@ -2930,14 +2952,17 @@ subroutine check_smois_land !call search(soilm_target_ptr(clb(1):cub(1),clb(2):cub(2), end subroutine check_smois_land - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!> Replace bad surface points. +!! !! When using vegetation type from the input data instead of the orography file, there !! are frequently points with ~0 soil moisture at land points. For these points, set !! values in all relevant target grid surface arrays to fill values (done in !! check_smois_land) then run the search routine again to fill with appropriate values !! from nearby points (done in replace_land_sfcparams). -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author Larissa Reames +!! @author Jeff Beck subroutine replace_land_sfcparams(localpet) use search_util @@ -3117,51 +3142,31 @@ subroutine replace_land_sfcparams(localpet) end subroutine replace_land_sfcparams - +!> Calculate supercooled soil moisture +!! +!! Calculate amount of supercooled liquid soil water content if +!! temperature is below 273.15K. Requires Newton-type iteration to +!! solve the nonlinear implicit equation given in eqn 17 of Koren et. al +!! (1999, JGR, VOL 104(D16), 19569-19585). +!! +!! New version (June 2001): Much faster and more accurate Newton +!! iteration achieved by first taking log of eqn cited above -- less than +!! 4 (typically 1 or 2) iterations achieves convergence. Also, explicit +!! 1-step solution option for special case of parameter ck=0, which +!! reduces the original implicit equation to a simpler explicit form, +!! known as the "Flerchinger eqn". Improved handling of solution in the +!! limit of freezing point temperature. +!! +!! @param[in] tkelv Temperature (Kelvin) +!! @param[in] smc Total soil moisture content (volumetric) +!! @param[in] sh2O Liquid soil moisture content (volumetric) +!! @param[in] smcmax Saturation soil moisture content +!! @param[in] bexp Soil type "b" parameter +!! @param[in] psis Saturated soil matric potential +!! @return frh2O Supercooled liquid water content +!! +!! @author George Gayno NOAA/EMC @date 2005-05-20 FUNCTION FRH2O (TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) -!$$$ function documentation block -! -! function: frh2o -! prgmmr: gayno org: w/np2 date: 2005-05-20 -! -! abstract: calculate supercooled soil moisture -! -! program history log: -! 2005-05-20 gayno - initial version -! -! usage: x = frh2o (tkelv,smc,sh2o,smcmax,bexp,psis) -! -! input argument list: -! tkelv - temperature (Kelvin) -! smc - total soil moisture content (volumetric) -! sh2O - liquid soil moisture content (volumetric) -! smcmax - saturation soil moisture content -! b - soil type "b" parameter -! psis - saturated soil matric potential -! -! output argument list: -! frh2O - supercooled liquid water content -! -! remarks: stolen from noah lsm code -! -! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF -! TEMPERATURE IS BELOW 273.15K (T0). REQUIRES NEWTON-TYPE ITERATION TO -! SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL -! (1999, JGR, VOL 104(D16), 19569-19585). -! -! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON -! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN -! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT -! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH -! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, -! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE -! LIMIT OF FREEZING POINT TEMPERATURE [AT0. -! -! attributes: -! language: fortran 90 -! machine: IBM SP -! -!$$$ use esmf @@ -3294,10 +3299,10 @@ FUNCTION FRH2O (TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) END function frh2o -!--------------------------------------------------------------------------------------------- -! Adjust soil moisture for changes in soil type between the input and target grids. -!--------------------------------------------------------------------------------------------- - +!> Adjust soil moisture for changes in soil type between the input and target grids. +!! Works for Noah land model only. +!! +!! @author George Gayno NOAA/EMC subroutine rescale_soil_moisture use esmf @@ -3462,11 +3467,10 @@ subroutine rescale_soil_moisture end subroutine rescale_soil_moisture -!--------------------------------------------------------------------------------------------- -! Adjust soil temperature for changes in terrain height between the input and -! target grids. -!--------------------------------------------------------------------------------------------- - +!> Adjust soil temperature for changes in terrain height between the input and +!! target grids. +!! +!! @author George Gayno NOAA/EMC subroutine adjust_soilt_for_terrain use model_grid, only : landmask_target_grid, & @@ -3537,11 +3541,12 @@ subroutine adjust_soilt_for_terrain end subroutine adjust_soilt_for_terrain -!--------------------------------------------------------------------------------------------- -! Adjust soil levels of the input grid if there's a mismatch between input and -! target grids. Presently can only convert from 9 to 4 levels. -!--------------------------------------------------------------------------------------------- - +!> Adjust soil levels of the input grid if there is a mismatch between input and +!! target grids. Presently can only convert from 9 to 4 levels. +!! +!! @param[in] localpet ESMF local persistent execution thread +!! @author Larissa Reames +!! @author Jeff Beck subroutine adjust_soil_levels(localpet) use model_grid, only : lsoil_target, i_input, j_input, input_grid use input_data, only : lsoil_input, soil_temp_input_grid, & @@ -3653,10 +3658,9 @@ subroutine adjust_soil_levels(localpet) end subroutine adjust_soil_levels -!--------------------------------------------------------------------------------------------- -! Set roughness at land and sea ice. -!--------------------------------------------------------------------------------------------- - +!> Set roughness length at land and sea ice. +!! +!! @author George Gayno NOAA/EMC subroutine roughness use model_grid, only : landmask_target_grid @@ -3708,10 +3712,9 @@ subroutine roughness end subroutine roughness -!--------------------------------------------------------------------------------------------- -! QC data before output. -!--------------------------------------------------------------------------------------------- - +!> Perform some quality control checks before output. +!! +!! @author George Gayno NOAA/EMC subroutine qc_check use model_grid, only : landmask_target_grid @@ -4043,11 +4046,10 @@ subroutine qc_check end subroutine qc_check -!--------------------------------------------------------------------------------------------- -! nst is not active at land or sea ice points. Set nst fields to flag values at these -! points. -!--------------------------------------------------------------------------------------------- - +!> nst is not active at land or sea ice points. Set nst fields to flag values at these +!! points. +!! +!! @author George Gayno NOAA/EMC subroutine nst_land_fill use model_grid, only : landmask_target_grid @@ -4254,6 +4256,9 @@ subroutine nst_land_fill end subroutine nst_land_fill +!> Create ESMF fields for the target grid surface variables +!! +!! @author George Gayno NOAA/EMC subroutine create_surface_esmf_fields use model_grid, only : target_grid, lsoil_target @@ -4588,6 +4593,9 @@ subroutine create_surface_esmf_fields end subroutine create_surface_esmf_fields +!> Create ESMF fields for the target grid nst variables +!! +!! @author George Gayno subroutine create_nst_esmf_fields use model_grid, only : target_grid @@ -4724,6 +4732,14 @@ subroutine create_nst_esmf_fields end subroutine create_nst_esmf_fields +!> Convert 1d index to 2d indices. +!! +!! @param[in] ij the 1d index +!! @param[in] itile i-dimension of the tile +!! @param[in] jtile j-dimension of the tile +!! @param[out] i the "i" index +!! @param[out] j the "j" index +!! @author George Gayno NOAA/EMC subroutine ij_to_i_j(ij, itile, jtile, i, j) implicit none From f7036033bdd367f480b3137c4239c263bf5441f4 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Tue, 23 Feb 2021 09:20:34 -0700 Subject: [PATCH 45/47] fix doxygen for sorc/emcsfc_snow2mdl.fd/grib_utils.f (#346) * fix doxygen * fix doxygen * Fix doxygen for ./emcsfc_snow2mdl.fd/grib_utils.f Fixes #291 Part of #191 Co-authored-by: George Gayno --- sorc/emcsfc_snow2mdl.fd/grib_utils.f | 281 ++++++++------------------- 1 file changed, 84 insertions(+), 197 deletions(-) diff --git a/sorc/emcsfc_snow2mdl.fd/grib_utils.f b/sorc/emcsfc_snow2mdl.fd/grib_utils.f index 7d51d9f05..c01d99ab0 100644 --- a/sorc/emcsfc_snow2mdl.fd/grib_utils.f +++ b/sorc/emcsfc_snow2mdl.fd/grib_utils.f @@ -1,8 +1,8 @@ !> @file !! @brief Determine whether file is grib or not. -! -!> Determine whether file is grib or not. !! @author gayno org: w/np2 @date 2007-nov-28 + +!> Determine whether file is grib or not. !! !! program history log: !! - 2007-nov-28 gayno - initial version @@ -57,44 +57,22 @@ subroutine grib_check(file_name, isgrib) end subroutine grib_check +!> Determine whether file is grib or not. +!! +!! Based on w3nco library routine skgb. +!! +!! @param[in] lugb file unit number +!! @param[in] iseek number of bits to skip before search. +!! @param[in] mseek max number of bytes to search. +!! @param[out] lskip number of bytes to skip before message +!! @param[out] lgrib number of bytes in message. '0' if not grib. +!! @param[out] i1 '1' or '2' if grib1/2 file. '0' if not grib. +!! +!! input file: +!! - file to be checked, unit=lugb +!! +!! @author George Gayno org: w/np2 @date 2014-Feb-07 SUBROUTINE SKGB2(LUGB,ISEEK,MSEEK,LSKIP,LGRIB,I1) -!$$$ subprogram documentation block -! -! subprogram: skgb2 -! prgmmr: gayno org: w/np2 date: 2014-feb-07 -! -! abstract: determine whether file is grib or not. -! based on w3nco library routine skgb. -! -! program history log: -! 2014-feb-07 gayno - initial version -! -! usage: call SKGB2(LUGB,ISEEK,MSEEK,LSKIP,LGRIB,I1) -! -! input argument list: lugb - file unit number -! iseek - number of bits to skip -! before search. -! mseek - max number of bytes -! to search. -! -! output argument list: lskip - number of bytes to skip -! before message -! lgrib - number of bytes in message. -! '0' if not grib. -! i1 - '1' or '2' if grib1/2 file. -! '0' if not grib. -! -! files: -! input: -! - file to be checked, unit=lugb -! -! output: none -! -! condition codes: none -! -! remarks: none. -! -!$$$ implicit none INTEGER, INTENT( IN) :: LUGB, ISEEK, MSEEK INTEGER, INTENT(OUT) :: LSKIP, LGRIB, I1 @@ -142,40 +120,23 @@ SUBROUTINE SKGB2(LUGB,ISEEK,MSEEK,LSKIP,LGRIB,I1) RETURN END subroutine skgb2 +!> Convert from the grib2 grid description template array +!! used by the ncep grib2 library, to the grib1 grid +!! description section array used by ncep ipolates library. +!! +!! @param[in] igdtnum grib2 grid desc template number +!! @param[in] igdstmpl grib2 grid desc template array +!! @param[in] igdtlen grib2 grid desc template array size +!! @param[out] kgds grib1 grid description section array used by ncep ipolates library. +!! @param[out] ni i grid dimensions +!! @param[out] nj j grid dimensions +!! @param[out] res grid resolution in km +!! +!! condition codes: +!! 50 - unrecognized model grid type; fatal +!! +!! @author George Gayno org: w/np2 @date 2014-Sep-26 subroutine gdt_to_gds(igdtnum, igdstmpl, igdtlen, kgds, ni, nj, res) -!$$$ subprogram documentation block -! -! subprogram: gdt_to_gds -! prgmmr: gayno org: w/np2 date: 2014-sep-26 -! -! abstract: convert from the grib2 grid description template array -! used by the ncep grib2 library, to the grib1 grid -! description section array used by ncep ipolates library. -! -! program history log: -! 2014-sep-26 gayno - initial version -! -! usage: call gds_to_gds(igdtnum,igdstmpl,igdtlen,kgds,ni,nj,res) -! -! input argument list: -! igdtnum - grib2 grid desc template number -! igdstmpl - grib2 grid desc template array -! igdtlen - grib2 grid desc template array size -! -! output argument list: -! kgds - grib1 grid description section array -! used by ncep ipolates library. -! ni,nj - i/j grid dimensions -! res - grid resolution in km -! -! files: none -! -! condition codes: -! 50 - unrecognized model grid type; fatal -! -! remarks: none. -! -!$$$ implicit none @@ -374,34 +335,19 @@ subroutine gdt_to_gds(igdtnum, igdstmpl, igdtlen, kgds, ni, nj, res) end subroutine gdt_to_gds +!> Determine length of grib2 gds template array, which is a function of +!! the map projection. +!! +!! @note call this routine before init_grib2. +!! +!! @param[in] kgds grib1 gds array +!! @param[in] igdstmplen length of gds template array. +!! +!! condition codes: +!! 47 - unrecognized grid type; fatal +!! +!! @author George Gayno org: w/np2 @date 2014-Sep-28 subroutine grib2_check (kgds, igdstmplen) -!$$$ subprogram documentation block -! -! subprogram: grib2_check -! prgmmr: gayno org: w/np2 date: 2014-sep-28 -! -! abstract: determine length of grib2 gds template array, -! which is a function of the map projection. -! -! program history log: -! 2014-sep-28 gayno - initial version -! -! usage: call grib2_check (kgds, igdstmplen) -! -! input argument list: kgds - grib1 gds array -! -! output argument list: igdstmplen - length of gds template -! array. -! -! files: none -! -! condition codes: -! 47 - unrecognized grid type; fatal -! -! remarks: call this routine before init_grib2. -! -!$$$ - implicit none integer, intent(in) :: kgds(200) @@ -421,58 +367,37 @@ subroutine grib2_check (kgds, igdstmplen) end subroutine grib2_check +!> Initialize grib2 arrays required by the ncep g2 library according to +!! grib1 gds information. The grib1 gds is held in the kgds array, which +!! is used by the ncep ipolates and w3nco (grib 1) libraries. +!! +!! Call routine grib2_check first to determine igdstmplen. +!! +!! @param[in] century current date/time info +!! @param[in] year current date/time info +!! @param[in] month current date/time info +!! @param[in] day current date/time info +!! @param[in] hour current date/time info +!! @param[in] kgds grib1 gds information +!! @param[in] igdstmplen length of grib2 gdt template. +!! @param[in] lat11 lat of first grid point +!! @param[in] lon11 lon of first grid point +!! @param[in] latlast lat of last grid point +!! @param[in] lonlast lon of last grid point +!! @param[out] igds grib2 section 3 information. +!! @param[out] listsec0 grib2 section 0 information. +!! @param[out] listsec1 grib2 section 1 information. +!! @param[out] ipdsnum grib2 pds template number +!! @param[out] ipdstmpl grib2 pds template array +!! @param[out] igdstmpl grib2 gds template array +!! @param[out] idefnum information for non-reg grid, grid points in each row. +!! @param[out] ideflist information for non-reg grid, grid points in each row. +!! @param[out] ngrdpts number of model grid points. +!! @author George Gayno org: w/np2 @date 2014-Sep-28 subroutine init_grib2(century, year, month, day, hour, kgds, & lat11, latlast, lon11, lonlast, & listsec0, listsec1, igds, ipdstmpl, ipdsnum, igdstmpl, & igdstmplen, idefnum, ideflist, ngrdpts) -!$$$ subprogram documentation block -! -! subprogram: init_grib2 -! prgmmr: gayno org: w/np2 date: 2014-sep-28 -! -! abstract: initialize grib2 arrays required by the ncep g2 library -! according to grib1 gds information. the grib1 gds is -! held in the kgds array, which is used by the ncep ipolates -! and w3nco (grib 1) libraries. -! -! program history log: -! 2014-sep-28 gayno - initial version -! -! usage: init_grib2(century, year, month, day, hour, kgds, & -! lat11, latlast, lon11, lonlast, & -! listsec0, listsec1, igds, ipdstmpl, ipdsnum, igdstmpl, & -! igdstmplen, idefnum, ideflist, ngrdpts) -! -! input argument list: -! century/year/month/day/hour - current date/time info -! kgds - grib1 gds information -! igdstmplen - length of grib2 gdt -! template. -! lat11, lon11 - lat/lon of first grid point -! latlast, lonlast - lat/lon of last grid point -! -! output argument list: -! igds - grib2 section 3 information. -! listsec0 - grib2 section 0 information. -! listsec1 - grib2 section 1 information. -! ipdsnum - grib2 pds template number -! ipdstmpl - grib2 pds template array -! igdstmpl - grib2 gds template array -! idefnum/ideflist - information for non-reg grid, -! # grid points in each row. -! ngrdpts - number of model grid points. -! -! files: -! input: none -! -! output: none -! -! condition codes: none -! -! remarks: call routine grib2_check first to determine igdstmplen. -! -!$$$ - implicit none integer, intent(in ) :: century, year, month, day, hour @@ -677,32 +602,13 @@ subroutine init_grib2(century, year, month, day, hour, kgds, & end subroutine init_grib2 +!> Nullify the grib2 gribfield pointers. +!! +!! @param[in] gfld a gribfield data structure +!! @param[out] gfld a gribfield data structure +!! +!! @author George Gayno org: w/np2 @date 2014-Sep-28 subroutine grib2_null(gfld) -!$$$ subprogram documentation block -! -! subprogram: grib2_null -! prgmmr: gayno org: w/np2 date: 2014-sep-28 -! -! abstract: nullify the grib2 gribfield pointers. -! -! program history log: -! 2014-sep-28 gayno - initial version -! -! usage: call grib2_null with a gribfield data structure -! -! input argument list: -! gfld - a gribfield data structure -! -! output argument list: -! gfld - a gribfield data structure -! -! files: none -! -! condition codes: none -! -! remarks: none -! -!$$$ use grib_mod @@ -722,32 +628,13 @@ subroutine grib2_null(gfld) end subroutine grib2_null +!> Deallocate the grib2 gribfield pointers. +!! +!! @param[in] gfld a gribfield data structure +!! @param[in] gfld a gribfield data structure +!! +!! @author George Gayno org: w/np2 @date 2014-Sep-28 subroutine grib2_free(gfld) -!$$$ subprogram documentation block -! -! subprogram: grib2_free -! prgmmr: gayno org: w/np2 date: 2014-sep-28 -! -! abstract: deallocate the grib2 gribfield pointers. -! -! program history log: -! 2014-sep-28 gayno - initial version -! -! usage: call grib2_free with a gribfield data structure -! -! input argument list: -! gfld - a gribfield data structure -! -! output argument list: -! gfld - a gribfield data structure -! -! files: none -! -! condition codes: none -! -! remarks: none -! -!$$$ use grib_mod From 9d9dd23e37a51fcc5ff6b7499b834c85ab32e5f3 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Tue, 23 Feb 2021 15:59:01 -0700 Subject: [PATCH 46/47] delete global_chgres (#299) * removed global_chgres * removed global_chgres from docs * removed nemsiogfs and landsfcutil from the build and modulefiles --- CMakeLists.txt | 2 - docs/user_guide.md | 4 - modulefiles/build.cheyenne.intel | 2 - modulefiles/build.hera.gnu | 2 - modulefiles/build.hera.intel | 2 - modulefiles/build.jet.intel | 2 - modulefiles/build.odin.intel | 2 - modulefiles/build.orion.intel | 2 - modulefiles/build.stampede.intel | 2 - modulefiles/build.wcoss_cray.intel | 2 - modulefiles/build.wcoss_dell_p3.intel | 2 - sorc/CMakeLists.txt | 2 - sorc/global_chgres.fd/CMakeLists.txt | 44 - sorc/global_chgres.fd/chgres.f90 | 1577 --- sorc/global_chgres.fd/chgres_utils.f90 | 2254 ----- sorc/global_chgres.fd/funcphys.f90 | 2892 ------ .../global_chgres_users_guide.md | 141 - sorc/global_chgres.fd/machine_8.f90 | 18 - sorc/global_chgres.fd/nrlmsise00_sub.f90 | 2428 ----- sorc/global_chgres.fd/nsst_chgres.f90 | 238 - sorc/global_chgres.fd/nstio_module.f90 | 1235 --- sorc/global_chgres.fd/num_parthds.f90 | 13 - sorc/global_chgres.fd/physcons.f90 | 92 - sorc/global_chgres.fd/read_write.f90 | 4336 --------- sorc/global_chgres.fd/sfcsub.F | 8651 ----------------- sorc/global_chgres.fd/surface_chgres.f90 | 2992 ------ ush/global_chgres.sh | 547 -- ush/global_chgres_driver.sh | 297 - 28 files changed, 27781 deletions(-) delete mode 100644 sorc/global_chgres.fd/CMakeLists.txt delete mode 100755 sorc/global_chgres.fd/chgres.f90 delete mode 100755 sorc/global_chgres.fd/chgres_utils.f90 delete mode 100755 sorc/global_chgres.fd/funcphys.f90 delete mode 100755 sorc/global_chgres.fd/global_chgres_users_guide.md delete mode 100755 sorc/global_chgres.fd/machine_8.f90 delete mode 100755 sorc/global_chgres.fd/nrlmsise00_sub.f90 delete mode 100644 sorc/global_chgres.fd/nsst_chgres.f90 delete mode 100755 sorc/global_chgres.fd/nstio_module.f90 delete mode 100755 sorc/global_chgres.fd/num_parthds.f90 delete mode 100755 sorc/global_chgres.fd/physcons.f90 delete mode 100644 sorc/global_chgres.fd/read_write.f90 delete mode 100644 sorc/global_chgres.fd/sfcsub.F delete mode 100755 sorc/global_chgres.fd/surface_chgres.f90 delete mode 100755 ush/global_chgres.sh delete mode 100755 ush/global_chgres_driver.sh diff --git a/CMakeLists.txt b/CMakeLists.txt index 266ec8c27..b02821a17 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -56,10 +56,8 @@ endif() find_package(gfsio REQUIRED) find_package(sfcio REQUIRED) find_package(w3nco REQUIRED) -find_package(landsfcutil REQUIRED) find_package(bacio REQUIRED) find_package(nemsio REQUIRED) -find_package(nemsiogfs REQUIRED) find_package(sigio REQUIRED) find_package(sp REQUIRED) find_package(ip REQUIRED) diff --git a/docs/user_guide.md b/docs/user_guide.md index 71a33f9e5..b4ba4807a 100644 --- a/docs/user_guide.md +++ b/docs/user_guide.md @@ -29,10 +29,6 @@ https://github.com/NOAA-EMC/UFS_UTILS. Operational Forecast System (GLOFS) in an FV3 surface restart file. See [fvcom documentation](@ref fvcom_readme). -- global_chgres - Creates cold start initial conditions for FV3 model - runs. Deprecated by the chgres_cube utility. See [global_chgres - documentation](@ref global_chgres_users_guide). - - global_cycle - Updates the GFS surface conditions using external snow and sea ice analyses. Updates monthly climatological fields such as plant greenness fraction and albedo. Runs as part of the GFS diff --git a/modulefiles/build.cheyenne.intel b/modulefiles/build.cheyenne.intel index fe225d01f..cee0935de 100644 --- a/modulefiles/build.cheyenne.intel +++ b/modulefiles/build.cheyenne.intel @@ -22,8 +22,6 @@ module load sigio/2.3.2 module load sfcio/1.4.1 module load gfsio/1.4.1 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 module load netcdf/4.7.4 diff --git a/modulefiles/build.hera.gnu b/modulefiles/build.hera.gnu index b7e9260cf..937c960c5 100644 --- a/modulefiles/build.hera.gnu +++ b/modulefiles/build.hera.gnu @@ -23,8 +23,6 @@ module load w3nco/2.4.1 module load gfsio/1.4.1 module load sfcio/1.4.1 module load sigio/2.3.2 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 module load nccmp/1.8.7.0 module load png/1.6.35 diff --git a/modulefiles/build.hera.intel b/modulefiles/build.hera.intel index 3774f7def..14c719f26 100644 --- a/modulefiles/build.hera.intel +++ b/modulefiles/build.hera.intel @@ -21,8 +21,6 @@ module load w3nco/2.4.1 module load gfsio/1.4.1 module load sfcio/1.4.1 module load sigio/2.3.2 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 module load jasper/2.0.15 diff --git a/modulefiles/build.jet.intel b/modulefiles/build.jet.intel index d14b5ee59..39377575f 100644 --- a/modulefiles/build.jet.intel +++ b/modulefiles/build.jet.intel @@ -22,8 +22,6 @@ module load bacio/2.4.1 module load sigio/2.3.2 module load sfcio/1.4.1 module load nemsio/2.5.2 -module load nemsiogfs/2.5.3 module load gfsio/1.4.1 -module load landsfcutil/2.4.1 module load g2/3.4.1 module load wgrib2/2.0.8 diff --git a/modulefiles/build.odin.intel b/modulefiles/build.odin.intel index 5be328674..30adf99d3 100644 --- a/modulefiles/build.odin.intel +++ b/modulefiles/build.odin.intel @@ -25,9 +25,7 @@ module load bacio module load sigio module load sfcio module load nemsio -module load nemsiogfs module load gfsio -module load landsfcutil module load g2 module load wgrib2 diff --git a/modulefiles/build.orion.intel b/modulefiles/build.orion.intel index 5ec3d5802..0c805aeba 100644 --- a/modulefiles/build.orion.intel +++ b/modulefiles/build.orion.intel @@ -20,8 +20,6 @@ module load w3nco/2.4.1 module load gfsio/1.4.1 module load sfcio/1.4.1 module load sigio/2.3.2 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 module load jasper/2.0.15 diff --git a/modulefiles/build.stampede.intel b/modulefiles/build.stampede.intel index 72de7107c..4e37c6e84 100644 --- a/modulefiles/build.stampede.intel +++ b/modulefiles/build.stampede.intel @@ -32,9 +32,7 @@ module load bacio module load sigio module load sfcio module load nemsio -module load nemsiogfs module load gfsio -module load landsfcutil module load g2 module load wgrib2 diff --git a/modulefiles/build.wcoss_cray.intel b/modulefiles/build.wcoss_cray.intel index c54daea65..ab776c745 100644 --- a/modulefiles/build.wcoss_cray.intel +++ b/modulefiles/build.wcoss_cray.intel @@ -27,8 +27,6 @@ module load w3nco/2.4.1 module load gfsio/1.4.1 module load sfcio/1.4.1 module load sigio/2.3.2 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 setenv ZLIB_ROOT /usrx/local/prod/zlib/1.2.7/intel/haswell diff --git a/modulefiles/build.wcoss_dell_p3.intel b/modulefiles/build.wcoss_dell_p3.intel index 117093998..38221bf78 100644 --- a/modulefiles/build.wcoss_dell_p3.intel +++ b/modulefiles/build.wcoss_dell_p3.intel @@ -31,8 +31,6 @@ module load w3nco/2.4.1 module load gfsio/1.4.1 module load sfcio/1.4.1 module load sigio/2.3.2 -module load nemsiogfs/2.5.3 -module load landsfcutil/2.4.1 module load wgrib2/2.0.8 module use /usrx/local/dev/modulefiles diff --git a/sorc/CMakeLists.txt b/sorc/CMakeLists.txt index d7f473dc2..505ec9e4d 100644 --- a/sorc/CMakeLists.txt +++ b/sorc/CMakeLists.txt @@ -5,10 +5,8 @@ add_subdirectory(emcsfc_ice_blend.fd) add_subdirectory(emcsfc_snow2mdl.fd) if (OpenMP_FOUND) - add_subdirectory(global_chgres.fd) add_subdirectory(global_cycle.fd) else() - message(STATUS "OpenMP is required for global_chgres.fd and was NOT found, skipping ...") message(STATUS "OpenMP is required for global_cycle.fd and was NOT found, skipping ...") endif() add_subdirectory(nst_tf_chg.fd) diff --git a/sorc/global_chgres.fd/CMakeLists.txt b/sorc/global_chgres.fd/CMakeLists.txt deleted file mode 100644 index 4c2133a35..000000000 --- a/sorc/global_chgres.fd/CMakeLists.txt +++ /dev/null @@ -1,44 +0,0 @@ -set(fortran_src - chgres.f90 - chgres_utils.f90 - funcphys.f90 - machine_8.f90 - nrlmsise00_sub.f90 - nsst_chgres.f90 - nstio_module.f90 - num_parthds.f90 - physcons.f90 - read_write.f90 - sfcsub.F - surface_chgres.f90) - -if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -convert big_endian") -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fconvert=big-endian") - if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) - set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-argument-mismatch") - endif() -endif() - -set(exe_name global_chgres) -add_executable(${exe_name} ${fortran_src}) -target_link_libraries( - ${exe_name} - gfsio::gfsio - nemsiogfs::nemsiogfs - nemsio::nemsio - sigio::sigio - sfcio::sfcio - landsfcutil::landsfcutil_d - ip::ip_d - sp::sp_d - w3emc::w3emc_d - w3nco::w3nco_d - bacio::bacio_4 - NetCDF::NetCDF_Fortran) -if(OpenMP_Fortran_FOUND) - target_link_libraries(${exe_name} OpenMP::OpenMP_Fortran) -endif() - -install(TARGETS ${exe_name} RUNTIME DESTINATION ${exec_dir}) diff --git a/sorc/global_chgres.fd/chgres.f90 b/sorc/global_chgres.fd/chgres.f90 deleted file mode 100755 index 1f0c6d5a3..000000000 --- a/sorc/global_chgres.fd/chgres.f90 +++ /dev/null @@ -1,1577 +0,0 @@ -!> @file -!! -!! @author IREDELL @date 1999-09-10 -!! -!! THIS PROGRAM INTERPOLATES THE SIGMA, SURFACE AND NSST RESTART -!! FILES FROM THE GLOBAL SPECTRAL MODEL TO THE FV3 CUBED SPHERE GRID. -!! -!! THE PROCEDURE FOR CHANGING THE SIGMA FILE RESOLUTION IS THUS: -!! WHEN THE SIGMA FILE IS SIGIO FORMAT (SPECTRAL COEFFICIENTS) -!! THE DATA IS FIRST CONVERTED FROM SPECTRAL TO GRID POINT -!! SPACE (A GLOBAL GAUSSIAN OR REGULAR LAT/LON GRID). THE DIMENSIONS -!! OF THAT GLOBAL GRID ARE USER-SELECTABLE. BY DEFAULT, THE -!! DIMENSIONS ARE DETERMINED FROM THE JCAP VALUE OF THE INPUT -!! DATA. NO CONVERSION IS REQUIRED WHEN THE WHEN THE SIGMA FILE -!! IS IN NEMSIO FORMAT AS THE DATA ARE ALREADY IN GRID POINT SPACE. -!! IF THE USER SELECTS A NEW NUMBER OF VERTICAL LEVELS OR A -!! DIFFERENT TYPE OF LEVEL (I.E., HYBRID OR SIGMA), THEN A VERTICAL -!! INTERPOLATION IS PERFOMRED. THE DATA ARE THEN INTERPOLATED -!! FROM THE GLOBAL GRID TO THE SIX TILES OF THE FV3 CUBED SPHERE -!! GRID. -!! -!! THE SURFACE FILE CONVERSION IS DONE FOR A SINGLE FV3 TILE ONLY. -!! SO FOR A GLOBAL SIX TILE FV3 GRID, THIS PROGRAM MUST BE CALLED -!! SIX TIMES. THE PROCEDURE FOR INTERPOLATING SURFACE DATA IS: -!! NEAREST NEIGHBOR INTERPOLATION IS PERFORMED SO THAT LAND/NONLAND -!! POINTS ON THE INPUT GRID ARE MAPPED TO LAND/NONLAND POINTS -!! ON THE TARGET GRID. IF THE INPUT FILE CONTAINS LANDICE -!! AND THE OUTPUT GRID IS TO HAVE LANDICE, THEN NONLAND IS -!! MAPPED TO NONLAND, LANDICE IS MAPPED TO LANDICE, ICE FREE -!! LAND IS MAPPED TO ICE FREE LAND. OPTIONALLY, THE CLIMO FIELDS -!! SUCH AS ALBEDO, ROUGHNESS, ETC, MAY DETERMINED ON THE OUTPUT -!! GRID FROM SFCCYCLE (WHICH IS CALLED FROM THE SURFACE -!! CHGRES MODULE). THE LATTER IS RECOMMENDED WHEN CONVERTING -!! FROM A LOW TO HIGH RESOLUTION GRID. THE LAND-SEA MASK ON THE -!! TARGET FV3 TILE IS READ FROM FILE. SKIN AND SOIL TEMPERATURE OVER -!! LAND ARE ADJUSTED FOR DIFFERENCES BETWEEN THE INPUT AND OUTPUT -!! OROGRAPHY. LIQ SOIL MOISTURE IS CALCULATED ACCORDING TO THE -!! ADJUSTED TEMP. OROGRAPHY ON THE TARGET FV3 TILE IS READ FROM -!! THE SAME FILE AS THE FV3 LAND-SEA MASK. THE PROGRAM WILL ALSO -!! CONVERT FROM TWO TO FOUR SOIL LAYERS AND VICE VERSA. IT WILL -!! WILL INITIALIZE ALL LAND STATES FOR THE LANDICE PHYSICS IF -!! DESIRED. THE PROGRAM WILL SCALE TOTAL SOIL MOISTURE FOR ANY -!! DIFFERENCES IN SOIL TYPE BETWEEN THE INPUT AND OUTPUT GRIDS. -!! -!! THE PROCEDURE FOR CONVERTING AN NSST FILE IS THUS: -!! NEAREST NEIGHBOR INTERPOLATION IS USED TO MAP TO THE OUTPUT -!! GRID AS SOME NSST FIELDS ARE NOT CONTINUOUS. NSST FIELDS -!! ARE ONLY REQUIRED AT OPEN WATER POINTS. FOR CONSISTENCY, -!! THESE OPEN WATER POINTS ARE DETERMINED BY THE FV3 LAND-SEA -!! MASK OUTPUT FROM THE SURFACE FILE CONVERSION STEP (WHICH -!! INCLUDES SEA ICE). THEREFORE, WHEN CONVERTING AN NSST FILE, -!! A SURFACE RESTART FILE MUST ALSO BE CONVERTED. AS FOR THE -!! SURFACE, THE NSST CONVERSION IS DONE FOR A SINGLE FV3 TILE -!! ONLY. -!! -!! PROGRAM HISTORY LOG: -!! - 98-04-03 IREDELL -!! - 2007 JUANG, MOORTHI, GAYNO, F YANG, DORIS PAN -!! - 2008 MOORTHI S -!! - 2011-08-05 GAYNO G : ADDED CAPABILITY TO WORK WITH NSST FILES -!! - 2011 J. WANG : CHANGE HEADER FOR SIGIO TO NEMSIO FILE -!! - 2013 SARAH LU : REVISE NEWSIG (COPIED FROM GLOBAL_CHGRES.FD) -!! - 2014 MOORTHI S : MERGED TRUNK VERSION WITH NGAC VERSION (NEMSIO) -!! - 2015 MOORTHI S : ADDED OPTION TO USE BINARY OROGRAPHY -!! - 2015 IREDELL M : ADDED OPTION TO WRITE NEMSIO ON REDUCED GRID -!! - 2015 FANGLIN Y : ADDED THE LOGICAL RDGRID -!! - 2015-10-06 MOORTHI S : ADDED OPTION TO READ PAST ICS FROM TOM HAMILL FOR GEFS -!! - 2015-12-06 MOORTHI S : ADDED OPTION TO READ NEMSIO FILE WITHOUT P, DP, VEL (NOPDPVV) -!! - 2016-04-22 MOORTHI S : MERGE WITH JIM ABLES'S MODIFICATIONS ADDING LATITUDINAL -!! DECOMPOSITION TO ENABLE CHANGING RESOLUTION FROM A NEMSIO -!! FILE TO A NEMSIO FILE. UPGRADE THE CODE TO WORK FOR -!! VERTICAL RESOLUTION CHANGE AND FIX SOME ADDITIONAL BUGS. -!! ADDED NOPDPVV OPTION NOT TO OUTPUT P, DP AND VVEL -!! - 2016-04-27 MOORTHI S : FIXED A BUG FOR NOPDPVV=.FALSE. -!! - 2016-06-01 GAYNO G : OPTION TO PROCESS NSST FILES IN NEMSIO FORMAT -!! - 2017-01-27 GAYNO/GFDL : EXTENSIVE MODIFICATIONS TO INTERPOLATE GFS DATA -!! TO FV3 CUBED SPHERE GRID. -!! - 2017-04-12 GAYNO : WRITE NSST RECORDS TO THE SURFACE NETCDF RESTART -!! FILE. PREVIOUSLY, THE NSST RECORDS WERE WRITTEN -!! -!! NAMELISTS: -!! NAMCHG: -!! - LEVS INTEGER NEW NUMBER OF ATMOSPHERIC LEVELS (DEFAULT: NO CHANGE -!! FROM INPUT GFS DATA) -!! - NTRAC INTEGER NEW NUMBER OF TRACERS (DEFAULT: NO CHANGE FROM INPUT -!! GFS DATA) -!! - LONB INTEGER NUMBER OF LONGITUDES - GFS GAUSSIAN INPUT GRID. ONLY -!! USED WHEN INPUT GFS DATA IS SFCIO FORMAT. (DEFAULT: FROM -!! INPUT GFS SFCIO DATA HEADER) -!! - LATB INTEGER NUMBER OF LATITUDES - GFS GAUSSIAN INPUT GRID. ONLY -!! USED WHEN INPUT GFS DATA IS SFCIO FORMAT. (DEFAULT: FROM -!! INPUT GFS SFCIO DATA HEADER) -!! - IDVC INTEGER NEW VERTICAL COORDINATE ID -!! (1 FOR SIGMA, 2 FOR HYBRID, 3 GENERAL HYBRID) (DEFAULT: SAME AS -!! INPUT GFS DATA) -!! - IDVM INTEGER NEW VERTICAL MASS VARIABLE ID -!! (1 FOR LN(PS) AND 2 FOR PS (KPA)) (DEFAULT: SAME AS INPUT GFS -!! DATA). -!! - IDSL INTEGER NEW TYPE OF SIGMA STRUCTURE -!! (1 FOR PHILLIPS OR 2 FOR MEAN) (DEFAULT: SAME AS INPUT GFS DATA) -!! - MQUICK INTEGER FLAG TO SKIP VERTICAL INTERPOLATION. USEFUL WHEN THE -!! NUMBER AND TYPE OF VERTICAL LEVELS IS NOT CHANGING. ONLY -!! ACTIVE WHEN INPUT GFS DATA IS NEMSIO FORMAT. (DEFAULT: 0 - -!! DONT SKIP. TO SKIP, SET TO 1) -!! - IDVT INTEGER NEW TRACER VARIABLE ID (DEFAULT: SAME AS INPUT GFS DATA) -!! - LATCH INTEGER NUMBER OF GAUSSIAN LATITUDES TO PROCESS AT ONE TIME -!! (DEFAULT: 8) -!! - LSOIL INTEGER NEW NUMBER OF SOIL LAYERS (DEFAULT: NO CHANGE FROM INPUT -!! GFS DATA). -!! - IVSSFC INTEGER NEW VERSION NUMBER SFC FILE (DEFAULT: NO CHANGE FROM INPUT -!! GFS DATA). -!! - NVCOORD INTEGER NEW NUMBER OF VERTICAL COORDINATES -!! (DEFAULT: NO CHANGE FROM INPUT GFS DATA) -!! - IDRT SPECTRAL TO INTERMEDIATE GRID OPTION. WHEN INPUT GFS SIGMA FILE IS -!! SIGIO FORMAT (SPECTRAL COEFFICIENTS), CHGRES FIRST CONVERTS TO A -!! TO A GLOBAL GRID. THAT GLOBAL GRID IS IN TURN INTERPOLATED TO THE -!! FV3 GRID TILES. THE IDRT OPTION CONTROLS WHAT GLOBAL GRID IS -!! CHOSEN. DEFAULT IS '4' - GLOBAL GAUSSIAN GRID. CAN ALSO CHOOSE -!! '0' - GLOBAL REGULAR LAT/LON GRID. -!! - OUTTYP INTEGER NUMBER OF OUTPUT FILE TYPE. NOT USED YET. CURRENTLY, -!! THE FV3 SIGMA AND SURFACE/NSST FILES ARE NETCDF FORMAT ONLY. -!! - CHGQ0 SET NEGATIVE VALUES OF TRACERS TO ZERO: 0 FALSE; 1 TRUE. -!! - REGIONAL FLAG FOR PROCESSING STAND-ALONE NEST. WHEN '1', REMOVE HALO -!! FROM GRIDS AND CREATE AN ATMOSPHERIC BOUNDARY FILE. WHEN '2', -!! CREATE BOUNDARY FILE ONLY. WHEN '0', PROCESS NORMALLY AS -!! FOR A GLOBAL GRID. DEFAULT IS '0'. -!! - HALO WHEN RUNNING A STAND-ALONE NEST, THIS SPECIFIES THE NUMBER OF -!! ROWS/COLS FOR THE HALO. -!! -!! INPUT FILES: -!! -UNIT 11 CHGRES.INP.SIG GFS SIGMA FILE (IN EITHER SIGIO OR NEMSIO FORMAT) -!! -UNIT 13 CHGRES.INP.SIGLEVEL NEW VERTICAL STRUCTURE -!! -UNIT 21 CHGRES.INP.SFC GFS SURFACE FILE (SFCIO OR NEMSIO FORMAT) -!! -UNIT 17 CHGRES.INP.LPL3 WHEN GFS SIGMA FILE IS SIGIO (SPECTRAL), CHGRES -!! FIRST CONVERTS TO A GLOBAL GAUSSIAN OR LAT/LON -!! GRID. THIS GRID CAN BE REDUCED (# GRID POINTS -!! DECREASES TOWARDS THE POLE). THIS FILE DEFINES -!! THE REDUCED GRID. -!! -UNIT 31 CHGRES.INP.NST NSST FILE FOR INPUT GRID (NSTIO OR NEMSIO FORMAT) -!! NOTE: FV3GFS OUTPUTS NSST FIELDS IN THE SURFACE -!! FILE - CHGRES.INP.SFC -!! -UNIT ?? CHGRES.FV3.OROG.T[1-6] FV3 OROGRAPHY AND LAND MASK. ONE FILE FOR EACH -!! SIX GLOBAL TILES (NETCDF FORMAT) -!! -UNIT ?? CHGRES.FV3.GRD.T[1-6] FV3 GRID SPECS FILE. ONE FILE FOR EACH SIX -!! GLOBAL TILES (NETCDF FORMAT) -!! OUTPUT FILES: -!! -UNIT ?? GFS_CTRL.NC FV3 ATMOSPHERIC HEADER FILE (NETCDF FORMAT) -!! -UNIT ?? OUT.SFC.TILE[1-6].NC FV3 SURFACE/NSST DATA FILE (NETCDF FORMAT) ONE -!! FILE FOR EACH SIX GLOBAL TILES. -!! -UNIT ?? GFS_DATA.TILE[1-6].NC FVN ATMOSPHERIC FILE (NETCDF FORMAT). ONE FILE -!! FOR EACH SIX GLOBAL TILES. -!! -!! REMARKS: -!! VALID VALUES OF IDVT -!! ALL UNITS ARE SPECIFIC IN KG/KG -!! 
-!!  IDVT  NTRAC 
-!!     0      2    VAPOR,OZONE,CLOUD (DEFAULT OPERATIONAL)
-!!     1      1    VAPOR,OZONE
-!!     2      1    VAPOR,CLOUD
-!!    21      2    VAPOR,OZONE,CLOUD
-!!    12      2    VAPOR,CLOUD,OZONE
-!!   100     20    SET 1: VAPOR,OZONE,CLOUD, AND INITIAL VALUES OF
-!!                 CLAT*CLON,CLAT*SLON,SLAT,
-!!                 V*SLON-U*SLAT*CLON,-V*CLON-U*SLAT*SLON,U*CLAT
-!!                 ONE,K,SIGMA,PS,PRES,TEMP,ENTROPY,MOIST ENTROPY
-!!                 VAPOR,OZONE,CLOUD
-!!   200       5   IDEA tracer set with O and O2 in addition q, O3, clw
-!!
-!! -!! NUMBER OF TRACERS FOR NEMSIO FILE: -!! - data holder q(:,:,ntraco_q) -!! - ntraco_q=NTRAC_MET+NTRACO_AER -!! - nemsio data header recname/reclevtyp/reclev, NTRAC=NTRAC_MET+NTRAC_AER -!! - NTRAC_MET: meteorology tracerss, could be: spfh,ozn,cld -!! - NTRAC_AER: aerosol tracer -!! - PROGRAM CHGRES - USE SIGIO_MODULE - USE NEMSIO_MODULE - USE NEMSIO_GFS - USE SFCIO_MODULE - USE FUNCPHYS - USE SURFACE_CHGRES - - IMPLICIT NONE - - INTERFACE - SUBROUTINE WRITE_FV3_SFC_DATA_NETCDF(IMO,JMO,LSOILO,SFCOUTPUT,F10MO, & - T2MO,Q2MO,UUSTARO,FFMMO,FFHHO,TPRCPO, & - SRFLAGO,TILE_NUM,NUM_NSST_FIELDS,NSST_OUTPUT) - USE SURFACE_CHGRES - IMPLICIT NONE - INTEGER, INTENT(IN) :: IMO, JMO, LSOILO, TILE_NUM - INTEGER, INTENT(IN) :: NUM_NSST_FIELDS - REAL, INTENT(IN) :: F10MO(IMO,JMO) - REAL, INTENT(IN) :: Q2MO(IMO,JMO) - REAL, INTENT(IN) :: T2MO(IMO,JMO) - REAL, INTENT(IN) :: UUSTARO(IMO,JMO) - REAL, INTENT(IN) :: FFMMO(IMO,JMO) - REAL, INTENT(IN) :: FFHHO(IMO,JMO) - REAL, INTENT(IN) :: TPRCPO(IMO,JMO) - REAL, INTENT(IN) :: SRFLAGO(IMO,JMO) - REAL, INTENT(IN), OPTIONAL :: NSST_OUTPUT(IMO*JMO,NUM_NSST_FIELDS) - TYPE(SFC1D) :: SFCOUTPUT - END SUBROUTINE WRITE_FV3_SFC_DATA_NETCDF - END INTERFACE - - INTEGER:: LEVS=0,NTRAC=0,LONB=0,LATB=0, & - IDVC=0,IDVM=0,IDSL=0,MQUICK=0,IDVT=0, & - LATCH=4,LSOIL=0,IVSSFC=0,NVCOORD=0, & - IDRT=4,OUTTYP=999,IALB=0,CHGQ0=0,ISOT=0,IVEGSRC=0, & - NTILES=6,TILE_NUM=1,REGIONAL=0,HALO=0 -! - REAL, PARAMETER :: PIFAC=180/ACOS(-1.0) -! - REAL RI(0:20),CPI(0:20) - - LOGICAL USE_UFO, NST_ANL, RDGRID, NOPDPVV - - NAMELIST/NAMCHG/ LEVS,NTRAC,LONB,LATB, & - IDVC,IDVM,IDSL,MQUICK,IDVT,LATCH, & - LSOIL,IVSSFC,NVCOORD,OUTTYP,IDRT,RI,CPI, & - IALB,CHGQ0,USE_UFO,NST_ANL,RDGRID, & - NOPDPVV,ISOT,IVEGSRC,NTILES,TILE_NUM, & - REGIONAL, HALO -! - INTEGER NSIGI,NSIL,NSIGO, & - IRET,IOSSIL,IRET0,IRET1, & - NCI,IMI,JMI,IMO,JMO,IJX,NTRACM, & - J1,J2,JL,IJL,J,JN,JS,N, & - NTRACO, IJMO, LATCH2, K, LATG2, & - NSFCI,NSFCO,INPTYP, & - SFCPRESS_ID_I, THERMODYN_ID_I, & - SFCPRESS_ID_O, THERMODYN_ID_O, & - NREC, LEVSI, LEVSO, I, L - - INTEGER :: IMO_WITH_HALO, JMO_WITH_HALO - INTEGER :: NSST_YEAR, NSST_MON - INTEGER :: NSST_DAY, NSST_HOUR - INTEGER, DIMENSION(200) :: KGDS_INPUT, KGDS_OUTPUT - REAL, ALLOCATABLE :: MASK_OUTPUT(:), RLATS_OUTPUT(:), & - RLONS_OUTPUT(:), NSST_INPUT(:,:,:), & - MASK_INPUT(:,:), NSST_OUTPUT(:,:) - INTEGER, PARAMETER :: NUM_NSST_FIELDS=18 - TYPE(SFC2D) :: SFCINPUT - TYPE(SFC1D) :: SFCOUTPUT - LOGICAL, PARAMETER :: MERGE=.FALSE. - LOGICAL :: DO_NSST - REAL,ALLOCATABLE :: SLAT(:),WLAT(:),CLAT(:),RLAT(:) - REAL,ALLOCATABLE :: OROGO(:,:), OROGO_UF(:,:) - REAL,ALLOCATABLE :: ZSI(:,:), PSI(:,:), PI(:,:,:), & - TI(:,:,:), UI(:,:,:),VI(:,:,:), & - QI(:,:,:,:), WI(:,:,:), TIV(:,:,:), & - XCP(:,:,:),VIRT(:,:,:),SUMQ(:,:,:) - REAL,ALLOCATABLE :: ZSO(:,:), PSO(:,:), PO(:,:,:), & - TO(:,:,:), UO(:,:,:),VO(:,:,:), & - QO(:,:,:,:), WO(:,:,:), TPO(:,:), & - DTDPO(:,:,:),DPO(:,:,:) - REAL,ALLOCATABLE :: F10MI(:,:),T2MI(:,:),Q2MI(:,:) - REAL,ALLOCATABLE :: UUSTARI(:,:),FFMMI(:,:),FFHHI(:,:) - REAL,ALLOCATABLE :: TPRCPI(:,:),SRFLAGI(:,:) - REAL,ALLOCATABLE :: F10MO(:,:),T2MO(:,:),Q2MO(:,:) - REAL,ALLOCATABLE :: UUSTARO(:,:),FFMMO(:,:),FFHHO(:,:) - REAL,ALLOCATABLE :: TPRCPO(:,:),SRFLAGO(:,:) - TYPE(SIGIO_HEAD) :: SIGHEADI,SIGHEADO - TYPE(SIGIO_DBTA) :: SIGDATAI - TYPE(SFCIO_HEAD) :: SFCHEADI - REAL,ALLOCATABLE :: SLMSKO(:,:) - REAL,ALLOCATABLE :: GEOLAT(:,:), GEOLON(:,:), TMPVAR(:,:) - REAL,ALLOCATABLE :: TMPLAT(:,:), TMPLON(:,:) - REAL :: FCSTHOUR, NSST_FHOUR - INTEGER :: IOLPL3,NLPL3,FILESZ - INTEGER,ALLOCATABLE :: LPL3(:) - REAL, ALLOCATABLE :: AK(:), BK(:), CK(:), VCOORD(:,:), & - VCOORDI(:,:), VCOORDO(:,:) - -! Define variables for NEMSIO - TYPE(NEMSIO_GFILE) :: GFILEI,GFILEISFC - TYPE(NEMSIO_HEAD) :: GFSHEADI - TYPE(NEMSIO_HEADV) :: GFSHEADVI - TYPE(NEMSIO_DBTA) :: GFSDATAI - TYPE(NEMSIO_DBTA) :: GFSDATAO - CHARACTER(8) :: FILETYPE, MODELNAME - CHARACTER(LEN=16) :: FILETYPE2 -! -! Define local vars: - INTEGER LONBO,LATBO,IDVCO,IDVMO,IDSLO,IDVTO, & - NVCOORDO,IDATE4O(4),LSOILO,IVSO, & - I_OZN,I_CLD, LSOILI, IVSI - CHARACTER(16),allocatable :: TRAC_NAME(:) - REAL(4) FHOURO - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! EXECUTION BEGINS -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RI = 0.0 - CPI = 0.0 - USE_UFO = .FALSE. - NST_ANL = .FALSE. - RDGRID = .FALSE. - NOPDPVV = .FALSE. - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ NAMELIST -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL W3TAGB('GLOBAL_CHGRES',1999,0253,0056,'NP23') - CALL GFUNCPHYS - READ(*,NAMCHG) - WRITE(6,NAMCHG) - - LATCH2 = LATCH + LATCH - - IF (REGIONAL == 1) THEN - PRINT*,"WILL CREATE GRIDS WITHOUT HALO." - PRINT*,"WILL CREATE ATMOSPHERIC BOUNDARY FILE." - ELSEIF (REGIONAL == 2) THEN - PRINT*,"WILL CREATE ATMOSPHERIC BOUNDARY FILE ONLY." - ELSE - HALO = 0 - ENDIF - - IF (REGIONAL > 0) THEN - IF (HALO == 0) THEN - PRINT *,'FATAL ERROR: MUST SPECIFIY NON-ZERO HALO.' - CALL ERREXIT(51) - ELSE - PRINT*,"USER SPECIFIED HALO IS: ", HALO, " ROWS/COLS." - ENDIF - ENDIF - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! OPEN INPUT ATMOSPHERIC FILE. DETERMINE FILE TYPE. -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NSIGI = 11 - NSIL = 13 - NLPL3 = 17 - NSIGO = 51 - INPTYP = 0 - - CALL NEMSIO_INIT(IRET) - - OPEN (NSIGI, FILE='chgres.inp.sig', ACCESS='DIRECT', RECL=16, IOSTAT=IRET) - READ (NSIGI, REC=1, IOSTAT=IRET1) FILETYPE2 - CLOSE (NSIGI) - - IF(IRET == 0 .AND. IRET1 == 0) THEN - IRET = INDEX(FILETYPE2, "NEMSIO") - IF (IRET /= 0) THEN - INPTYP = 1 - PRINT*,'INPUT ATMOS FILE chgres.inp.sig IS NEMSIO FORMAT' - ELSE - CALL SIGIO_SROPEN(NSIGI,'chgres.inp.sig',IRET) - CALL SIGIO_SRHEAD(NSIGI,SIGHEADI,IRET1) - IF(IRET == 0 .AND. IRET1 == 0) THEN - INPTYP = 2 - PRINT*,'INPUT ATMOS FILE chgres.inp.sig IS SIGIO FORMAT' - ENDIF - ENDIF - ENDIF - - IF(INPTYP /= 0) THEN - OPEN(NSIL,FILE='chgres.inp.siglevel', & - FORM='FORMATTED',STATUS='OLD',IOSTAT=IRET) - IF(IRET /= 0) NSIL = 0 - ELSE - PRINT*,'--- FAILED TO OPEN ATMOS FILE chgres.inp.sig ---' - PRINT*,'--- PROCEED TO CHANGE SFC FILE chgres.inp.sfc ---' - NSIGO = 0 - ENDIF - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! CHANGE RESOLUTION OF INPUT ATMOS SIGIO FILE. -! OUTPUT ATMOS FILE ON FV3 CUBED-SPHERE GRID WILL BE NETCDF FORMAT. -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(INPTYP == 2) THEN - - PRINT*, 'CHGRES INPUT: GFS SPECTRAL SIGIO SIGMA FILE ' - PRINT*, 'CHGRES OUTPUT: FV3 NETCDF FILE' - - IF (CPI(0) == 0.0) THEN - IF (MOD(SIGHEADI%IDVM/10,10) == 3) THEN - DO N=1,SIGHEADI%NTRAC+1 - CPI(N-1) = SIGHEADI%CPI(N) - RI(N-1) = SIGHEADI%RI(N) - ENDDO - ENDIF - ENDIF - - LEVSI = SIGHEADI%LEVS - LEVSO = LEVSI - IF(LEVS > 0) LEVSO = LEVS - LONBO = SIGHEADI%LONB - LATBO = SIGHEADI%LATB - IF(LONB > 0 .AND. LATB > 0) THEN - LONBO = LONB - LATBO = LATB - ENDIF - NTRACO = SIGHEADI%NTRAC - IF(NTRAC > 0) NTRACO = NTRAC - IF (IDVT == 200) THEN - NTRACO = MAX(SIGHEADI%NTRAC+2, NTRACO) - IF (NTRAC > 0 .AND. NTRACO > NTRAC) THEN - PRINT *,'FATAL ERROR: Incompatible values specified for NTRAC & IDVT' - CALL ERREXIT(13) - ENDIF - ENDIF - - ALLOCATE(TRAC_NAME(NTRACO)) - - CALL GET_TRACERS(IDVT, NTRACO, I_CLD, I_OZN, TRAC_NAME) - - IDVCO = SIGHEADI%IDVC - IDVMO = SIGHEADI%IDVM - IDSLO = SIGHEADI%IDSL - IDVTO = SIGHEADI%IDVT - NVCOORDO = SIGHEADI%NVCOORD - - IF (NVCOORDO >= 3 ) THEN - IF (SIGHEADI%VCOORD(1,NVCOORDO) < 0.0) THEN - SIGHEADI%VCOORD(:,NVCOORDO) = 0.0 - SIGHEADI%NVCOORD = 2 - ENDIF - ENDIF - - IF(IDVC > 0) IDVCO = IDVC - IF(IDVM >= 0) IDVMO = IDVM - IF(IDSL >= 0) IDSLO = IDSL - IF(IDVT > 0) IDVTO = IDVT - IF(IDVC == 1) NVCOORDO = 1 - IF(NVCOORD > 0) NVCOORDO = NVCOORD - - FHOURO = SIGHEADI%FHOUR - IDATE4O(1:4) = SIGHEADI%IDATE(1:4) - - IF(MQUICK == 1) THEN - PRINT*,'' - PRINT*,' MQUICK OPTION NOT AVAILABLE WHEN INPUT DATA IS' - PRINT*,' SPECTRAL GFS AND OUTPUT IS FV3 CUBE GRID.' - PRINT*,' IGNORING MQUICK SETTING.' - ENDIF - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GET NEW SIGMA LEVELS -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(NSIL /= 0) THEN - ALLOCATE(VCOORDO(LEVSO+1,NVCOORDO)) - CALL NEWSIG(NSIL,IDVCO,LEVSO,NVCOORDO,VCOORDO,IOSSIL) - IF(IOSSIL == 0) THEN - PRINT*,"NEW MODEL LEVELS READ IN" - ENDIF - ELSEIF(IDVCO == SIGHEADI%IDVC .AND. & - LEVSO == SIGHEADI%LEVS .AND. & - NVCOORDO == SIGHEADI%NVCOORD) THEN - ALLOCATE(VCOORDO(LEVSO+1,NVCOORDO)) - VCOORDO = SIGHEADI%VCOORD - IOSSIL = 0 - PRINT*,"NEW MODEL LEVELS COPIED FROM OLD" - ELSE - IOSSIL = 42 - ENDIF - IF(IOSSIL /= 0) THEN - PRINT*,'' - PRINT*,"FATAL ERROR DEFINING SIGMA VALUES." - PRINT*,"IOSSIL IS: ",IOSSIL - CALL ERREXIT(8) - ENDIF - - PRINT*,'' - PRINT*,"INPUT SIGMA FILE SPECS:" - PRINT*," WAVES: ",SIGHEADI%JCAP - PRINT*," LEVELS: ",SIGHEADI%LEVS - PRINT*," NTRAC: ",SIGHEADI%NTRAC - PRINT*," IVS: ",SIGHEADI%IVS - PRINT*," IDVC: ",SIGHEADI%IDVC - PRINT*," NVCOORD: ",SIGHEADI%NVCOORD - PRINT*," IDVM: ",SIGHEADI%IDVM - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ IN 2D LONSPERLAT -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ALLOCATE(LPL3(LATBO)) - LPL3 = LONBO ! full grid as default - LATG2 = 0 - IF(RDGRID) THEN - PRINT*,'' - PRINT*,"READ LPL FROM UNIT ",NLPL3 - OPEN(NLPL3,FILE='chgres.inp.lpl3', & - FORM='FORMATTED',STATUS='OLD',IOSTAT=IOLPL3) - IF(IOLPL3 == 0) THEN - READ(NLPL3,*,IOSTAT=IOLPL3) LATG2,LPL3(1:MIN(LATG2,(LATBO+1)/2)) - PRINT *,'LPL3 READ: EXPECTED ',(LATBO+1)/2,', READ ',LATG2 - IF(IOLPL3 == 0 .AND. LATG2 == (LATBO+1)/2) THEN - DO J=1,LATBO/2 - LPL3(LATBO+1-J) = LPL3(J) - ENDDO - PRINT*,"LPL3 READ IN" - ENDIF - ELSE - PRINT*,"WARNING: BAD READ OF LONSPERLAT FILE. USE FULL GRID." - ENDIF - ENDIF - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ OLD SIGMA FILE -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SIGIO_ALDBTA(SIGHEADI,SIGDATAI,IRET) - IF(IRET /= 0) THEN - PRINT*,'FATAL ERROR ALLOCATING SIGDATAI. IRET: ',IRET - CALL ERREXIT(4) - ENDIF - CALL SIGIO_SRDBTA(NSIGI,SIGHEADI,SIGDATAI,IRET) - IF(IRET /= 0) THEN - PRINT *,'FATAL ERROR READING FILE NSIGI=',NSIGI - CALL ERREXIT(94) - ENDIF - - NCI = SIZE(SIGDATAI%T,1) - IJX = LONBO*LATCH2 - NTRACM = MIN(SIGHEADI%NTRAC,NTRACO) - IF (IDVT == 200) NTRACO = MIN(SIGHEADI%NTRAC,NTRACO) + 2 - - CALL NEMSIO_GFS_ALGRD(LONBO,LATBO,LEVSO,NTRACO,GFSDATAO,NOPDPVV) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! USE TRANSFORMS TO CHANGE RESOLUTION -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - PRINT*,'' - IF (IDRT == 4) THEN - PRINT*,"TRANSFORM TO A GAUSSIAN GRID OF:" - ELSEIF (IDRT == 0) THEN - PRINT*,"TRANSFORM TO A LAT/ON GRID OF:" - ENDIF - PRINT*," I/J DIMS: ",LONBO,LATBO - PRINT*," LEVELS: ",LEVSO - PRINT*," NTRAC: ",NTRACO - PRINT*," IDVC: ",IDVCO - PRINT*," NVCOORD: ",NVCOORDO - PRINT*," IDVM: ",IDVMO - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! ALLOCATE TEMPORARY SIGIO DATA -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ALLOCATE(SLAT(LATBO), WLAT(LATBO), CLAT(LATBO), RLAT(LATBO)) - ALLOCATE(ZSI(LONBO,LATCH2), PSI(LONBO,LATCH2)) - ALLOCATE(PI(LONBO,LATCH2,LEVSI)) - ALLOCATE(TI(LONBO,LATCH2,LEVSI)) - ALLOCATE(UI(LONBO,LATCH2,LEVSI)) - ALLOCATE(VI(LONBO,LATCH2,LEVSI)) - ALLOCATE(QI(LONBO,LATCH2,LEVSI,NTRACM)) - IF (THERMODYN_ID_I == 3) THEN - ALLOCATE(SUMQ(LONBO,LATCH2,LEVSI)) - ALLOCATE(XCP (LONBO,LATCH2,LEVSI)) - ELSE - ALLOCATE(VIRT(LONBO,LATCH2,LEVSI)) - ENDIF - ALLOCATE(WI(LONBO,LATCH2,LEVSI)) - ALLOCATE(ZSO(LONBO,LATCH2), PSO(LONBO,LATCH2)) - ALLOCATE(PO(LONBO,LATCH2,LEVSO)) - ALLOCATE(TO(LONBO,LATCH2,LEVSO)) - ALLOCATE(UO(LONBO,LATCH2,LEVSO)) - ALLOCATE(VO(LONBO,LATCH2,LEVSO)) - ALLOCATE(WO(LONBO,LATCH2,LEVSO)) - ALLOCATE(QO(LONBO,LATCH2,LEVSO,NTRACO)) - ALLOCATE(TPO(LONBO,LEVSO)) - ALLOCATE(DPO(LONBO,LATCH2,LEVSO)) - ALLOCATE(DTDPO(LONBO,LATCH2,LEVSO)) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GET NEW LATITUDES -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPLAT(IDRT,LATBO,SLAT,WLAT) -!$omp parallel do private(j) - DO J=1,LATBO - CLAT(J) = SQRT(1-SLAT(J)*SLAT(J)) - RLAT(J) = PIFAC * ASIN(SLAT(J)) - ENDDO - DEALLOCATE(SLAT, CLAT, WLAT) -! -! ------------------------------------------------------------------ -! GET PS and T DATA TYPE FOR THE FILE - - SFCPRESS_ID_I = MOD(SIGHEADI%IDVM,10) - THERMODYN_ID_I = MOD(SIGHEADI%IDVM/10,10) - SFCPRESS_ID_O = MOD(IDVMO,10) - THERMODYN_ID_O = MOD(IDVMO/10,10) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! LOOP OVER LATITUDE -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LATLOOP1 : DO J1=1,(LATBO+1)/2,LATCH - - J2 = MIN(J1+LATCH-1,(LATBO+1)/2) - JL = 2*(J2-J1+1) - IJL = LONBO*JL - CALL TRSSC(SIGHEADI%JCAP,NCI,SIGHEADI%LEVS,NTRACM, & - SIGHEADI%IDVM,IDRT,LONBO,LATBO,IJX,J1,J2,1, & - LPL3(J1:J2), & - SIGDATAI%HS,SIGDATAI%PS,SIGDATAI%T, & - SIGDATAI%D,SIGDATAI%Z,SIGDATAI%Q, & - ZSI,PSI,TI,UI,VI,QI) - - IF (THERMODYN_ID_I == 3) THEN - XCP(:,1:JL,:) = 0.0 - SUMQ(:,1:JL,:) = 0.0 - DO N=1,NTRACM - IF( CPI(N) .NE. 0.0 .AND. RI(N) .NE. 0.0) THEN - XCP(:,1:JL,:) = XCP(:,1:JL,:) + CPI(N)*QI(:,1:JL,:,N) - SUMQ(:,1:JL,:) = SUMQ(:,1:JL,:) + QI(:,1:JL,:,N) - ENDIF - ENDDO - XCP(:,1:JL,:) = (1.-SUMQ(:,1:JL,:))*CPI(0)+XCP(:,1:JL,:) - ELSE - VIRT(:,1:JL,:) = (1.+(461.50/287.05-1)*QI(:,1:JL,:,1)) - ENDIF - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! CONVERT TO SURFACE PRESSURE AND TEMPERATURE -! - SELECT CASE(SFCPRESS_ID_I) - CASE(0,1) - PSI(:,1:JL) = 1.E3*EXP(PSI(:,1:JL)) - CASE(2) - PSI(:,1:JL) = 1.E3*PSI(:,1:JL) - CASE DEFAULT - PRINT *,' DEFAULT SELECTED: PSI IS P IN PASCAL ' - END SELECT - - DO I=1,LONBO ! not using external gaussian terrain - ZSO(I,1:JL) = ZSI(I,1:JL) - ENDDO - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE NEW PRESSURE AND NEW SURFACE PRESSURE AND OMEGA -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF (THERMODYN_ID_I == 3) THEN - TI(:,1:JL,:) = TI(:,1:JL,:)/CPI(0) ! enthalpy (CpT/Cpd) - ENDIF - - ALLOCATE(VCOORD(SIGHEADI%LEVS+1,SIGHEADI%NVCOORD)) - VCOORD = SIGHEADI%VCOORD - - CALL GETOMEGA(SIGHEADI%JCAP,NCI,SIGHEADI%LEVS, & - SIGHEADI%IDVC,SIGHEADI%IDVM,IDRT, & - SIGHEADI%IDSL,SIGHEADI%NVCOORD,VCOORD, & - LONBO,LATBO,IJL,IJX,J1,J2,1,SIGDATAI%D, & - SIGDATAI%PS,PSI,TI,UI,VI,WI) - - CALL SIGIO_MODPRD(IJL,IJX,SIGHEADI%LEVS,SIGHEADI%NVCOORD, & - SIGHEADI%IDVC,SIGHEADI%IDSL,VCOORD,IRET, & - PS=PSI,T=TI,PM=PI) - - DEALLOCATE (VCOORD) -! - SELECT CASE( THERMODYN_ID_I ) - CASE(0,1) - TI(:,1:JL,:) = TI(:,1:JL,:)/VIRT(:,1:JL,:) ! to t - CASE(2) - CASE(3) - TI(:,1:JL,:) = TI(:,1:JL,:)/XCP(:,1:JL,:)*CPI(0) ! to t - CASE DEFAULT - END SELECT - - PSO = PSI -! -! VERTICALLY INTERPOLATE UPPER-AIR FIELDS - HENRY JUANG'S APPROACH -! - CALL NEWPR1(IJL,IJX,LEVSO,SIGHEADI%LEVS,IDVCO,IDVMO,IDSLO, & - NVCOORDO, VCOORDO,RI, CPI, NTRACM, & - PI,TI,QI,PSO,PO) - - CALL VINTG(IJL,IJX,SIGHEADI%LEVS,LEVSO,NTRACM, & - PI,UI,VI,TI,QI,WI,PO,UO,VO,TO,QO,WO) - -! idea add init condition for temp tracer4-5 ( o o2) - IF (IDVT == 200) then - CALL VINTG_IDEA(LONBO,LATCH,LEVSO,NTRACO,PO,RLAT, & - LATBO,J1,J2,SIGHEADI%IDATE,UO,VO,TO,QO) - ENDIF -! - IF( IDVCO == 3 ) THEN - ALLOCATE(AK(LEVSO+1), BK(LEVSO+1), CK(LEVSO+1)) - DO K=1,LEVSO+1 - AK(K) = VCOORDO(K,1) - BK(K) = VCOORDO(K,2) - CK(K) = VCOORDO(K,3) - ENDDO - CALL CHECKDP(IJL,IJX,LEVSO,AK,BK,CK,PSO,TO,QO) - DEALLOCATE (AK, BK, CK) - ENDIF - -!----force tracers to be positvie - IF (CHGQ0 == 1) QO = MAX(QO, 0.0) - - DO J=J1,J2 - JN = J - JS = LATBO+1-J - DO I=1,LONBO - GFSDATAO%ZS(I,JN) = ZSO(I,2*(J-J1)+1) - GFSDATAO%ZS(I,JS) = ZSO(I,2*(J-J1)+2) - GFSDATAO%PS(I,JN) = PSO(I,2*(J-J1)+1) - GFSDATAO%PS(I,JS) = PSO(I,2*(J-J1)+2) - ENDDO - IF (NOPDPVV) THEN - DO K=1,LEVSO - DO I=1,LONBO - GFSDATAO%T(I,JN,K) = TO(I,2*(J-J1)+1,K) - GFSDATAO%T(I,JS,K) = TO(I,2*(J-J1)+2,K) - GFSDATAO%U(I,JN,K) = UO(I,2*(J-J1)+1,K) - GFSDATAO%U(I,JS,K) = UO(I,2*(J-J1)+2,K) - GFSDATAO%V(I,JN,K) = VO(I,2*(J-J1)+1,K) - GFSDATAO%V(I,JS,K) = VO(I,2*(J-J1)+2,K) - ENDDO - ENDDO - ELSE - DO K=1,LEVSO - DO I=1,LONBO - GFSDATAO%DP(I,JN,K) = DPO(I,2*(J-J1)+1,K) - GFSDATAO%DP(I,JS,K) = DPO(I,2*(J-J1)+2,K) - GFSDATAO%P(I,JN,K) = PO(I,2*(J-J1)+1,K) - GFSDATAO%P(I,JS,K) = PO(I,2*(J-J1)+2,K) - GFSDATAO%T(I,JN,K) = TO(I,2*(J-J1)+1,K) - GFSDATAO%T(I,JS,K) = TO(I,2*(J-J1)+2,K) - GFSDATAO%U(I,JN,K) = UO(I,2*(J-J1)+1,K) - GFSDATAO%U(I,JS,K) = UO(I,2*(J-J1)+2,K) - GFSDATAO%V(I,JN,K) = VO(I,2*(J-J1)+1,K) - GFSDATAO%V(I,JS,K) = VO(I,2*(J-J1)+2,K) - GFSDATAO%W(I,JN,K) = WO(I,2*(J-J1)+1,K) - GFSDATAO%W(I,JS,K) = WO(I,2*(J-J1)+2,K) - ENDDO - ENDDO - ENDIF - - DO N=1,NTRACM - DO K=1,LEVSO - DO I=1,LONBO - GFSDATAO%Q(I,JN,K,N) = QO(I,2*(J-J1)+1,K,N) - GFSDATAO%Q(I,JS,K,N) = QO(I,2*(J-J1)+2,K,N) - ENDDO - ENDDO - ENDDO - ENDDO - - ENDDO LATLOOP1 - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! DEALLOCATE TEMPORARY DATA -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DEALLOCATE(ZSI, PSI, PI, TI, UI, VI, WI, QI) - DEALLOCATE(ZSO, PSO, PO, TO, UO, VO, WO, QO) - DEALLOCATE(TPO, DTDPO, DPO) - DEALLOCATE(LPL3, RLAT) - IF (ALLOCATED(SUMQ)) DEALLOCATE(SUMQ) - IF (ALLOCATED(XCP)) DEALLOCATE(XCP) - IF (ALLOCATED(VIRT)) DEALLOCATE(VIRT) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GENERATE SPECIAL SETS OF TRACERS - IF(SIGHEADO%IDVT > 0 .AND. MOD(SIGHEADO%IDVT,100) == 0) THEN - PRINT*,'FATAL ERROR: USE OF SPECIAL TRACER SETS NOT YET IMPLEMENTED' - PRINT*,'FOR FV3. STOP.' - CALL ERREXIT(11) -!fv3 The specsets routine passes back tracers in spectral space. Routine -!fv3 should be modified to pass back tracers on gaussian or fv3 grid. -!fv3 CALL SPECSETS(SIGHEADO,SIGDATAO,IDRT) - ENDIF - - CALL SIGIO_AXDBTA(SIGDATAI,IRET) - - CALL SIGIO_SCLOSE(NSIGI,IRET) - - IF (REGIONAL < 2) THEN - CALL WRITE_FV3_ATMS_NETCDF(GFSDATAO%ZS,GFSDATAO%PS,GFSDATAO%T,GFSDATAO%W, & - GFSDATAO%U,GFSDATAO%V,GFSDATAO%Q,VCOORDO, & - LONB,LATB,LEVSO,NTRACO,NVCOORDO,NTILES,HALO,INPTYP,MODELNAME) - ENDIF - - IF (REGIONAL >= 1) THEN - CALL WRITE_FV3_ATMS_BNDY_NETCDF(GFSDATAO%ZS,GFSDATAO%PS,GFSDATAO%T, & - GFSDATAO%W,GFSDATAO%U,GFSDATAO%V,GFSDATAO%Q,VCOORDO, & - LONBO,LATBO,LEVSO,NTRACM,NVCOORDO,HALO,INPTYP,MODELNAME) - ENDIF - - CALL NEMSIO_GFS_AXGRD(GFSDATAO) - - DEALLOCATE (VCOORDO) - DEALLOCATE (TRAC_NAME) - -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -! CHANGE RESOLUTION OF INPUT NEMSIO GRID FILE -! OUTPUT ATMOS FILE ON FV3 CUBED-SPHERE GRID WILL BE NETCDF FORMAT. -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - ELSEIF(INPTYP == 1) THEN - - PRINT*, 'CHGRES INPUT: GAUSSIAN NEMSIO FILE' - PRINT*, 'CHGRES OUTPUT: FV3 NETCDF FILE' - - CALL NEMSIO_OPEN(GFILEI,'chgres.inp.sig','read',IRET=IRET) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! OPEN (READ) NEMSIO GRID FILE HEADERS - CALL NEMSIO_GETFILEHEAD(GFILEI, IDATE=GFSHEADI%IDATE, & - NFHOUR=GFSHEADI%NFHOUR, & - NFMINUTE=GFSHEADI%NFMINUTE, & - NFSECONDN=GFSHEADI%NFSECONDN, & - NFSECONDD=GFSHEADI%NFSECONDD, & - VERSION=GFSHEADI%VERSION, & - MODELNAME=MODELNAME, & - NREC=GFSHEADI%NREC, & - DIMX=GFSHEADI%DIMX, & - DIMY=GFSHEADI%DIMY, & - DIMZ=GFSHEADI%DIMZ, & - JCAP=GFSHEADI%JCAP, & - NTRAC=GFSHEADI%NTRAC, & - NCLDT=GFSHEADI%NCLDT, & - NSOIL=GFSHEADI%NSOIL, & - IDSL=GFSHEADI%IDSL, & - IDVC=GFSHEADI%IDVC, & - IDVM=GFSHEADI%IDVM, & - IDRT=GFSHEADI%IDRT, IRET=IRET0) - - CALL NEMSIO_GETHEADVAR(GFILEI,'FHOUR', GFSHEADI%FHOUR,IRET=IRET) - - IF(IRET/=0) GFSHEADI%FHOUR = REAL(GFSHEADI%NFHOUR,8) + & - REAL(GFSHEADI%NFMINUTE,8)/60. + & - REAL(GFSHEADI%NFSECONDN,8)/(3600.*GFSHEADI%NFSECONDD) - - CALL NEMSIO_GETHEADVAR(GFILEI,'DIMY', GFSHEADI%LATB,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'DIMX', GFSHEADI%LONB,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'LEVS', GFSHEADI%LEVS,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'ITRUN', GFSHEADI%ITRUN,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'IORDER', GFSHEADI%IORDER,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'IREALF', GFSHEADI%IREALF, IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'ICEN2', GFSHEADI%ICEN2,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'IDVT', GFSHEADI%IDVT,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'PDRYINI', GFSHEADI%PDRYINI,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'IVS', GFSHEADI%IVSSIG,IRET=IRET) - CALL NEMSIO_GETHEADVAR(GFILEI,'NVCOORD', GFSHEADI%NVCOORD,IRET=IRET) - - PRINT*,'' - PRINT*,"INPUT NEMSIO FILE SPECS:" - WRITE(6,155) GFSHEADI%IDATE - 155 FORMAT(" DATE: ",7(I6)) - PRINT*," FHOUR: ",GFSHEADI%FHOUR - PRINT*," VERSION: ",GFSHEADI%VERSION - PRINT*," NREC: ",GFSHEADI%NREC - PRINT*," JCAP: ",GFSHEADI%JCAP - PRINT*," NTRAC: ",GFSHEADI%NTRAC - PRINT*," NCLDT: ",GFSHEADI%NCLDT -! note: in some fv3gfs files, the number of tracers (ntrac) is 8. That -! number includes cloud cover, which is not processed by chgres. So -! don't use ntrac. Instead compute it from the number of cloud species -! (ncldt) plus 2 (o3 and specific hum). - IF(TRIM(MODELNAME) == "FV3GFS") THEN - GFSHEADI%NTRAC = GFSHEADI%NCLDT + 2 - ENDIF - PRINT*," IDSL: ",GFSHEADI%IDSL - PRINT*," IDVC: ",GFSHEADI%IDVC - PRINT*," IDVM: ",GFSHEADI%IDVM - PRINT*," IDRT: ",GFSHEADI%IDRT - PRINT*," LONB: ",GFSHEADI%LONB - PRINT*," LATB: ",GFSHEADI%LATB - PRINT*," LEVS: ",GFSHEADI%LEVS - PRINT*," ITRUN: ",GFSHEADI%ITRUN - PRINT*," IORDER: ",GFSHEADI%IORDER - PRINT*," IREALF: ",GFSHEADI%IREALF - PRINT*," ICEN2: ",GFSHEADI%ICEN2 - PRINT*," IDVT: ",GFSHEADI%IDVT - PRINT*," PDRYINI: ",GFSHEADI%PDRYINI - PRINT*," IVSSIG: ",GFSHEADI%IVSSIG - PRINT*," NVCOORD: ",GFSHEADI%NVCOORD - - LEVSI = GFSHEADI%DIMZ - LONB = GFSHEADI%DIMX - LATB = GFSHEADI%DIMY - - ALLOCATE(GFSHEADVI%VCOORD(LEVSI+1,3,2)) - ALLOCATE(GFSHEADVI%CPI(GFSHEADI%NTRAC+1)) - ALLOCATE(GFSHEADVI%RI(GFSHEADI%NTRAC+1)) - - IF(TRIM(MODELNAME) == 'FV3GFS') THEN - CALL NEMSIO_GETFILEHEAD(GFILEI, VCOORD=GFSHEADVI%VCOORD, & - IRET=IRET1) - GFSHEADVI%CPI = -999. - GFSHEADVI%RI = -999. - NOPDPVV = .FALSE. - ELSE - CALL NEMSIO_GETFILEHEAD(GFILEI, VCOORD=GFSHEADVI%VCOORD, & - CPI=GFSHEADVI%CPI, RI=GFSHEADVI%RI, & - IRET=IRET1) - ENDIF - - IF(IRET1.NE.0 ) THEN - PRINT*, 'FATAL ERROR READNG NEMSIO FILE HEADER. IRET: ', IRET1 - CALL ERREXIT(25) - ENDIF - - IF (GFSHEADI%NVCOORD == -9999) THEN - GFSHEADI%NVCOORD = 3 - IF (MAXVAL(GFSHEADVI%VCOORD(:,3,1)) == 0. .AND. & - MINVAL(GFSHEADVI%VCOORD(:,3,1)) == 0. ) THEN - GFSHEADI%NVCOORD = 2 -! jw for hyb: when no idsl is set - IF (GFSHEADI%IDSL == -9999)GFSHEADI%IDSL = 1 - IF (MAXVAL(GFSHEADVI%VCOORD(:,2,1)) == 0. .AND. & - MINVAL(GFSHEADVI%VCOORD(:,2,1)) ==0.) THEN - GFSHEADI%NVCOORD = 1 - ENDIF - ENDIF - ENDIF - - ALLOCATE(VCOORDI(LEVSI+1,GFSHEADI%NVCOORD)) - VCOORDI(:,:) = GFSHEADVI%VCOORD(:,1:GFSHEADI%NVCOORD,1) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ INPUT NEMSIO DATA ARRAY - - ALLOCATE(GFSDATAI%ZS(LONB,LATB)) - ALLOCATE(GFSDATAI%PS(LONB,LATB)) - ALLOCATE(GFSDATAI%T(LONB,LATB,LEVSI)) - ALLOCATE(GFSDATAI%U(LONB,LATB,LEVSI)) - ALLOCATE(GFSDATAI%V(LONB,LATB,LEVSI)) - ALLOCATE(GFSDATAI%Q(LONB,LATB,LEVSI,GFSHEADI%NTRAC)) - IF (.NOT. NOPDPVV) THEN - ALLOCATE(GFSDATAI%P(LONB,LATB,LEVSI)) - ALLOCATE(GFSDATAI%DP(LONB,LATB,LEVSI)) - ALLOCATE(GFSDATAI%W(LONB,LATB,LEVSI)) - ENDIF - - IF(TRIM(MODELNAME) == "FV3GFS") THEN - CALL READ_FV3GFS_ATMS_DATA_NEMSIO(GFILEI, GFSDATAI, GFSHEADI, & - VCOORDI, (LEVSI+1), GFSHEADI%NVCOORD) - deallocate(gfsdatai%dp) - ELSE - CALL NEMSIO_GFS_RDGRD(GFILEI,GFSDATAI,IRET=IRET) - ENDIF - - CALL NEMSIO_CLOSE(GFILEI,IRET=IRET) - - IF (LEVS > 0) THEN - LEVSO = LEVS - ELSE - LEVSO = LEVSI - ENDIF - - IF (NTRAC > 0) THEN - NTRACO = NTRAC - ELSE - NTRACO = GFSHEADI%NTRAC - ENDIF - - IF(IDVT > 0)THEN - IDVTO = IDVT - ELSE - IDVTO = GFSHEADI%IDVT - ENDIF - -! IF (NTRACO == 3 .AND. IDVTO == 21) THEN -! PRINT*,'INPUT FILE TRACERS: SPFH, O3MR, CLWMR' -! ELSE -! PRINT*,'- FATAL ERROR: CHGRES ASSUMES NTRACO=3 AND IDVT=21' -! PRINT*,'- INPUT FILE VALUES ARE ',NTRACO,IDVT -! PRINT*,'- STOP.' -! CALL ERREXIT(27) -! ENDIF - - IF(IDVC > 0) THEN - IDVCO = IDVC - ELSE - IDVCO = GFSHEADI%IDVC - ENDIF - - IF(IDVM > 0) THEN - IDVMO = IDVM - ELSE - IDVMO = GFSHEADI%IDVM - ENDIF - - IF(IDSL > 0) THEN - IDSLO = IDSL - ELSE - IDSLO = GFSHEADI%IDSL - ENDIF - - IF(NVCOORD > 0) THEN - NVCOORDO = NVCOORD - ELSE - NVCOORDO = GFSHEADI%NVCOORD - ENDIF - - IF(MQUICK == 1) THEN - IF(LEVSO.NE.LEVSI) CALL ERREXIT(28) - ENDIF - -! GET NEW SIGMA LEVELS - - IF(NSIL /= 0) THEN - ALLOCATE(VCOORDO(LEVSO+1,NVCOORDO)) - CALL NEWSIG(NSIL, IDVCO, LEVSO, NVCOORDO, VCOORDO, IOSSIL) - IF(IOSSIL == 0) THEN - PRINT '(" NEW MODEL LEVELS READ IN")' - ENDIF - ELSEIF(IDVCO == GFSHEADI%IDVC .AND. & - LEVSO == LEVSI .AND. & - NVCOORDO == GFSHEADI%NVCOORD) THEN - ALLOCATE(VCOORDO(LEVSO+1,NVCOORDO)) - VCOORDO(:,:) = GFSHEADVI%VCOORD(:,1:NVCOORDO,1) - IOSSIL = 0 - PRINT '(" NEW MODEL LEVELS COPIED FROM OLD")' - ELSE - IOSSIL=42 - ENDIF - - IF(IOSSIL.NE.0) THEN - PRINT*,"FATAL ERROR DEFINING SIGMA VALUES. IOSSIL: ", IOSSIL - CALL ERREXIT(81) - ENDIF - - PRINT*,'' - PRINT*,"TRANSFORM TO A CUBED-SPHERE GRID OF:" - PRINT*," LEVELS: ",LEVSO - PRINT*," NTRAC: ",NTRACO - PRINT*," IDVC: ",IDVCO - PRINT*," NVCOORD: ",NVCOORDO - - IF (NOPDPVV) THEN - NREC = 2 + LEVSO*(3+NTRACO) !zs,ps,t,u,v,q(ntracer) - ELSE - NREC = 2 + LEVSO*(6+NTRACO) !zs,ps,p,dp,t,u,v,q(ntracer),vvel - ENDIF - - IF (NTRACO == GFSHEADI%NTRAC) THEN - CPI(0:NTRACO) = GFSHEADVI%CPI(1:NTRACO+1) - RI(0:NTRACO) = GFSHEADVI%RI(1:NTRACO+1) - ELSEIF (IDVC == 2) THEN - CPI(0:NTRACO) = -999. - RI(0:NTRACO) = -999. - ELSE - PRINT *,'FATAL ERROR: You have different Tracers from input,', & - ' make sure to provide CPI & RI, for generalized coordinate.' - PRINT*,' Stop program.' - CALL ERREXIT(24) - ENDIF - - MQUICKNEMS : IF (MQUICK == 0) THEN - - ALLOCATE(ZSI(LONB,LATCH2), PSI(LONB,LATCH2)) - ALLOCATE(TI(LONB,LATCH2,LEVSI), TIV(LONB,LATCH2,LEVSI), & - UI(LONB,LATCH2,LEVSI), VI(LONB,LATCH2,LEVSI), & - PI(LONB,LATCH2,LEVSI), WI(LONB,LATCH2,LEVSI), & - QI(LONB,LATCH2,LEVSI,NTRACO)) - - ALLOCATE(GFSDATAO%ZS(LONB,LATB)) - ALLOCATE(GFSDATAO%PS(LONB,LATB)) - ALLOCATE(GFSDATAO%T(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%U(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%V(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%Q(LONB,LATB,LEVSO,NTRACO)) - - IF (.NOT. NOPDPVV) THEN - ALLOCATE(PO(LONB,LATCH2,LEVSO)) - ALLOCATE(GFSDATAO%W(LONB,LATB,LEVSO)) - ELSE - ALLOCATE(PO(LONB,LATCH2,LEVSO)) - ALLOCATE(WO(LONB,LATCH2,LEVSO)) - ENDIF - - LATLOOP : DO J1=1,LATB,LATCH2 - - J2 = MIN(J1+LATCH2-1, LATB) - JL = J2-J1+1 - IJL = LONB*JL - IJX = LONB*JL - - ZSI(:,:) = GFSDATAI%ZS(:,J1:J2) - PSI(:,:) = GFSDATAI%PS(:,J1:J2) - - TI(:,:,:) = GFSDATAI%T(:,J1:J2,:) - UI(:,:,:) = GFSDATAI%U(:,J1:J2,:) - VI(:,:,:) = GFSDATAI%V(:,J1:J2,:) - - DO N=1,NTRACO - QI(:,:,:,N) = GFSDATAI%Q(:,J1:J2,:,N) - ENDDO - - TIV = TI*(1.+(461.50/287.05-1)*QI(:,:,:,1)) ! virtual temperature - - IF (.NOT. NOPDPVV) THEN - PI(:,:,:) = GFSDATAI%P(:,J1:J2,:) - ELSE - CALL SIGIO_MODPRD(IJL,IJX,LEVSI,GFSHEADI%NVCOORD, & - GFSHEADI%IDVC,GFSHEADI%IDSL,VCOORDI,IRET, & - PS=PSI,T=TIV,PM=PI) - ENDIF - - IF ( NREC == GFSHEADI%NREC .AND. .NOT. NOPDPVV ) THEN - WI(:,:,:) = GFSDATAI%W(:,J1:J2,:) - ELSEIF (TRIM(MODELNAME) == "FV3GFS" .AND. .NOT. NOPDPVV ) THEN - WI(:,:,:) = GFSDATAI%W(:,J1:J2,:) - ELSE - WI = 0. - ENDIF - - GFSDATAO%ZS(:,J1:J2) = ZSI - GFSDATAO%PS(:,J1:J2) = PSI - -!----------------------------------------------------------------------- -! VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! -- Henry Juang's approach - - IF (NOPDPVV) THEN - CALL NEWPR1(IJL, IJX, LEVSO, LEVSI, IDVCO, IDVMO, IDSLO, & - NVCOORDO, VCOORDO, RI, CPI, NTRACO, & - PI, TI, QI, GFSDATAO%PS(:,J1:J2), PO) - - CALL VINTG(IJL,IJX,LEVSI,LEVSO,NTRACO,PI,UI,VI,TI,QI,WI, & - PO, GFSDATAO%U(:,J1:J2,:), GFSDATAO%V(:,J1:J2,:), & - GFSDATAO%T(:,J1:J2,:), GFSDATAO%Q(:,J1:J2,:,:), WO) - - ELSE - CALL NEWPR1(IJL, IJX, LEVSO, LEVSI, IDVCO, IDVMO, IDSLO, & - NVCOORDO, VCOORDO, RI, CPI, NTRACO, PI, TI, QI, & - GFSDATAO%PS(:,J1:J2), PO) - - CALL VINTG(IJL,IJX,LEVSI,LEVSO,NTRACO,PI,UI,VI,TI,QI,WI, & - PO, GFSDATAO%U(:,J1:J2,:), & - GFSDATAO%V(:,J1:J2,:),GFSDATAO%T(:,J1:J2,:), & - GFSDATAO%Q(:,J1:J2,:,:), & - GFSDATAO%W(:,J1:J2,:)) - ENDIF - - IF (IDVCO == 3) THEN - ALLOCATE(AK(LEVSO+1), BK(LEVSO+1), CK(LEVSO+1)) - - AK = VCOORDO(1:(LEVSO+1),1) - BK = VCOORDO(1:(LEVSO+1),2) - CK = VCOORDO(1:(LEVSO+1),3) - - CALL CHECKDP(IJL,IJX,LEVSO,AK,BK,CK,GFSDATAO%PS(:,J1:J2), & - GFSDATAO%T(:,J1:J2,:),GFSDATAO%Q(:,J1:J2,:,:)) - - DEALLOCATE(AK,BK,CK) - ENDIF - - ENDDO LATLOOP - - DEALLOCATE(ZSI, PSI, PI, TI, TIV, UI, VI, WI, QI) - - IF (ALLOCATED(PO)) DEALLOCATE(PO) - IF (ALLOCATED(WO)) DEALLOCATE(WO) - - ELSE ! MQUICK /= 0 - - ALLOCATE(GFSDATAO%ZS(LONB,LATB)) - ALLOCATE(GFSDATAO%PS(LONB,LATB)) - ALLOCATE(GFSDATAO%T(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%U(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%V(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%Q(LONB,LATB,LEVSO,NTRACO)) - - GFSDATAO%ZS = GFSDATAI%ZS - GFSDATAO%PS = GFSDATAI%PS - GFSDATAO%U = GFSDATAI%U - GFSDATAO%V = GFSDATAI%V - GFSDATAO%T = GFSDATAI%T - GFSDATAO%Q = GFSDATAI%Q - - IF (.NOT. NOPDPVV) THEN - ALLOCATE(GFSDATAO%W(LONB,LATB,LEVSO)) - ALLOCATE(GFSDATAO%P(LONB,LATB,LEVSO)) - GFSDATAO%P = GFSDATAI%P - IF(NREC == GFSHEADI%NREC) THEN - GFSDATAO%W = GFSDATAI%W - ELSE - GFSDATAO%W = 0. - ENDIF - ENDIF - - ENDIF MQUICKNEMS - - DEALLOCATE(VCOORDI) - - CALL NEMSIO_GFS_AXHEADV(GFSHEADVI) - - CALL NEMSIO_GFS_AXGRD(GFSDATAI) - - IF (.NOT. ALLOCATED(GFSDATAO%W)) THEN - ALLOCATE(GFSDATAO%W(LONB,LATB,LEVSO)) - GFSDATAO%W = 0.0 - END IF - - IF (REGIONAL < 2) THEN - CALL WRITE_FV3_ATMS_NETCDF(GFSDATAO%ZS,GFSDATAO%PS,GFSDATAO%T,GFSDATAO%W, & - GFSDATAO%U,GFSDATAO%V,GFSDATAO%Q,VCOORDO, & - LONB,LATB,LEVSO,NTRACO,NVCOORDO,NTILES,HALO,INPTYP,MODELNAME) - ENDIF - - IF (REGIONAL >=1) THEN - CALL WRITE_FV3_ATMS_BNDY_NETCDF(GFSDATAO%ZS,GFSDATAO%PS,GFSDATAO%T, & - GFSDATAO%W,GFSDATAO%U,GFSDATAO%V,GFSDATAO%Q,VCOORDO, & - LONB,LATB,LEVSO,NTRACO,NVCOORDO,HALO,INPTYP,MODELNAME) - ENDIF - - DEALLOCATE(VCOORDO) - - CALL NEMSIO_GFS_AXGRD(GFSDATAO) - -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - ENDIF !!!END OF INPTYP OPTIONS FOR ATMOS FILE -! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - -! --------------------------------------------------------------------- -! CLOSE FILES - IF(INPTYP /= 0) THEN - IF(NSIL > 0) CLOSE(NSIL) - ENDIF - -! --------------------------------------------------------------------- -! END OF CHANGE RESOLUTION FOR ATMOSPHERIC FIELDS. -! --------------------------------------------------------------------- - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! OPEN SURFACE FILES -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NSFCI = 21 - NSFCO = 61 - CALL SFCIO_SROPEN(NSFCI,'chgres.inp.sfc',IRET) - CALL SFCIO_SRHEAD(NSFCI,SFCHEADI,IRET1) - IF(IRET == 0 .AND. IRET1 == 0) THEN - INPTYP = 2 - CALL SFCIO_SCLOSE(NSFCI, IRET) - ELSE - CALL NEMSIO_OPEN(GFILEISFC,'chgres.inp.sfc','read',IRET=IRET) - CALL NEMSIO_GETFILEHEAD(GFILEISFC,GTYPE=FILETYPE, & - MODELNAME=MODELNAME,IRET=IRET) - PRINT *,'OPEN chgres.inp.sfc,iret=',IRET, 'gtype=',FILETYPE, & - 'modelname= ',modelname - IF (TRIM(FILETYPE) == 'NEMSIO' .AND. IRET == 0) THEN - INPTYP = 1 - CALL NEMSIO_CLOSE(GFILEISFC, IRET=IRET) - ELSE - INPTYP = 0 - NSFCO = 0 - ENDIF - ENDIF - - IF (NSFCO == 0) GOTO 80 - -! FV3GFS SURFACE FILES CONTAIN BOTH SFC AND NSST FIELDS - - IF (TRIM(MODELNAME) == "FV3GFS") THEN - DO_NSST=.TRUE. - ELSE - FILESZ=0 - DO_NSST=.FALSE. - INQUIRE (FILE="./chgres.inp.nst", SIZE=FILESZ) - IF (FILESZ > 0) DO_NSST=.TRUE. - IF (DO_NSST .AND. NSFCO == 0) THEN - PRINT*,'FATAL ERROR: WHEN CONVERTING AN NSST RESTART FILE,' - PRINT*,'YOU MUST ALSO CONVERT A SURFACE RESTART FILE.' - CALL ERREXIT(33) - ENDIF - ENDIF - - IF(INPTYP==2) THEN - - CALL READ_GFS_SFC_HEADER_SFCIO (NSFCI,IMI,JMI,IVSI,LSOILI, & - FCSTHOUR,IDATE4O,KGDS_INPUT) - - ELSEIF(INPTYP==1) THEN - - CALL READ_GFS_SFC_HEADER_NEMSIO (IMI,JMI,IVSI,LSOILI, & - FCSTHOUR,IDATE4O,KGDS_INPUT) - - ENDIF - - ALLOCATE (SFCINPUT%ALNSF(IMI,JMI), SFCINPUT%ALNWF(IMI,JMI), & - SFCINPUT%ALVSF(IMI,JMI), SFCINPUT%ALVWF(IMI,JMI), & - SFCINPUT%CANOPY_MC(IMI,JMI),SFCINPUT%GREENFRC(IMI,JMI), & - SFCINPUT%FACSF(IMI,JMI), SFCINPUT%FACWF(IMI,JMI), & - SFCINPUT%SKIN_TEMP(IMI,JMI),SFCINPUT%LSMASK(IMI,JMI), & - SFCINPUT%SEA_ICE_FLAG(IMI,JMI), & - SFCINPUT%SNOW_LIQ_EQUIV(IMI,JMI), & - SFCINPUT%Z0(IMI,JMI), SFCINPUT%OROG(IMI,JMI), & - SFCINPUT%VEG_TYPE(IMI,JMI), SFCINPUT%SOIL_TYPE(IMI,JMI),& - SFCINPUT%SOILM_TOT(IMI,JMI,LSOILI), & - SFCINPUT%SOIL_TEMP(IMI,JMI,LSOILI) ) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! THE 200501 VERSION OF THE SURFACE FILE HAS ADDITIONAL FIELDS FOR -! USE BY NOAH LSM AND NEW SEA ICE PHYSICS, WHILE OLDER VERSIONS -! DO NOT. IF THESE VARIABLES ARE NOT ALLOCATED, THE SURFACE CHGRES -! CODE WILL NOT INTERPOLATE THEM. - - IF (IVSI >= 200501) THEN - ALLOCATE (SFCINPUT%SEA_ICE_FRACT(IMI,JMI), & - SFCINPUT%SEA_ICE_DEPTH(IMI,JMI), & - SFCINPUT%MXSNOW_ALB(IMI,JMI), & - SFCINPUT%SNOW_DEPTH(IMI,JMI), & - SFCINPUT%SLOPE_TYPE(IMI,JMI), & - SFCINPUT%GREENFRC_MAX(IMI,JMI), & - SFCINPUT%GREENFRC_MIN(IMI,JMI), & - SFCINPUT%SOILM_LIQ(IMI,JMI,LSOILI) ) - ENDIF - - ALLOCATE (F10MI(IMI,JMI), T2MI(IMI,JMI), Q2MI(IMI,JMI), & - UUSTARI(IMI,JMI), FFMMI(IMI,JMI), FFHHI(IMI,JMI), & - SRFLAGI(IMI,JMI), TPRCPI(IMI,JMI) ) - - IF(INPTYP==2) THEN - - CALL READ_GFS_SFC_DATA_SFCIO (NSFCI, IMI, JMI, SFCINPUT, & - F10MI, T2MI, Q2MI, UUSTARI, FFMMI, FFHHI, & - SRFLAGI, TPRCPI) - - ELSE - - IF (TRIM(MODELNAME) == "FV3GFS") THEN - CALL READ_FV3GFS_SFC_DATA_NEMSIO (IMI, JMI, LSOILI, SFCINPUT, & - F10MI, T2MI, Q2MI, UUSTARI, FFMMI, FFHHI, & - SRFLAGI, TPRCPI) - ELSE - CALL READ_GFS_SFC_DATA_NEMSIO (IMI, JMI, LSOILI, IVSI, SFCINPUT, & - F10MI, T2MI, Q2MI, UUSTARI, FFMMI, FFHHI, & - SRFLAGI, TPRCPI) - ENDIF - - ENDIF - - IVSO = 200509 - IF(IVSSFC>0) IVSO = IVSSFC - - LSOILO = LSOILI - IF(LSOIL > 0) LSOILO = LSOIL - IF(IVSO < 200501) LSOILO = 2 - IF(LSOILO /= 2 .AND. LSOILO /= 4) THEN - PRINT*,"FATAL ERROR: NUMBER OF SOIL LAYERS MUST BE 2 OR 4." - CALL ERREXIT(9) - ENDIF - - CALL READ_FV3_GRID_DIMS_NETCDF(TILE_NUM,IMO,JMO) - - IMO_WITH_HALO = IMO - JMO_WITH_HALO = JMO - - IF (HALO > 0) THEN - IMO = IMO - (2*HALO) - JMO = JMO - (2*HALO) - PRINT*,"WILL REMOVE HALO." - PRINT*,"FULL GRID DIMENSIONS: ", IMO_WITH_HALO, JMO_WITH_HALO - PRINT*,"NO HALO DIMENSIONS : ", IMO, JMO - ENDIF - - IJMO = IMO * JMO - - PRINT '(" CHANGE SURFACE FILE RESOLUTION", & - " FROM ",I4," X ",I4," X ",I4," VERSION",I8)', & - IMI,JMI,LSOILI,IVSI - PRINT '(" ", & - " TO ",I4," X ",I4," X ",I4," VERSION",I8)', & - IMO,JMO,LSOILO,IVSO - - ALLOCATE(TMPVAR(IMO_WITH_HALO,JMO_WITH_HALO)) - ALLOCATE(TMPLAT(IMO_WITH_HALO,JMO_WITH_HALO)) - ALLOCATE(TMPLON(IMO_WITH_HALO,JMO_WITH_HALO)) - - ALLOCATE(GEOLAT(IMO,JMO)) - ALLOCATE(GEOLON(IMO,JMO)) - CALL READ_FV3_LATLON_NETCDF(TILE_NUM,IMO_WITH_HALO,JMO_WITH_HALO,TMPLON,TMPLAT) - DO J = 1, JMO - DO I = 1, IMO - GEOLAT(I,J) = TMPLAT(I+HALO,J+HALO) - GEOLON(I,J) = TMPLON(I+HALO,J+HALO) - ENDDO - ENDDO - - DEALLOCATE(TMPLAT, TMPLON) - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! INTERPOLATE SOME SURFACE FIELDS THE OLD WAY. THESE ARE FIELDS -! THAT ARE EITHER DIAGNOSTIC OR DO NOT REQUIRE SPECIAL HANDLING -! BY THE NEW SURFACE CHGRES LOGIC. - - ALLOCATE (F10MO(IMO,JMO), T2MO(IMO,JMO), Q2MO(IMO,JMO), & - UUSTARO(IMO,JMO), FFMMO(IMO,JMO), FFHHO(IMO,JMO), & - TPRCPO(IMO,JMO), SRFLAGO(IMO,JMO) ) - - CALL GL2ANY(0,1,F10MI,IMI,JMI,F10MO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,T2MI,IMI,JMI,T2MO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,Q2MI,IMI,JMI,Q2MO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,UUSTARI,IMI,JMI,UUSTARO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,FFMMI,IMI,JMI,FFMMO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,FFHHI,IMI,JMI,FFHHO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(0,1,TPRCPI,IMI,JMI,TPRCPO,IMO,JMO,GEOLON,GEOLAT) - CALL GL2ANY(2,1,SRFLAGI,IMI,JMI,SRFLAGO,IMO,JMO,GEOLON,GEOLAT) - - DEALLOCATE (F10MI, T2MI, Q2MI, UUSTARI, FFMMI, FFHHI) - DEALLOCATE (TPRCPI, SRFLAGI) - - ALLOCATE(SLMSKO(IMO,JMO)) - CALL READ_FV3_GRID_DATA_NETCDF('slmsk',TILE_NUM,IMO_WITH_HALO,JMO_WITH_HALO,TMPVAR) - DO J = 1, JMO - DO I = 1, IMO - SLMSKO(I,J) = TMPVAR(I+HALO,J+HALO) - ENDDO - ENDDO - ALLOCATE(SFCOUTPUT%LSMASK(IJMO)) - SFCOUTPUT%LSMASK = RESHAPE(SLMSKO, (/IJMO/)) - DEALLOCATE(SLMSKO) - - ALLOCATE(OROGO(IMO,JMO)) - CALL READ_FV3_GRID_DATA_NETCDF('orog_filt',TILE_NUM,IMO_WITH_HALO,JMO_WITH_HALO,TMPVAR) - DO J = 1, JMO - DO I = 1, IMO - OROGO(I,J) = TMPVAR(I+HALO,J+HALO) - ENDDO - ENDDO - ALLOCATE(SFCOUTPUT%OROG(IJMO)) - SFCOUTPUT%OROG = RESHAPE(OROGO, (/IJMO/)) - DEALLOCATE(OROGO) - - ALLOCATE(OROGO_UF(IMO,JMO)) - CALL READ_FV3_GRID_DATA_NETCDF('orog_raw',TILE_NUM,IMO_WITH_HALO,JMO_WITH_HALO,TMPVAR) - DO J = 1, JMO - DO I = 1, IMO - OROGO_UF(I,J) = TMPVAR(I+HALO,J+HALO) - ENDDO - ENDDO - - DEALLOCATE(TMPVAR) - - ALLOCATE(SFCOUTPUT%LATS(IJMO)) - SFCOUTPUT%LATS = RESHAPE(GEOLAT, (/IJMO/)) - DEALLOCATE(GEOLAT) - ALLOCATE(SFCOUTPUT%LONS(IJMO)) - SFCOUTPUT%LONS = RESHAPE(GEOLON, (/IJMO/)) - DEALLOCATE(GEOLON) - - ALLOCATE(SFCOUTPUT%ALNSF(IJMO)) - ALLOCATE(SFCOUTPUT%ALNWF(IJMO)) - ALLOCATE(SFCOUTPUT%ALVSF(IJMO)) - ALLOCATE(SFCOUTPUT%ALVWF(IJMO)) - ALLOCATE(SFCOUTPUT%CANOPY_MC(IJMO)) - ALLOCATE(SFCOUTPUT%FACSF(IJMO)) - ALLOCATE(SFCOUTPUT%FACWF(IJMO)) - ALLOCATE(SFCOUTPUT%GREENFRC(IJMO)) - ALLOCATE(SFCOUTPUT%SUBSTRATE_TEMP(IJMO)) - ALLOCATE(SFCOUTPUT%SKIN_TEMP(IJMO)) - ALLOCATE(SFCOUTPUT%SNOW_LIQ_EQUIV(IJMO)) - ALLOCATE(SFCOUTPUT%Z0(IJMO)) - ALLOCATE(SFCOUTPUT%SOILM_TOT(IJMO,LSOILO)) - ALLOCATE(SFCOUTPUT%SOIL_TEMP(IJMO,LSOILO)) - ALLOCATE(SFCOUTPUT%VEG_TYPE(IJMO)) - ALLOCATE(SFCOUTPUT%SOIL_TYPE(IJMO)) - ALLOCATE(SFCOUTPUT%SEA_ICE_FLAG(IJMO)) - IF (IVSO >= 200501) THEN - ALLOCATE(SFCOUTPUT%SLOPE_TYPE(IJMO)) - ALLOCATE(SFCOUTPUT%SEA_ICE_FRACT(IJMO)) - ALLOCATE(SFCOUTPUT%SEA_ICE_DEPTH(IJMO)) - ALLOCATE(SFCOUTPUT%SOILM_LIQ(IJMO,LSOILO)) - ALLOCATE(SFCOUTPUT%SNOW_DEPTH(IJMO)) - ALLOCATE(SFCOUTPUT%MXSNOW_ALB(IJMO)) - ALLOCATE(SFCOUTPUT%GREENFRC_MAX(IJMO)) - ALLOCATE(SFCOUTPUT%GREENFRC_MIN(IJMO)) - END IF - IF (IVSO >= 200509) then - ALLOCATE (SFCOUTPUT%SEA_ICE_TEMP(IJMO)) - END IF - -! the fv3 does not have a grib 1 gds. so, there is no way to set the -! kgds array for the output grid. ipolates only uses kgds for the -! output grid when doing the budget interpolation. so, for now, -! only bilinear and neighbor interpolation will be used. - - KGDS_OUTPUT = 0 - - CALL SURFACE_CHGRES_DRIVER(IMO,JMO,IJMO,LSOILO, & - KGDS_OUTPUT,SFCOUTPUT,IMI,JMI, & - OROGO_UF,USE_UFO,NST_ANL, & - LSOILI, IDATE4O(1), IDATE4O(2), & - IDATE4O(3), IDATE4O(4), FCSTHOUR, & - KGDS_INPUT, SFCINPUT, IALB, & - ISOT, IVEGSRC, TILE_NUM, MERGE, IRET) - - IF (IRET /= 0) THEN - PRINT*, "FATAL ERROR IN SURFACE CHGRES DRIVER. IRET: ", IRET - CALL ERREXIT(34) - END IF - - CALL SURFACE_CHGRES_AX2D(SFCINPUT) - - DEALLOCATE(OROGO_UF) - - IF (DO_NSST) THEN - - ALLOCATE(RLATS_OUTPUT(IJMO)) - RLATS_OUTPUT=SFCOUTPUT%LATS - ALLOCATE(RLONS_OUTPUT(IJMO)) - RLONS_OUTPUT=SFCOUTPUT%LONS - ALLOCATE(MASK_OUTPUT(IJMO)) - MASK_OUTPUT=SFCOUTPUT%LSMASK - WHERE(SFCOUTPUT%SEA_ICE_FLAG==1) MASK_OUTPUT=2 - - ALLOCATE(NSST_OUTPUT(IJMO,NUM_NSST_FIELDS)) - ALLOCATE(NSST_INPUT(IMI,JMI,NUM_NSST_FIELDS)) - ALLOCATE(MASK_INPUT(IMI,JMI)) - - IF (INPTYP == 1) THEN - IF(TRIM(MODELNAME) == "FV3GFS") THEN ! for fv3, surface and nst - ! records in same file. - CALL READ_FV3GFS_NSST_DATA_NEMSIO (MASK_INPUT,NSST_INPUT,IMI,JMI, & - NUM_NSST_FIELDS,NSST_YEAR,NSST_MON,NSST_DAY, & - NSST_HOUR,NSST_FHOUR) - ELSE - CALL READ_GFS_NSST_DATA_NEMSIO (MASK_INPUT,NSST_INPUT,IMI,JMI, & - NUM_NSST_FIELDS,NSST_YEAR,NSST_MON,NSST_DAY, & - NSST_HOUR,NSST_FHOUR) - ENDIF - ELSEIF (INPTYP == 2) THEN - CALL READ_GFS_NSST_DATA_NSTIO (IMI,JMI,NUM_NSST_FIELDS, & - NSST_INPUT, MASK_INPUT,NSST_YEAR, & - NSST_MON,NSST_DAY,NSST_HOUR, & - NSST_FHOUR) - ENDIF - - PRINT*,"- CHANGE NSST FILE RESOLUTION FROM ",IMI, " X ",JMI - PRINT*," TO ",IMO, " X ",JMO - - CALL NSST_CHGRES(IMI, JMI, MASK_OUTPUT, SFCOUTPUT%SKIN_TEMP, & - IMO, IJMO, KGDS_INPUT, NSST_INPUT, MASK_INPUT, & - NSST_OUTPUT, NUM_NSST_FIELDS, & - KGDS_OUTPUT, RLATS_OUTPUT, RLONS_OUTPUT) - - DEALLOCATE(RLATS_OUTPUT,RLONS_OUTPUT) - DEALLOCATE(NSST_INPUT,MASK_INPUT,MASK_OUTPUT) - - CALL WRITE_FV3_SFC_DATA_NETCDF(IMO,JMO,LSOILO,SFCOUTPUT,F10MO, & - T2MO,Q2MO,UUSTARO,FFMMO,FFHHO,TPRCPO, & - SRFLAGO,TILE_NUM,NUM_NSST_FIELDS,NSST_OUTPUT) - - DEALLOCATE(NSST_OUTPUT) - - ELSE ! output surface data only. - - CALL WRITE_FV3_SFC_DATA_NETCDF(IMO,JMO,LSOILO,SFCOUTPUT,F10MO, & - T2MO,Q2MO,UUSTARO,FFMMO,FFHHO,TPRCPO, & - SRFLAGO,TILE_NUM,NUM_NSST_FIELDS) - - - ENDIF ! process nsst file - - DEALLOCATE(F10MO, T2MO, Q2MO, UUSTARO, FFMMO, FFHHO) - DEALLOCATE(TPRCPO, SRFLAGO) - CALL SURFACE_CHGRES_AX1D(SFCOUTPUT) - - 80 CONTINUE - - IF(NSIGO==0 .AND. NSFCO==0) THEN - PRINT *,'- NO INPUT ATMOS OR SURFACE FILE SPECIFIED' - ENDIF - - CALL W3TAGE('GLOBAL_CHGRES') - END PROGRAM CHGRES diff --git a/sorc/global_chgres.fd/chgres_utils.f90 b/sorc/global_chgres.fd/chgres_utils.f90 deleted file mode 100755 index e6bab2c23..000000000 --- a/sorc/global_chgres.fd/chgres_utils.f90 +++ /dev/null @@ -1,2254 +0,0 @@ -!> @file -!! -!! INTERPOLATE GAUSSIAN GRID TO ANY GRID -!! @author EMC @date JAN-18-2017 -!! -!! INPUT ARGUMENT LIST: -!! IP INTEGER INTERPOLATION TYPE -!! KM INTEGER NUMBER OF LEVELS -!! G1 REAL (IM1,JM1,KM) INPUT GAUSSIAN FIELD -!! IM1 INTEGER NUMBER OF INPUT LONGITUDES -!! JM1 INTEGER NUMBER OF INPUT LATITUDES -!! IM2 INTEGER NUMBER OF OUTPUT LONGITUDES -!! JM2 INTEGER NUMBER OF OUTPUT LATITUDES -!! RLON REAL (IM2,JM2) OUTPUT GRID LONGITUDES -!! RLAT REAL (IM2,JM2) OUTPUT GRID LATITUDES -!! OUTPUT ARGUMENT LIST: -!! G2 REAL (IM2,JM2,KM) OUTPUT FIELD -!! -!! SUBPROGRAMS CALLED: -!! - ipolates() IREDELL'S POLATE FOR SCALAR FIELDS -!! - SUBROUTINE GL2ANY(IP,KM,G1,IM1,JM1,G2,IM2,JM2,RLON,RLAT) - IMPLICIT NONE - INTEGER, INTENT(IN) :: IP, KM, IM1, JM1, IM2, JM2 - REAL, INTENT(IN) :: G1(IM1,JM1,KM) - REAL, INTENT(IN) :: RLAT(IM2,JM2),RLON(IM2,JM2) - REAL, INTENT(OUT) :: G2(IM2,JM2,KM) - LOGICAL*1 :: L1(IM1,JM1,KM),L2(IM2,JM2,KM) - INTEGER :: IB1(KM),IB2(KM) - INTEGER :: KGDS1(200),KGDS2(200) - INTEGER :: IPOPT(20), IRET, NO - DATA KGDS1/4,0,0,90000,0,0,-90000,193*0/ - DATA KGDS2/200*0/ - DATA IPOPT/20*0/ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - L1=.TRUE. - KGDS2(1) = -1 - NO = IM2*JM2 - IB1=0 - KGDS1(2)=IM1 - KGDS1(3)=JM1 - KGDS1(8)=NINT(-360000./IM1) - KGDS1(10)=JM1/2 - CALL IPOLATES(IP,IPOPT,KGDS1,KGDS2,IM1*JM1,IM2*JM2,KM,IB1,L1,G1, & - NO,RLAT,RLON,IB2,L2,G2,IRET) - IF(IRET/=0)THEN - PRINT*,'FATAL ERROR IN ROUTINE GL2ANY, IRET: ', IRET - CALL ERREXIT(23) - ENDIF - END SUBROUTINE GL2ANY - -!----------------------------------------------------------------------- - SUBROUTINE GL2ANYV(IP,KM,G1U,G1V,IM1,JM1,G2U,G2V,IM2,JM2,RLON,RLAT) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: GL2ANYV INTERPOLATE GAUSSIAN GRID TO ANY GRID -! PRGMMR: EMC ORG: W/NMC23 DATE: JAN-23-2017 -! -! ABSTRACT: LINEARLY INTERPOLATES VECTOR FIELD FROM GAUSSIAN GRID TO -! ANY GRID. OUTPUT WINDS ARE EARTH RELATIVE. -! -! PROGRAM HISTORY LOG: -! 2017-JAN-23 ESRL/EMC INITIAL VERSION -! -! USAGE: CALL GL2ANY(IP,KM,G1U,G1V,IM1,JM1,G2U,G2V,IM2,JM2,RLON,RLAT) -! INPUT ARGUMENT LIST: -! IP INTEGER INTERPOLATION TYPE -! KM INTEGER NUMBER OF LEVELS -! G1U REAL (IM1,JM1,KM) INPUT GAUSSIAN U-COMPONENT FIELD -! G1V REAL (IM1,JM1,KM) INPUT GAUSSIAN V-COMPONENT FIELD -! IM1 INTEGER NUMBER OF INPUT LONGITUDES -! JM1 INTEGER NUMBER OF INPUT LATITUDES -! IM2 INTEGER NUMBER OF OUTPUT LONGITUDES -! JM2 INTEGER NUMBER OF OUTPUT LATITUDES -! RLON REAL (IM2,JM2) OUTPUT GRID LONGITUDES -! RLAT REAL (IM2,JM2) OUTPUT GRID LATITUDES -! OUTPUT ARGUMENT LIST: -! G2U REAL (IM2,JM2,KM) OUTPUT U-COMPONENT FIELD -! G2V REAL (IM2,JM2,KM) OUTPUT V-COMPONENT FIELD -! -! SUBPROGRAMS CALLED: -! IPOLATEV IREDELL'S POLATE FOR VECTOR FIELDS -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!C$$$ - IMPLICIT NONE - INTEGER, INTENT(IN) :: IP, KM, IM1, JM1, IM2, JM2 - REAL, INTENT(IN) :: G1U(IM1,JM1,KM), G1V(IM1,JM1,KM) - REAL, INTENT(IN) :: RLAT(IM2,JM2),RLON(IM2,JM2) - REAL, INTENT(OUT) :: G2U(IM2,JM2,KM), G2V(IM2,JM2,KM) - LOGICAL*1 :: L1(IM1,JM1,KM),L2(IM2,JM2,KM) - INTEGER :: IB1(KM),IB2(KM) - INTEGER :: KGDS1(200),KGDS2(200) - INTEGER :: IPOPT(20), IRET, NO - REAL :: CROT(IM2,JM2),SROT(IM2,JM2) - DATA KGDS1/4,0,0,90000,0,0,-90000,193*0/ - DATA KGDS2/200*0/ - DATA IPOPT/20*0/ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - L1=.TRUE. - KGDS2(1) = -1 ! THE OUTPUT GRID IS A SERIES OF POINTS - NO = IM2*JM2 - IB1=0 - KGDS1(2)=IM1 - KGDS1(3)=JM1 - KGDS1(8)=NINT(-360000./IM1) - KGDS1(10)=JM1/2 - CROT = 1.0 ! DONT ROTATE WINDS TO THE OUTPUT GRID. - SROT = 0.0 ! FV3 EXPECTS EARTH RELATIVE WINDS. - CALL IPOLATEV(IP,IPOPT,KGDS1,KGDS2,IM1*JM1,IM2*JM2,KM,IB1,L1,G1U, & - G1V,NO,RLAT,RLON,CROT,SROT,IB2,L2,G2U,G2V,IRET) - IF(IRET/=0)THEN - PRINT*,'FATAL ERROR IN ROUTINE GL2ANYV, IRET: ', IRET - CALL ERREXIT(23) - ENDIF - END SUBROUTINE GL2ANYV - -!----------------------------------------------------------------------- - SUBROUTINE NEWSIG(NSIL,IDVC,LEVS,NVCOORD,VCOORD,IRET) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWSIG GET NEW SIGMA STRUCTURE -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-04-03 -! -! ABSTRACT: READ IN INTERFACE SIGMA VALUES (OR USE OLD VALUES) -! AND COMPUTE FULL SIGMA VALUES. -! -! PROGRAM HISTORY LOG: -! 98-04-03 IREDELL -! -! USAGE: CALL NEWSIG(NSIL,IDVC,LEVS,NVCOORD,VCOORD,IRET) -! INPUT ARGUMENTS: -! NSIL INTEGER UNIT NUMBER OF NEW SIGMA INTERFACE VALUES -! IDVC INTEGER VERTICAL COORDINATE ID -! LEVS INTEGER NEW NUMBER OF LEVELS -! NVCOORD INTEGER NEW NUMBER OF VERTICAL COORDINATES -! OUTPUT ARGUMENTS: -! VCOORD REAL (LEVS+1,NVCOORD) NEW VERTICAL COORDINATES -! IRET INTEGER RETURN CODE -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE -! - INTEGER :: NSIL,IDVC,LEVS,NVCOORD,IRET - REAL :: VCOORD(LEVS+1,NVCOORD) -! - INTEGER :: IDVCI,LEVSI,NVCOORDI,K,N -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ VERTICAL COORDINATES - PRINT*,'' - PRINT*,"READ VERTICAL COORDS FROM UNIT ",NSIL - READ(NSIL,*,IOSTAT=IRET) IDVCI,LEVSI,NVCOORDI - write(*,*)'IDVCI=',IDVCI,' LEVSI=',LEVSI,' NVCOORDI=',NVCOORDI - IF(IRET == 0) THEN -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Added by Moorthi for gaea - if (nvcoordi == 0) then - nvcoordi = nvcoord - backspace nsil - if (idvci > 5) then - levsi = idvci - idvci = 0 - idvc = idvci - nvcoordi = 1 - nvcoord = nvcoordi - - backspace nsil - READ(NSIL,*,IOSTAT=IRET) (VCOORD(K,1),K=2,LEVS) - VCOORD(1,1) = 1. - VCOORD(LEVS+1,1) = 0. - else - READ(NSIL,*,IOSTAT=IRET) & - ((VCOORD(K,N),N=1,NVCOORD),K=1,LEVS+1) - endif - elseif (nvcoordi <= 3) then - READ(NSIL,*,IOSTAT=IRET) & - ((VCOORD(K,N),N=1,NVCOORD),K=1,LEVS+1) - else - write(0,*)'FATAL ERROR: nvcoordi=',nvcoordi,' not available-abort chgres' - call errexit(55) - endif - IF(IRET .NE. 0) RETURN - IF(IDVCI .NE. IDVC.OR.LEVSI .NE. LEVS) IRET = 28 - IF(NVCOORDI.NE. NVCOORD) IRET = 28 - IF(IRET .NE. 0) RETURN -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ INTERFACE HYBRID VALUES - ELSE - REWIND NSIL - READ(NSIL,*,IOSTAT=IRET) IDVCI - REWIND NSIL - IF(IRET == 0 .AND. (IDVCI == 2 .OR. IDVCI == 3)) THEN - READ(NSIL,*,IOSTAT=IRET) IDVCI, LEVSI - READ(NSIL,*,IOSTAT=IRET) (VCOORD(K,1),VCOORD(K,2),K=1,LEVS+1) - IF(IRET.NE.0) RETURN - IF(IDVCI.NE.IDVC.OR.LEVSI.NE.LEVS) IRET = 28 - IF(IRET.NE.0) RETURN -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! READ INTERFACE SIGMA VALUES - ELSE - VCOORD(1,1) = 1. - VCOORD(LEVS+1,1) = 0. - READ(NSIL,*,IOSTAT=IRET) LEVSI - READ(NSIL,*,IOSTAT=IRET) (VCOORD(K,1),K=2,LEVS) - IF(IRET.NE.0) RETURN - IF(LEVSI.NE.LEVS) IRET = 28 - IF(IRET.NE.0) RETURN - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ENDIF - IRET=0 - END SUBROUTINE NEWSIG -!----------------------------------------------------------------------- - SUBROUTINE TRSSC(JCAP,NC,KM,NTRAC,IDVM, & - IDRT,LONB,LATB,IJN,J1,J2,JC,LONSPERLAT, & - SZS,SPS,ST,SD,SZ,SQ,ZS,PS,T,U,V,Q) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TRSSC TRANSFORM SIGMA SPECTRAL FIELDS TO GRID -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: TRANSFORMS SIGMA SPECTRAL FIELDS TO GRID AND CONVERTS -! LOG SURFACE PRESSURE TO SURFACE PRESSURE AND VIRTUAL TEMPERATURE -! TO TEMPERATURE. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL TRSSC(JCAP,NC,KM,NTRAC,IDVM, -! & IDRT,LONB,LATB,IJN,J1,J2,JC,LONSPERLAT, -! & SZS,SPS,ST,SD,SZ,SQ,ZS,PS,T,U,V,Q) -! INPUT ARGUMENT LIST: -! JCAP INTEGER SPECTRAL TRUNCATION -! NC INTEGER FIRST DIMENSION (NC>=(JCAP+1)*(JCAP+2)) -! KM INTEGER NUMBER OF LEVELS -! NTRAC INTEGER NUMBER OF TRACERS -! IDVM INTEGER MASS VARIABLE ID -! IDRT INTEGER DATA REPRESENTATION TYPE -! LONB INTEGER NUMBER OF LONGITUDES -! LATB INTEGER NUMBER OF LATITUDES -! IJN INTEGER HORIZONTAL DIMENSION -! J1 INTEGER FIRST LATITUDE -! J2 INTEGER LAST LATITUDE -! JC INTEGER NUMBER OF CPUS -! LONSPERLAT INTEGER (J1:J2) NUMBER OF LONGITUDES PER LATITUDE -! SZS REAL (NC) OROGRAPHY -! SPS REAL (NC) LOG SURFACE PRESSURE -! ST REAL (NC,LEVS) VIRTUAL TEMPERATURE -! SD REAL (NC,LEVS) DIVERGENCE -! SZ REAL (NC,LEVS) VORTICITY -! SQ REAL (NC,LEVS*NTRAC) TRACERS -! OUTPUT ARGUMENT LIST: -! ZS REAL (IJN) OROGRAPHY -! PS REAL (IJN) SURFACE PRESSURE -! T REAL (IJN,KM) TEMPERATURE -! U REAL (IJN,KM) ZONAL WIND -! V REAL (IJN,KM) MERIDIONAL WIND -! Q REAL (IJN,KM*NTRAC) TRACERS -! -! SUBPROGRAMS CALLED: -! SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - INTEGER LONSPERLAT(J1:J2) - REAL SZS(NC),SPS(NC),ST(NC,KM),SD(NC,KM),SZ(NC,KM),SQ(NC,KM*NTRAC) - REAL ZS(IJN),PS(IJN),T(IJN,KM),U(IJN,KM),V(IJN,KM),Q(IJN,KM*NTRAC) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! SPECTRAL TRANSFORMS - LONB2=LONB*2 - IJ=LONB2*(J2-J1+1) - IN=1 - IS=1+LONB - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,1,1,1,LONB2,LONB2,NC,IJN, & - J1,J2,JC,SZS,ZS(IN),ZS(IS),1) - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,1,1,1,LONB2,LONB2,NC,IJN, & - J1,J2,JC,SPS,PS(IN),PS(IS),1) - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN, & - J1,J2,JC,ST,T(IN,1),T(IS,1),1) - CALL SPTRANV(0,JCAP,IDRT,LONB,LATB,KM,1,1,LONB2,LONB2,NC,IJN, & - J1,J2,JC,SD,SZ,U(IN,1),U(IS,1),V(IN,1),V(IS,1),1) - CALL SPTRAN(0,JCAP,IDRT,LONB,LATB,KM*NTRAC,1,1,LONB2,LONB2,NC,IJN,& - J1,J2,JC,SQ,Q(IN,1),Q(IS,1),1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! TRANSFORM TO REDUCED GRID INSTEAD - DO J=J1,J2 - JN=LONB2*(J-J1)+IN - JS=LONB2*(J-J1)+IS - CALL SPTRRJ(LONB,LONSPERLAT(J),ZS(JN),ZS(JN),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),ZS(JS),ZS(JS),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),PS(JN),PS(JN),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),PS(JS),PS(JS),1) - DO K=1,KM - CALL SPTRRJ(LONB,LONSPERLAT(J),T(JN,K),T(JN,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),T(JS,K),T(JS,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),U(JN,K),U(JN,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),U(JS,K),U(JS,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),V(JN,K),V(JN,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),V(JS,K),V(JS,K),1) - ENDDO - DO K=1,KM*NTRAC - CALL SPTRRJ(LONB,LONSPERLAT(J),Q(JN,K),Q(JN,K),1) - CALL SPTRRJ(LONB,LONSPERLAT(J),Q(JS,K),Q(JS,K),1) - ENDDO - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! CONVERT TO SURFACE PRESSURE AND TEMPERATURE -! SELECT CASE(MOD(IDVM,10)) -! CASE(0,1) -! DO I=1,IJ -! PS(I)=1.E3*EXP(PS(I)) -! ENDDO -! CASE(2) -! DO I=1,IJ -! PS(I)=1.E3*PS(I) -! ENDDO -! CASE DEFAULT -! DO I=1,IJ -! PS(I)=1.E3*EXP(PS(I)) -! ENDDO -! END SELECT -! SELECT CASE(MOD(IDVM/10,10)) -! CASE(0,1) -! DO K=1,KM -! DO I=1,IJ -! T(I,K)=T(I,K)/(1.+(461.50/287.05-1)*Q(I,K)) -! if (t(i,k) .lt. 10) print *,' t=',t(i,k),' i=',i -! ENDDO -! print *,' T=',t(ij,k),' q=',Q(IJ,K),' k=',k -! ENDDO -! CASE DEFAULT -! DO K=1,KM -! DO I=1,IJ -! T(I,K)=T(I,K)/(1.+(461.50/287.05-1)*Q(I,K)) -! ENDDO -! ENDDO -! END SELECT -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE TRSSC -!----------------------------------------------------------------------- - SUBROUTINE NEWPS(IM,ZS,PS,IMX,KM,P,T,Q,ZSNEW,PSNEW) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPS COMPUTE NEW SURFACE PRESSURE -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: COMPUTES A NEW SURFACE PRESSURE GIVEN A NEW OROGRAPHY. -! THE NEW PRESSURE IS COMPUTED ASSUMING A HYDROSTATIC BALANCE -! AND A CONSTANT TEMPERATURE LAPSE RATE. BELOW GROUND, THE -! LAPSE RATE IS ASSUMED TO BE -6.5 K/KM. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL NEWPS(IM,ZS,PS,IMX,KM,P,T,Q,ZSNEW,PSNEW) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! ZS REAL (IM) OLD OROGRAPHY (M) -! PS REAL (IM) OLD SURFACE PRESSURE (PA) -! IMX INTEGER FIRST DIMENSION -! KM INTEGER NUMBER OF LEVELS -! P REAL (IMX,KM) PRESSURES (PA) -! T REAL (IMX,KM) TEMPERATURES (K) -! Q REAL (IMX,KM) SPECIFIC HUMIDITIES (KG/KG) -! ZSNEW REAL (IM) NEW OROGRAPHY (M) -! OUTPUT ARGUMENT LIST: -! PSNEW REAL (IM) NEW SURFACE PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - INTEGER,INTENT(IN)::IM,IMX,KM - REAL,INTENT(IN):: ZS(IM),PS(IM),P(IMX,KM) - REAL,INTENT(IN):: T(IMX,KM),Q(IMX,KM) - REAL,INTENT(IN):: ZSNEW(IM) - REAL,INTENT(OUT):: PSNEW(IM) - PARAMETER(BETA=-6.5E-3,EPSILON=1.E-9) - PARAMETER(G=9.80665,RD=287.05,RV=461.50) - PARAMETER(GOR=G/RD,FV=RV/RD-1.) - REAL ZU(IM) - FTV(AT,AQ)=AT*(1+FV*AQ) - FGAM(APU,ATVU,APD,ATVD)=-GOR*LOG(ATVD/ATVU)/LOG(APD/APU) - FZ0(AP,ATV,AZD,APD)=AZD+ATV/GOR*LOG(APD/AP) - FZ1(AP,ATV,AZD,APD,AGAM)=AZD-ATV/AGAM*((APD/AP)**(-AGAM/GOR)-1) - FP0(AZ,AZU,APU,ATVU)=APU*EXP(-GOR/ATVU*(AZ-AZU)) - FP1(AZ,AZU,APU,ATVU,AGAM)=APU*(1+AGAM/ATVU*(AZ-AZU))**(-GOR/AGAM) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE BELOW THE ORIGINAL GROUND - LS=0 - K=1 - GAMMA=BETA - DO I=1,IM -! if (zsnew(i) == zs(i)) then -! psnew(i) = ps(i) -! else - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - ZU(I)=FZ1(PU,TVU,ZS(I),PS(I),GAMMA) - IF(ZSNEW(I).LE.ZU(I)) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ELSE - PSNEW(I)=0 - LS=LS+1 - ENDIF -! endif - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE ABOVE THE ORIGINAL GROUND - DO K=2,KM - IF(LS.GT.0) THEN - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PD=P(I,K-1) - TVD=FTV(T(I,K-1),Q(I,K-1)) - GAMMA=FGAM(PU,TVU,PD,TVD) - IF(ABS(GAMMA).GT.EPSILON) THEN - ZU(I)=FZ1(PU,TVU,ZU(I),PD,GAMMA) - ELSE - ZU(I)=FZ0(PU,TVU,ZU(I),PD) - ENDIF - IF(ZSNEW(I).LE.ZU(I)) THEN - IF(ABS(GAMMA).GT.EPSILON) THEN - PSNEW(I)=FP1(ZSNEW(I),ZU(I),PU,TVU,GAMMA) - ELSE - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - LS=LS-1 - ENDIF - ENDIF - ENDDO - ENDIF - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE SURFACE PRESSURE OVER THE TOP - IF(LS.GT.0) THEN - K=KM - GAMMA=0 - DO I=1,IM - IF(PSNEW(I).EQ.0) THEN - PU=P(I,K) - TVU=FTV(T(I,K),Q(I,K)) - PSNEW(I)=FP0(ZSNEW(I),ZU(I),PU,TVU) - ENDIF - ENDDO - ENDIF - END SUBROUTINE NEWPS -!----------------------------------------------------------------------- - SUBROUTINE VINTG(IM,IX,KM1,KM2,NT,P1,U1,V1,T1,Q1,W1,P2, & - U2,V2,T2,Q2,W2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL VINTG(IM,IX,KM1,KM2,NT,P1,U1,V1,T1,Q1,P2, -! & U2,V2,T2,Q2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! IX INTEGER FIRST DIMENSION -! KM1 INTEGER NUMBER OF INPUT LEVELS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! NT INTEGER NUMBER OF TRACERS -! P1 REAL (IX,KM1) INPUT PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! U1 REAL (IX,KM1) INPUT ZONAL WIND -! V1 REAL (IX,KM1) INPUT MERIDIONAL WIND -! T1 REAL (IX,KM1) INPUT TEMPERATURE (K) -! Q1 REAL (IX,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) -! P2 REAL (IX,KM2) OUTPUT PRESSURES -! OUTPUT ARGUMENT LIST: -! U2 REAL (IX,KM2) OUTPUT ZONAL WIND -! V2 REAL (IX,KM2) OUTPUT MERIDIONAL WIND -! T2 REAL (IX,KM2) OUTPUT TEMPERATURE (K) -! Q2 REAL (IX,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) -! DTDP2 REAL (IX,KM2) OUTPUT DTDP -! -! SUBPROGRAMS CALLED: -! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - REAL P1(IX,KM1),U1(IX,KM1),V1(IX,KM1),T1(IX,KM1),Q1(IX,KM1,NT) & - ,W1(IX,KM1) - REAL P2(IX,KM2),U2(IX,KM2),V2(IX,KM2),T2(IX,KM2),Q2(IX,KM2,NT) & - ,W2(IX,KM2) -! REAL,optional :: DTDP2(IX,KM2) - PARAMETER(DLTDZ=-6.5E-3*287.05/9.80665) - PARAMETER(DLPVDRT=-2.5E6/461.50) - - REAL,allocatable :: Z1(:,:),Z2(:,:) - REAL,allocatable :: C1(:,:,:),C2(:,:,:),J2(:,:,:) - - allocate (Z1(IM+1,KM1),Z2(IM+1,KM2)) - allocate (C1(IM+1,KM1,4+NT),C2(IM+1,KM2,4+NT),J2(IM+1,KM2,4+NT)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE -! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -!$OMP PARALLEL DO DEFAULT(SHARED), & -!$OMP& PRIVATE(K,I) - DO K=1,KM1 - DO I=1,IM - Z1(I,K) = -LOG(P1(I,K)) - C1(I,K,1) = U1(I,K) - C1(I,K,2) = V1(I,K) - C1(I,K,3) = W1(I,K) - C1(I,K,4) = T1(I,K) - C1(I,K,5) = Q1(I,K,1) - ENDDO - ENDDO -!$OMP END PARALLEL DO - DO N=2,NT - DO K=1,KM1 - DO I=1,IM - C1(I,K,4+N) = Q1(I,K,N) - ENDDO - ENDDO - ENDDO -!$OMP PARALLEL DO DEFAULT(SHARED), & -!$OMP& PRIVATE(K,I) - DO K=1,KM2 - DO I=1,IM - Z2(I,K) = -LOG(P2(I,K)) - ENDDO - ENDDO -!$OMP END PARALLEL DO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION -! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS -! AND 1ST-ORDER FOR EXTRAPOLATION. - CALL TERP3(IM,1,1,1,1,4+NT,(IM+1)*KM1,(IM+1)*KM2, & - KM1,IM+1,IM+1,Z1,C1,KM2,IM+1,IM+1,Z2,C2,J2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED -! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. - DO K=1,KM2 - DO I=1,IM - U2(I,K)=C2(I,K,1) - V2(I,K)=C2(I,K,2) - W2(I,K)=C2(I,K,3) - DZ=Z2(I,K)-Z1(I,1) - IF(DZ.GE.0) THEN - T2(I,K)=C2(I,K,4) - Q2(I,K,1)=C2(I,K,5) -!jaa DTDP2(I,K)=-J2(I,K,4)/P2(I,K) - ELSE - T2(I,K)=T1(I,1)*EXP(DLTDZ*DZ) - Q2(I,K,1)=Q1(I,1,1)*EXP(DLPVDRT*(1/T2(I,K)-1/T1(I,1))-DZ) -!jaa DTDP2(I,K)=-T2(I,K)*DLTDZ/P2(I,K) - ENDIF - ENDDO - ENDDO - DO N=2,NT - DO K=1,KM2 - DO I=1,IM - Q2(I,K,N)=C2(I,K,4+N) - ENDDO - ENDDO - ENDDO - DEALLOCATE (Z1,Z2,C1,C2,J2) - END SUBROUTINE VINTG -!----------------------------------------------------------------------- - SUBROUTINE TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & - & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). -! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT -! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. -! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 98-05-01 MARK IREDELL -! 1999-01-04 IREDELL USE ESSL SEARCH -! -! USAGE: CALL TERP3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, -! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2,J2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF COLUMNS -! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 -! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 -! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 -! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 -! NM INTEGER NUMBER OF FIELDS PER COLUMN -! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 -! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 -! KM1 INTEGER NUMBER OF INPUT POINTS -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE -! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) -! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) -! INPUT FIELDS TO INTERPOLATE -! KM2 INTEGER NUMBER OF OUTPUT POINTS -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE -! (Z2 NEED NOT BE MONOTONIC) -! -! OUTPUT ARGUMENT LIST: -! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS -! J2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS CHANGE WRT Z2 -! -! SUBPROGRAMS CALLED: -! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2 - INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2 - INTEGER I,K1,K2,N - REAL Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) - REAL Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - REAL Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL J2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL FFA(IM),FFB(IM),FFC(IM),FFD(IM) - REAL GGA(IM),GGB(IM),GGC(IM),GGD(IM) - INTEGER K1S(IM,KM2) - REAL Z1A,Z1B,Z1C,Z1D,Q1A,Q1B,Q1C,Q1D,Z2S,Q2S,J2S -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,1,IM,K1S) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GENERALLY INTERPOLATE CUBICALLY WITH MONOTONIC CONSTRAINT -! FROM TWO NEAREST INPUT POINTS ON EITHER SIDE OF THE OUTPUT POINT, -! BUT WITHIN THE TWO EDGE INTERVALS INTERPOLATE LINEARLY. -! KEEP THE OUTPUT FIELDS CONSTANT OUTSIDE THE INPUT DOMAIN. - -!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(IM,IXZ1,IXQ1,IXZ2) , & -!$OMP& SHARED(IXQ2,NM,NXQ1,NXQ2,KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2) , & -!$OMP& SHARED(KXQ2,Z2,Q2,J2,K1S) - - DO K2=1,KM2 - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A) - GGA(I)=1/(Z1A-Z1B) - GGB(I)=1/(Z1B-Z1A) - ELSEIF(K1.GT.1.AND.K1.LT.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-2)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1C=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - Z1D=Z1(1+(I-1)*IXZ1+(K1+1)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D) - FFC(I)=(Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D) - FFD(I)=(Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C) - GGA(I)= 1/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - 1/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D)+ & - (Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - 1/(Z1A-Z1D) - GGB(I)= 1/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - 1/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D)+ & - (Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - 1/(Z1B-Z1D) - GGC(I)= 1/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - 1/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D)+ & - (Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - 1/(Z1C-Z1D) - GGD(I)= 1/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - 1/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C)+ & - (Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - 1/(Z1D-Z1C) - ENDIF - ENDDO -! INTERPOLATE. - DO N=1,NM - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.0) THEN - Q2S=Q1(1+(I-1)*IXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.KM1) THEN - Q2S=Q1(1+(I-1)*IXQ1+(KM1-1)*KXQ1+(N-1)*NXQ1) - J2S=0 - ELSEIF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Q1A=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B - J2S=GGA(I)*Q1A+GGB(I)*Q1B - ELSE - Q1A=Q1(1+(I-1)*IXQ1+(K1-2)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1C=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q1D=Q1(1+(I-1)*IXQ1+(K1+1)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B+FFC(I)*Q1C+FFD(I)*Q1D - J2S=GGA(I)*Q1A+GGB(I)*Q1B+GGC(I)*Q1C+GGD(I)*Q1D - IF(Q2S.LT.MIN(Q1B,Q1C)) THEN - Q2S=MIN(Q1B,Q1C) - J2S=0 - ELSEIF(Q2S.GT.MAX(Q1B,Q1C)) THEN - Q2S=MAX(Q1B,Q1C) - J2S=0 - ENDIF - ENDIF - Q2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=Q2S - J2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=J2S - ENDDO - ENDDO - ENDDO -!$OMP END PARALLEL DO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE TERP3 -!----------------------------------------------------------------------- - SUBROUTINE RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,& - & L2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: THIS SUBPROGRAM SEARCHES MONOTONIC SEQUENCES OF REAL NUMBERS -! FOR INTERVALS THAT SURROUND A GIVEN SEARCH SET OF REAL NUMBERS. -! THE SEQUENCES MAY BE MONOTONIC IN EITHER DIRECTION; THE REAL NUMBERS -! MAY BE SINGLE OR DOUBLE PRECISION; THE INPUT SEQUENCES AND SETS -! AND THE OUTPUT LOCATIONS MAY BE ARBITRARILY DIMENSIONED. -! -! PROGRAM HISTORY LOG: -! 1999-01-05 MARK IREDELL -! -! USAGE: CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2, -! & L2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF SEQUENCES TO SEARCH -! KM1 INTEGER NUMBER OF POINTS IN EACH SEQUENCE -! IXZ1 INTEGER SEQUENCE SKIP NUMBER FOR Z1 -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! SEQUENCE VALUES TO SEARCH -! (Z1 MUST BE MONOTONIC IN EITHER DIRECTION) -! KM2 INTEGER NUMBER OF POINTS TO SEARCH FOR -! IN EACH RESPECTIVE SEQUENCE -! IXZ2 INTEGER SEQUENCE SKIP NUMBER FOR Z2 -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! SET OF VALUES TO SEARCH FOR -! (Z2 NEED NOT BE MONOTONIC) -! IXL2 INTEGER SEQUENCE SKIP NUMBER FOR L2 -! KXL2 INTEGER POINT SKIP NUMBER FOR L2 -! -! OUTPUT ARGUMENT LIST: -! L2 INTEGER (1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTERVAL LOCATIONS HAVING VALUES FROM 0 TO KM1 -! (Z2 WILL BE BETWEEN Z1(L2) AND Z1(L2+1)) -! -! SUBPROGRAMS CALLED: -! SBSRCH ESSL BINARY SEARCH -! DBSRCH ESSL BINARY SEARCH -! -! REMARKS: -! IF THE ARRAY Z1 IS DIMENSIONED (IM,KM1), THEN THE SKIP NUMBERS ARE -! IXZ1=1 AND KXZ1=IM; IF IT IS DIMENSIONED (KM1,IM), THEN THE SKIP -! NUMBERS ARE IXZ1=KM1 AND KXZ1=1; IF IT IS DIMENSIONED (IM,JM,KM1), -! THEN THE SKIP NUMBERS ARE IXZ1=1 AND KXZ1=IM*JM; ETCETERA. -! SIMILAR EXAMPLES APPLY TO THE SKIP NUMBERS FOR Z2 AND L2. -! -! RETURNED VALUES OF 0 OR KM1 INDICATE THAT THE GIVEN SEARCH VALUE -! IS OUTSIDE THE RANGE OF THE SEQUENCE. -! -! IF A SEARCH VALUE IS IDENTICAL TO ONE OF THE SEQUENCE VALUES -! THEN THE LOCATION RETURNED POINTS TO THE IDENTICAL VALUE. -! IF THE SEQUENCE IS NOT STRICTLY MONOTONIC AND A SEARCH VALUE IS -! IDENTICAL TO MORE THAN ONE OF THE SEQUENCE VALUES, THEN THE -! LOCATION RETURNED MAY POINT TO ANY OF THE IDENTICAL VALUES. -! -! TO BE EXACT, FOR EACH I FROM 1 TO IM AND FOR EACH K FROM 1 TO KM2, -! Z=Z2(1+(I-1)*IXZ2+(K-1)*KXZ2) IS THE SEARCH VALUE AND -! L=L2(1+(I-1)*IXL2+(K-1)*KXL2) IS THE LOCATION RETURNED. -! IF L=0, THEN Z IS LESS THAN THE START POINT Z1(1+(I-1)*IXZ1) -! FOR ASCENDING SEQUENCES (OR GREATER THAN FOR DESCENDING SEQUENCES). -! IF L=KM1, THEN Z IS GREATER THAN OR EQUAL TO THE END POINT -! Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1) FOR ASCENDING SEQUENCES -! (OR LESS THAN OR EQUAL TO FOR DESCENDING SEQUENCES). -! OTHERWISE Z IS BETWEEN THE VALUES Z1(1+(I-1)*IXZ1+(L-1)*KXZ1) AND -! Z1(1+(I-1)*IXZ1+(L-0)*KXZ1) AND MAY EQUAL THE FORMER. -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ -! IMPLICIT NONE -! INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 -! REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) -! INTEGER(4) INCX,N,INCY,M,INDX(KM2),RC(KM2),IOPT -! INTEGER I,K2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. -! DO I=1,IM -! IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -! INPUT COORDINATE IS MONOTONICALLY ASCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=KXZ1 -! M=KM1 -! IOPT=1 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=INDX(K2)-RC(K2) -! ENDDO -! ELSE -! INPUT COORDINATE IS MONOTONICALLY DESCENDING. -! INCX=KXZ2 -! N=KM2 -! INCY=-KXZ1 -! M=KM1 -! IOPT=0 -! IF(DIGITS(1.).LT.DIGITS(1._8)) THEN -! CALL SBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ELSE -! CALL DBSRCH(Z2(1+(I-1)*IXZ2),INCX,N, -! & Z1(1+(I-1)*IXZ1),INCY,M,INDX,RC,IOPT) -! ENDIF -! DO K2=1,KM2 -! L2(1+(I-1)*IXL2+(K2-1)*KXL2)=KM1+1-INDX(K2) -! ENDDO -! ENDIF -! ENDDO -! - IMPLICIT NONE - INTEGER,INTENT(IN):: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2 - REAL,INTENT(IN):: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL,INTENT(IN):: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - INTEGER,INTENT(OUT):: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2) - INTEGER I,K2,L - REAL Z -!C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!C FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - DO I=1,IM - IF(Z1(1+(I-1)*IXZ1).LE.Z1(1+(I-1)*IXZ1+(KM1-1)*KXZ1)) THEN -!C INPUT COORDINATE IS MONOTONICALLY ASCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.LT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ELSE -!C INPUT COORDINATE IS MONOTONICALLY DESCENDING. - DO K2=1,KM2 - Z=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - L=0 - DO - IF(Z.GT.Z1(1+(I-1)*IXZ1+L*KXZ1)) EXIT - L=L+1 - IF(L.EQ.KM1) EXIT - ENDDO - L2(1+(I-1)*IXL2+(K2-1)*KXL2)=L - ENDDO - ENDIF - ENDDO - - END SUBROUTINE RSEARCH -!----------------------------------------------------------------------- - SUBROUTINE SPPAD(I1,M1,Q1,I2,M2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: SPPAD PAD OR TRUNCATE A SPECTRAL FIELD -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: PAD OR TRUNCATE A SPECTRAL FIELD -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL SPPAD(I1,M1,Q1,I2,M2,Q2) -! -! INPUT ARGUMENT LIST: -! I1 - INTEGER INPUT SPECTRAL DOMAIN SHAPE -! (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -! M1 - INTEGER INPUT SPECTRAL TRUNCATION -! Q1 - REAL ((M+1)*((I+1)*M+2)) INPUT FIELD -! I2 - INTEGER OUTPUT SPECTRAL DOMAIN SHAPE -! (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -! M2 - INTEGER OUTPUT SPECTRAL TRUNCATION -! -! OUTPUT ARGUMENT LIST: -! Q2 - REAL ((M+1)*((I+1)*M+2)) OUTPUT FIELD -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - REAL Q1((M1+1)*((I1+1)*M1+2)) - REAL Q2((M2+1)*((I2+1)*M2+2)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO L=0,M2 - DO N=L,I2*L+M2 - KS2=L*(2*M2+(I2-1)*(L-1))+2*N - IF(L.LE.M1.AND.N.LE.I1*L+M1) THEN - KS1=L*(2*M1+(I1-1)*(L-1))+2*N - Q2(KS2+1)=Q1(KS1+1) - Q2(KS2+2)=Q1(KS1+2) - ELSE - Q2(KS2+1)=0 - Q2(KS2+2)=0 - ENDIF - ENDDO - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END SUBROUTINE SPPAD - SUBROUTINE SPECSETS(H,D,IDRT) -!----------------------------------------------------------------------- -!$$$ Subprogram documentation block -! -! Subprogram: specsets Create special tracer sets -! Prgmmr: Iredell Org: W/NP23 Date: 2004-09-24 -! -! Abstract: This subprogram optionally augments the tracers -! in the global model initial conditions if special tracer set -! are requested, based on the value of the tracer variable ID. -! -! Program history log: -! 2004-09-24 Iredell -! -! Modules used: -! sigio_module global model sigma file types and I/O -! -! Usage: call specsets(h,d,idrt) -! Input arguments: -! h type(sigio_head) sigma file header -! ak -! bk -! idsl -! idvc -! idvt -! jcap -! latb -! levs -! lonb -! ntrac -! si -! d type(sigio_data) sigma file data -! hs -! ps -! t -! d -! z -! q -! -! Output arguments: -! d type(sigio_data) sigma file data -! q -! -! Attributes: -! Language: Fortran90 -! -! Remarks: -! Pertinent values of h%idvt and h%ntrac -! idvt ntrac -! 100 20 set 1: vapor,ozone,cloud, and initial values of -! clat*clon,clat*slon,slat, -! v*slon-u*slat*clon,-v*clon-u*slat*slon,u*clat -! one,k,sigma,ps,pres,temp,entropy,moist entropy -! vapor,ozone,cloud -! -!C$$$ - use sigio_module - implicit none - type(sigio_head),intent(in):: h - type(sigio_dbta),intent(inout):: d - integer, intent(in) :: idrt - real,dimension(h%latb):: slat,wlat - real,dimension(h%lonb,h%latb):: hs,ps - real,dimension(h%lonb,h%latb,h%levs):: pm,pd - real,dimension(h%lonb,h%latb,h%levs):: t,u,v - real,dimension(h%lonb,h%latb,h%levs,h%ntrac):: q - real clat,rlon - real, allocatable :: vcoord(:,:) - - integer i,j,k,iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call splat(idrt,h%latb,slat,wlat) - call sptez(0,h%jcap,idrt,h%lonb,h%latb,d%hs,hs,+1) - call sptez(0,h%jcap,idrt,h%lonb,h%latb,d%ps,ps,+1) - call sptezm(0,h%jcap,idrt,h%lonb,h%latb,h%levs,d%t,t,+1) - call sptezmv(0,h%jcap,idrt,h%lonb,h%latb,h%levs,d%d,d%z,u,v,+1) - call sptezm(0,h%jcap,idrt,h%lonb,h%latb,h%levs*3,d%q,q,+1) - ps=1.e3*exp(ps) - t=t/(1.+(461.50/287.05-1)*q(:,:,:,1)) - allocate(vcoord(h%levs+1,h%nvcoord)) - vcoord = h%vcoord - call sigio_modprd(h%lonb*h%latb,h%lonb*h%latb,h%levs,h%nvcoord, & - h%idvc,h%idsl,vcoord,iret, & - ps=ps,t=t,pm=pm,pd=pd) - deallocate (vcoord) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(h%idvt==100.and.h%ntrac==20) then -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(i,j,clat,rlon,k) - do j=1,h%latb - clat=sqrt(1-slat(j)**2) - do i=1,h%lonb - rlon=2*acos(-1.)*(i-1)/h%lonb - q(i,j,:,4)=clat*cos(rlon) - q(i,j,:,5)=clat*sin(rlon) - q(i,j,:,6)=slat(j) - q(i,j,:,7)=v(i,j,:)*sin(rlon)-u(i,j,:)*slat(j)*cos(rlon) - q(i,j,:,8)=-v(i,j,:)*cos(rlon)-u(i,j,:)*slat(j)*sin(rlon) - q(i,j,:,9)=u(i,j,:)*clat - q(i,j,:,10)=1 - q(i,j,:,11)=(/(k,k=1,h%levs)/) - q(i,j,:,12)=pm(i,j,:)/ps(i,j) - q(i,j,:,13)=ps(i,j) - q(i,j,:,14)=pm(i,j,:) - q(i,j,:,15)=t(i,j,:) - call dothe(1,1,h%levs,pm(i,j,:),t(i,j,:),q(i,j,:,1), & - q(i,j,:,16),q(i,j,:,17)) - q(i,j,:,16)=1004.6*log(q(i,j,:,16)/273.15) - q(i,j,:,17)=1004.6*log(q(i,j,:,17)/273.15) - q(i,j,:,18)=q(i,j,:,1) - q(i,j,:,19)=q(i,j,:,2) - q(i,j,:,20)=q(i,j,:,3) - enddo - enddo -!$OMP END PARALLEL DO - call sptezm(0,h%jcap,idrt,h%lonb,h%latb,h%levs*(h%ntrac-3), & - d%q(1,1,4),q(1,1,1,4),-1) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine specsets -!----------------------------------------------------------------------- - subroutine dothe(im,ix,km,p,t,q,th,the) - use physcons - use funcphys - implicit none - integer,intent(in):: im,ix,km - real,intent(in):: p(ix,km),t(ix,km),q(ix,km) - real,intent(out):: th(ix,km),the(ix,km) - integer i,k - real(krealfp) pr,tr,qr - real(krealfp) qminr,elr,pvr,tdpdr,tlclr,pklclr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! potential temperature - do k=1,km - do i=1,im - pr=p(i,k) - tr=t(i,k) - th(i,k)=tr/fpkapx(pr) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! equivalent potential temperature - qminr=1.e-6 - do k=1,km - do i=1,im - pr=p(i,k) - tr=t(i,k) - qr=q(i,k) - if(qr.lt.qminr) then - elr=con_hvap+con_dldt*(tr-con_ttp) - elr=elr*exp(-con_dldt/con_cp*(qminr-qr)) - tr=(elr-con_hvap)/con_dldt+con_ttp - qr=qminr - endif - pvr=pr*qr/(con_eps-con_epsm1*qr) - tdpdr=tr-ftdpx(pvr) - tlclr=ftlclx(tr,tdpdr) - pklclr=fpkapx(pr)*tlclr/tr - the(i,k)=fthex(tlclr,pklclr) - enddo - enddo - end subroutine dothe -!----------------------------------------------------------------------- - SUBROUTINE NEWPR1(IM,IX,KM,KMP,IDVC,IDVM,IDSL,NVCOORD,VCOORD, & - & RI, CPI, NTRACM,PP,TP,QP,PS,PM) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: NEWPR1 COMPUTE MODEL PRESSURES -! PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 -! PRGMMR: Fanglin Yang ORG: W/NMC23 DATE: 2006-11-28 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2006-12-12 -! PRGMMR: S. Moorthi ORG: NCEP/EMC DATE: 2007-01-02 -! -! ABSTRACT: COMPUTE MODEL PRESSURES. -! -! PROGRAM HISTORY LOG: -! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- -! -! USAGE: CALL NEWPR1(IM,IX,KM,KMP,IDVC,IDSL,NVCOORD,VCOORD,PP,TP,QP,P -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! IX INTEGER FIRST DIMENSION -! KM INTEGER NUMBER OF LEVELS -! KMP INTEGER NUMBER OF OLD LEVELS -! IDVC INTEGER VERTICAL COORDINATE ID -! (1 FOR SIGMA AND 2 FOR HYBRID) -! IDSL INTEGER TYPE OF SIGMA STRUCTURE -! (1 FOR PHILLIPS OR 2 FOR MEAN) -! NVCOORD INTEGER NUMBER OF VERTICAL COORDINATES -! VCOORD REAL (KM+1,NVCOORD) VERTICAL COORDINATE VALUES -! FOR IDVC=1, NVCOORD=1: SIGMA INTERFACE -! FOR IDVC=2, NVCOORD=2: HYBRID INTERFACE A AND B -! FOR IDVC=3, NVCOORD=3: JUANG GENERAL HYBRID INTERFACE -! AK REAL (KM+1) HYBRID INTERFACE A -! BK REAL (KM+1) HYBRID INTERFACE B -! CK REAL (KM+1) HYBRID INTERFACE C -! PP REAL (IX,KM) OLD PRESSURE -! TP REAL (IX,KM) OLD TEMPERATURE -! QP REAL (IX,KM) OLD SPECIFIC HUMIDITY -! PS REAL (IX) SURFACE PRESSURE (PA) -! OUTPUT ARGUMENT LIST: -! PM REAL (IX,KM) MID-LAYER PRESSURE (PA) -! DP REAL (IX,KM) LAYER DELTA PRESSURE (PA) -! TEMPORARY -! PI REAL (IX,KM+1) INTERFACE PRESSURE (PA) -! SI REAL (KM+1) SIGMA INTERFACE VALUES (IDVC=1) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - REAL, PARAMETER :: RD=287.05, RV=461.50, CP=1004.6, & - ROCP=RD/CP, ROCP1=ROCP+1, ROCPR=1/ROCP, & - FV=RV/RD-1. - integer im, ix, km, kmp, idvc, idvm, idsl, nvcoord, ntracm - real ri(0:ntracm), cpi(0:ntracm) - REAL SI(KM+1),AK(KM+1),BK(KM+1),CK(KM+1) - REAL VCOORD(KM+1,NVCOORD) - REAL PS(IX),PI(IX,KM+1),PM(IX,KM) -! REAL DP(IX,KM) - REAL PP(IX,KMP),TP(IX,KMP),QP(IX,KMP,NTRACM) - REAL PO(KMP),TO(KMP),QO(KMP,ntracm) - REAL PN(KM ),TN(KM ),QN(KM,ntracm ), AKBKPS(KM) - REAL TOV(KM),TRK,PIO(KM+1) -! - real xcp, sumq, xcp2, sumq2, temu, temd, converg, dpmin, & - dpminall, tvu, tvd, tem, tem1, cp0i, qnk - integer sfcpress_id, thermodyn_id, i, k, n, nit -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sfcpress_id = mod(IDVM,1) - thermodyn_id = mod(IDVM/10,10) - ! hmhj for s-t - IF(IDVC.EQ.3) THEN - DO K=1,KM - AK(K) = VCOORD(K,1) - BK(K) = VCOORD(K,2) - CK(K) = VCOORD(K,3) - TOV(K) = 300.0 - ENDDO - PI(1:IM,1) = PS(1:IM) - PI(1:IM,KM+1) = 0.0 -! -! first guess : assume KMP=KM -! - if (thermodyn_id <= 1) then -!!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(KM,kmp,IM) -!!$OMP+ SHARED(qn,qp,TOV,PI,AK,BK,PS,CK) -!$omp parallel do shared(km,kmp,im,qp,tp,tov,pi,ak,bk,ck) , & -!$omp& private(i,k,tem,qnk,trk) - DO K=2,KM - tem = float(k-1) / float(kmp-1) - DO I=1,IM - qnk = qp(i,1,1) + (qp(i,kmp,1)-qp(i,1,1))*TEM - TRK = (TP(I,K)*(1.0+FV*QNK)/TOV(K)) ** ROCPR - ! p at interface - PI(I,K) = AK(K) + BK(K)*PS(I) + CK(K)*TRK - ENDDO - ENDDO -!!$OMP END PARALLEL DO - elseif (thermodyn_id == 3) then - cp0i = 1.0 / cpi(0) - DO K=2,KM - tem = float(k-1) / float(kmp-1) - DO I=1,IM - xcp = 0.0 - sumq = 0.0 - do n=1,NTRACM - qn(k,n) = qp(i,1,n) + (qp(i,kmp,n)-qp(i,1,n))*TEM - if( cpi(n).ne.0.0 ) then - xcp = xcp + cpi(n)*qn(k,n) - sumq = sumq + qn(k,n) - endif - enddo - xcp = (1.-sumq) + xcp * cp0i - tem1 = tp(i,1) + (tp(i,kmp)-tp(i,1))*tem - trk = (tem1*xcp/tov(k)) ** ROCPR - ! p at interface - PI(I,K) = AK(K) + BK(K)*PS(I) + CK(K)*TRK - enddo - enddo - endif - - DPMINALL=1000.0 -!$omp parallel do & -!$omp& shared(im,km,kmp,ntracm,thermodyn_id,pp,tp,qp,cpi,cp0i) , & -!$omp& shared(ak,bk,ck,pi) ,& -!$omp& private(i,k,nit,converg,dpmin,tvu,tvd,trk) ,& -!$omp& private(pio,po,to,qo,pn,tn,qn,akbkps) ,& -!$omp& private(xcp,xcp2,sumq,sumq2,temu,temd) -! - DO I=1,IM - DO K=1,KMP - PO(K) = PP(I,K) - TO(K) = TP(I,K) - QO(K,:) = QP(I,K,:) - ENDDO - do k=2,km - akbkps(k) = ak(k) + bk(k)*ps(i) - enddo -! iteration - ! default number of iterations - DO Nit=1,400 - CONVERG = 0.0 - DPMIN = 1000.0 - DO K=1,KM+1 - PIO(K) = PI(I,K) - ENDDO - DO K=1,KM - PN(K) = 0.5*(PIO(K)+PIO(K+1)) - ENDDO -! do interpolation by the intrinsic method to get TN and QN - if (thermodyn_id <= 1) then - CALL VINTTQ(KMP,KM,PO,TO,QO(1,1),PN,TN,QN(1,1)) - DO K=2,KM - TVU = TN(K )*(1.0+FV*QN(K,1)) - TVD = TN(K-1)*(1.0+FV*QN(K-1,1)) - TRK = ((TVD+TVU)/(TOV(K-1)+TOV(K))) ** ROCPR - PI(I,K) = AKBKPS(K) + CK(K)*TRK - CONVERG = MAX(CONVERG,ABS(PI(I,K)-PIO(K)) & - /(PI(I,K)+PIO(K))) - ! make it converged faster - PI(I,K) = 0.5*(PI(I,K)+PIO(K)) - DPMIN = MIN(DPMIN,PI(I,K-1)-PI(I,K)) - ENDDO - elseif (thermodyn_id == 3) then - CALL VINTTR(1,1,KMP,KM,NTRACM,PO,TO,QO,PN,TN,QN) - DO K=2,KM - xcp = 0.0 - xcp2 = 0.0 - sumq = 0.0 - sumq2 = 0.0 - do n=1,NTRACM - if( cpi(n).ne.0.0 ) then - xcp = xcp + cpi(n)*qn(k,n) - sumq = sumq + qn(k,n) - xcp2 = xcp2 + cpi(n)*qn(k-1,n) - sumq2 = sumq2 + qn(k-1,n) - endif - enddo - temu = (1.-sumq) + xcp*cp0i - temd = (1.-sumq2) + xcp2*cp0i - trk = ((tn(k)*temu + tn(k-1)*temd) & - / (TOV(K) + TOV(K-1))) ** ROCPR - PI(I,K) = AKBKPS(K) + CK(K)*TRK - CONVERG = MAX(CONVERG,ABS(PI(I,K)-PIO(K)) & - /(PI(I,K)+PIO(K))) - ! make it converged f - PI(I,K) = 0.5*(PI(I,K)+PIO(K)) - DPMIN = MIN(DPMIN,PI(I,K-1)-PI(I,K)) - ENDDO -! if (i .eq. 1) print *,' converg=',converg,' nit=',nit - endif - IF( CONVERG.LE.1.E-6 ) GOTO 100 - ENDDO - 100 CONTINUE -! PRINT *,'I=',I,' CONVERGED AT',Nit,' ITERATIONS',' DPMIN=' -! &, DPMIN - DPMINALL = MIN(DPMINALL,DPMIN) - ENDDO -!!$OMP END PARALLEL DO -! PRINT *,' ---- THE MINIMUM DP FOR A GROUP IS ',DPMINALL - ELSE IF(IDVC.EQ.2) THEN - DO K=1,KM+1 - AK(K) = VCOORD(K,1) - BK(K) = VCOORD(K,2) - PI(1:IM,K) = AK(K) + BK(K)*PS(1:IM) - ENDDO - ELSE - DO K=1,KM+1 - SI(K) = VCOORD(K,1) - PI(1:IM,K) = SI(K)*PS(1:IM) - ENDDO - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IDSL.EQ.2) THEN - DO K=1,KM - PM(1:IM,K) = (PI(1:IM,K)+PI(1:IM,K+1))/2 - ENDDO - ELSE -!$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(KM,PM,IM,PI) - DO K=1,KM - PM(1:IM,K) = ((PI(1:IM,K)**ROCP1-PI(1:IM,K+1)**ROCP1)/ & - (ROCP1*(PI(1:IM,K)-PI(1:IM,K+1))))**ROCPR - ENDDO -!$OMP END PARALLEL DO - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! DO K=1,KM -! DO I=1,IM -! DP(I,K) = PI(I,K) - PI(I,K+1) -! ENDDO -! ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE NEWPR1 -!----------------------------------------------------------------------- - SUBROUTINE CHECKDP(IM,IX,KM,AK,BK,CK,PS,TP,QP) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: CHECKDP COMPUTE MODEL PRESSURES -! PRGMMR: JUANG ORG: W/NMC23 DATE: 2005-04-11 -! -! ABSTRACT: CHECK THICKNESS FOR SIGMA-THETA COORDINATE -! -! PROGRAM HISTORY LOG: -! 2005-04-11 HANN_MING HENRY JUANG hybrid sigma, sigma-p, and sigma- -! -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! IX INTEGER FIRST DIMENSION -! KM INTEGER NUMBER OF LEVELS -! AK REAL (KM+1) HYBRID INTERFACE A -! BK REAL (KM+1) HYBRID INTERFACE B -! CK REAL (KM+1) HYBRID INTERFACE C -! TP REAL (IX,KM) OLD TEMPERATURE -! QP REAL (IX,KM) OLD SPECIFIC HUMIDITY -! PS REAL (IX) SURFACE PRESSURE (PA) -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IX,KM - REAL,PARAMETER :: RD=287.05,RV=461.50,CP=1004.6 - REAL,PARAMETER :: ROCP=RD/CP,ROCP1=ROCP+1,ROCPR=1./ROCP, & - FV=RV/RD-1. - REAL AK(KM+1),BK(KM+1),CK(KM+1),PS(IX) - REAL TP(IX,KM),QP(IX,KM),PI(IM,KM+1) - REAL TOV(KM),TRK,TVU,TVD - INTEGER K,I,KMIN - REAL DPMIN,FTV,AT,AQ -! - FTV(AT,AQ)=AT*(1+FV*AQ) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO K=1,KM - TOV(K) = 300.0 - ENDDO - PI(1:IM,1)=PS(1:IM) - PI(1:IM,KM+1)=0.0 -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(K,I,TVU,TVD,TRK) - DO K=2,KM - DO I=1,IM - TVU=FTV(TP(I,K ),QP(I,K )) - TVD=FTV(TP(I,K-1),QP(I,K-1)) - TRK = (TVD+TVU)/(TOV(K-1)+TOV(K)) - TRK = TRK ** ROCPR - PI(I,K)=AK(K)+BK(K)*PS(I)+CK(K)*TRK - ENDDO - ENDDO -!$OMP END PARALLEL DO - - DO I=1,IM - DPMIN=1000. - DO K=1,KM - IF( PI(I,K)-PI(I,K+1) .LT. DPMIN ) THEN - KMIN=K - DPMIN=PI(I,K)-PI(I,K+1) - ENDIF - ENDDO - IF( DPMIN.LT.0.0 )PRINT *,' I KMIN DPMIN ',I,KMIN,DPMIN - ENDDO - RETURN - END SUBROUTINE CHECKDP -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE VINTTQ(KM1,KM2,P1,T1,Q1,P2,T2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTTQ VERTICALLY INTERPOLATE UPPER-AIR T AND Q -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 1991-10-31 MARK IREDELL -! 2005-08-31 Henry JUANG MODIFIED IT TO DO T AND Q FROM VINTG -! -! USAGE: CALL VINTTQ(IM,IX,KM1,KM2,P1,T1,Q1,P2,T2,Q2) -! INPUT ARGUMENT LIST: -! KM1 INTEGER NUMBER OF INPUT LEVELS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! P1 REAL (IX,KM1) INPUT PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! T1 REAL (IX,KM1) INPUT TEMPERATURE (K) -! Q1 REAL (IX,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) -! P2 REAL (IX,KM2) OUTPUT PRESSURES -! OUTPUT ARGUMENT LIST: -! T2 REAL (IX,KM2) OUTPUT TEMPERATURE (K) -! Q2 REAL (IX,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) -! -! SUBPROGRAMS CALLED: -! TERP3_HJ CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER KM1,KM2 - REAL P1(KM1),T1(KM1),Q1(KM1) - REAL P2(KM2),T2(KM2),Q2(KM2) - REAL,PARAMETER :: DLTDZ=-6.5E-3*287.05/9.80665 - REAL,PARAMETER :: DLPVDRT=-2.5E6/461.50 - REAL Z1(2,KM1),Z2(2,KM2) - REAL C1(2,KM1,2),C2(2,KM2,2) - INTEGER K - REAL DZ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE -! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(K) - DO K=1,KM1 - Z1(1,K)=-LOG(P1(K)) - C1(1,K,1)=T1(K) - C1(1,K,2)=Q1(K) - ENDDO -!$OMP END PARALLEL DO -!$OMP PARALLEL DO DEFAULT(SHARED), & -!$OMP& PRIVATE(K) - DO K=1,KM2 - Z2(1,K)=-LOG(P2(K)) - ENDDO -!$OMP END PARALLEL DO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION -! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS -! AND 1ST-ORDER FOR EXTRAPOLATION. - CALL TERP3_HJ(1,1,1,1,1,2,2*KM1,2*KM2, & - KM1,2,2,Z1,C1,KM2,2,2,Z2,C2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED -! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. - DO K=1,KM2 - DZ=Z2(1,K)-Z1(1,1) - IF(DZ.GE.0) THEN - T2(K)=C2(1,K,1) - Q2(K)=C2(1,K,2) - ELSE - T2(K)=T1(1)*EXP(DLTDZ*DZ) - Q2(K)=Q1(1)*EXP(DLPVDRT*(1/T2(K)-1/T1(1))-DZ) - ENDIF - ENDDO - END SUBROUTINE VINTTQ -!----------------------------------------------------------------------- - SUBROUTINE TERP3_HJ(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, & - KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: TERP3_HJ CUBICALLY INTERPOLATE IN ONE DIMENSION -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 98-05-01 -! -! ABSTRACT: INTERPOLATE FIELD(S) IN ONE DIMENSION ALONG THE COLUMN(S). -! THE INTERPOLATION IS CUBIC LAGRANGIAN WITH A MONOTONIC CONSTRAINT -! IN THE CENTER OF THE DOMAIN. IN THE OUTER INTERVALS IT IS LINEAR. -! OUTSIDE THE DOMAIN, FIELDS ARE HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 98-05-01 MARK IREDELL -! 1999-01-04 IREDELL USE ESSL SEARCH -! 2006-11-10 SIMPLIFIED VERSION OF TERP3 -! -! USAGE: CALL TERP3_HJ(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, -! & KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF COLUMNS -! IXZ1 INTEGER COLUMN SKIP NUMBER FOR Z1 -! IXQ1 INTEGER COLUMN SKIP NUMBER FOR Q1 -! IXZ2 INTEGER COLUMN SKIP NUMBER FOR Z2 -! IXQ2 INTEGER COLUMN SKIP NUMBER FOR Q2 -! NM INTEGER NUMBER OF FIELDS PER COLUMN -! NXQ1 INTEGER FIELD SKIP NUMBER FOR Q1 -! NXQ2 INTEGER FIELD SKIP NUMBER FOR Q2 -! KM1 INTEGER NUMBER OF INPUT POINTS -! KXZ1 INTEGER POINT SKIP NUMBER FOR Z1 -! KXQ1 INTEGER POINT SKIP NUMBER FOR Q1 -! Z1 REAL (1+(IM-1)*IXZ1+(KM1-1)*KXZ1) -! INPUT COORDINATE VALUES IN WHICH TO INTERPOLATE -! (Z1 MUST BE STRICTLY MONOTONIC IN EITHER DIRECTION) -! Q1 REAL (1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) -! INPUT FIELDS TO INTERPOLATE -! KM2 INTEGER NUMBER OF OUTPUT POINTS -! KXZ2 INTEGER POINT SKIP NUMBER FOR Z2 -! KXQ2 INTEGER POINT SKIP NUMBER FOR Q2 -! Z2 REAL (1+(IM-1)*IXZ2+(KM2-1)*KXZ2) -! OUTPUT COORDINATE VALUES TO WHICH TO INTERPOLATE -! (Z2 NEED NOT BE MONOTONIC) -! -! OUTPUT ARGUMENT LIST: -! Q2 REAL (1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) -! OUTPUT INTERPOLATED FIELDS -! -! SUBPROGRAMS CALLED: -! RSEARCH SEARCH FOR A SURROUNDING REAL INTERVAL -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2,KM1,KXZ1,KXQ1, & - KM2,KXZ2,KXQ2 - REAL Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1) - REAL Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1) - REAL Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2) - REAL Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2) - REAL FFA(IM),FFB(IM),FFC(IM),FFD(IM) - INTEGER K1S(IM,KM2) - REAL Q2S,Q1A,Q1B,Q1C,Q1D,Z2S,Z1A,Z1B,Z1C,Z1D - INTEGER I,K1,K2,N -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! FIND THE SURROUNDING INPUT INTERVAL FOR EACH OUTPUT POINT. - CALL RSEARCH(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,1,IM,K1S) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! GENERALLY INTERPOLATE CUBICALLY WITH MONOTONIC CONSTRAINT -! FROM TWO NEAREST INPUT POINTS ON EITHER SIDE OF THE OUTPUT POINT, -! BUT WITHIN THE TWO EDGE INTERVALS INTERPOLATE LINEARLY. -! KEEP THE OUTPUT FIELDS CONSTANT OUTSIDE THE INPUT DOMAIN. - DO K2=1,KM2 - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A) - ELSEIF(K1.GT.1.AND.K1.LT.KM1-1) THEN - Z2S=Z2(1+(I-1)*IXZ2+(K2-1)*KXZ2) - Z1A=Z1(1+(I-1)*IXZ1+(K1-2)*KXZ1) - Z1B=Z1(1+(I-1)*IXZ1+(K1-1)*KXZ1) - Z1C=Z1(1+(I-1)*IXZ1+(K1+0)*KXZ1) - Z1D=Z1(1+(I-1)*IXZ1+(K1+1)*KXZ1) - FFA(I)=(Z2S-Z1B)/(Z1A-Z1B)* & - (Z2S-Z1C)/(Z1A-Z1C)* & - (Z2S-Z1D)/(Z1A-Z1D) - FFB(I)=(Z2S-Z1A)/(Z1B-Z1A)* & - (Z2S-Z1C)/(Z1B-Z1C)* & - (Z2S-Z1D)/(Z1B-Z1D) - FFC(I)=(Z2S-Z1A)/(Z1C-Z1A)* & - (Z2S-Z1B)/(Z1C-Z1B)* & - (Z2S-Z1D)/(Z1C-Z1D) - FFD(I)=(Z2S-Z1A)/(Z1D-Z1A)* & - (Z2S-Z1B)/(Z1D-Z1B)* & - (Z2S-Z1C)/(Z1D-Z1C) - ENDIF - ENDDO -! INTERPOLATE. - DO N=1,NM - DO I=1,IM - K1=K1S(I,K2) - IF(K1.EQ.0) THEN - Q2S=Q1(1+(I-1)*IXQ1+(N-1)*NXQ1) - ELSEIF(K1.EQ.KM1) THEN - Q2S=Q1(1+(I-1)*IXQ1+(KM1-1)*KXQ1+(N-1)*NXQ1) - ELSEIF(K1.EQ.1.OR.K1.EQ.KM1-1) THEN - Q1A=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q2S=FFA(I)*Q1A+FFB(I)*Q1B - ELSE - Q1A=Q1(1+(I-1)*IXQ1+(K1-2)*KXQ1+(N-1)*NXQ1) - Q1B=Q1(1+(I-1)*IXQ1+(K1-1)*KXQ1+(N-1)*NXQ1) - Q1C=Q1(1+(I-1)*IXQ1+(K1+0)*KXQ1+(N-1)*NXQ1) - Q1D=Q1(1+(I-1)*IXQ1+(K1+1)*KXQ1+(N-1)*NXQ1) - Q2S=MIN(MAX( & - FFA(I)*Q1A+FFB(I)*Q1B+FFC(I)*Q1C+FFD(I)*Q1D, & - MIN(Q1B,Q1C)),MAX(Q1B,Q1C)) - ENDIF - Q2(1+(I-1)*IXQ2+(K2-1)*KXQ2+(N-1)*NXQ2)=Q2S - ENDDO - ENDDO - ENDDO -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE TERP3_HJ -!----------------------------------------------------------------------- - SUBROUTINE VINTTR(IM,IX,KM1,KM2,NT,P1,T1,Q1,P2,T2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: VINTG VERTICALLY INTERPOLATE UPPER-AIR FIELDS -! PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -! PRGMMR: S. MOORTHI ORG: NCEP/EMC DATE: 2006-12-12 -! -! ABSTRACT: VERTICALLY INTERPOLATE UPPER-AIR FIELDS. -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS ARE INTERPOLATED. -! THE INTERPOLATION IS CUBIC LAGRANGIAN IN LOG PRESSURE -! WITH A MONOTONIC CONSTRAINT IN THE CENTER OF THE DOMAIN. -! IN THE OUTER INTERVALS IT IS LINEAR IN LOG PRESSURE. -! OUTSIDE THE DOMAIN, FIELDS ARE GENERALLY HELD CONSTANT, -! EXCEPT FOR TEMPERATURE AND HUMIDITY BELOW THE INPUT DOMAIN, -! WHERE THE TEMPERATURE LAPSE RATE IS HELD FIXED AT -6.5 K/KM AND -! THE RELATIVE HUMIDITY IS HELD CONSTANT. -! -! PROGRAM HISTORY LOG: -! 91-10-31 MARK IREDELL -! -! USAGE: CALL VINTTR(IM,IX,KM1,KM2,NT,P1,T1,Q1,P2,T2,Q2) -! INPUT ARGUMENT LIST: -! IM INTEGER NUMBER OF POINTS TO COMPUTE -! IX INTEGER FIRST DIMENSION -! KM1 INTEGER NUMBER OF INPUT LEVELS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! NT INTEGER NUMBER OF TRACERS -! P1 REAL (IX,KM1) INPUT PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! T1 REAL (IX,KM1) INPUT TEMPERATURE (K) -! Q1 REAL (IX,KM1,NT) INPUT TRACERS (HUMIDITY FIRST) -! P2 REAL (IX,KM2) OUTPUT PRESSURES -! OUTPUT ARGUMENT LIST: -! T2 REAL (IX,KM2) OUTPUT TEMPERATURE (K) -! Q2 REAL (IX,KM2,NT) OUTPUT TRACERS (HUMIDITY FIRST) -! -! SUBPROGRAMS CALLED: -! TERP3 CUBICALLY INTERPOLATE IN ONE DIMENSION -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER IM,IX,KM1,KM2,NT - REAL P1(IX,KM1),T1(IX,KM1),Q1(IX,KM1,NT) - REAL P2(IX,KM2),T2(IX,KM2),Q2(IX,KM2,NT) - REAL,PARAMETER :: DLTDZ=-6.5E-3*287.05/9.80665 - REAL,PARAMETER :: DLPVDRT=-2.5E6/461.50 - REAL Z1(IM+1,KM1),Z2(IM+1,KM2) - REAL C1(IM+1,KM1,1+NT),C2(IM+1,KM2,1+NT),J2(IM+1,KM2,1+NT) - INTEGER I,N,K - REAL DZ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COMPUTE LOG PRESSURE INTERPOLATING COORDINATE -! AND COPY INPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS - -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(K,I) - DO K=1,KM1 - DO I=1,IM - Z1(I,K)=-LOG(P1(I,K)) - C1(I,K,1)=T1(I,K) - C1(I,K,2)=Q1(I,K,1) - ENDDO - ENDDO -!$OMP END PARALLEL DO - DO N=2,NT - DO K=1,KM1 - DO I=1,IM - C1(I,K,1+N)=Q1(I,K,N) - ENDDO - ENDDO - ENDDO -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(K,I) - DO K=1,KM2 - DO I=1,IM - Z2(I,K)=-LOG(P2(I,K)) - ENDDO - ENDDO -!$OMP END PARALLEL DO - -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! PERFORM LAGRANGIAN ONE-DIMENSIONAL INTERPOLATION -! THAT IS 4TH-ORDER IN INTERIOR, 2ND-ORDER IN OUTSIDE INTERVALS -! AND 1ST-ORDER FOR EXTRAPOLATION. - CALL TERP3(IM,1,1,1,1,1+NT,(IM+1)*KM1,(IM+1)*KM2, & - KM1,IM+1,IM+1,Z1,C1,KM2,IM+1,IM+1,Z2,C2,J2) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! COPY OUTPUT WIND, TEMPERATURE, HUMIDITY AND OTHER TRACERS -! EXCEPT BELOW THE INPUT DOMAIN, LET TEMPERATURE INCREASE WITH A FIXED -! LAPSE RATE AND LET THE RELATIVE HUMIDITY REMAIN CONSTANT. - DO K=1,KM2 -! print *,' p2=',p2(1,k),' k=',k -! print *,' J2=',j2(1,k,3),' k=',k - DO I=1,IM - DZ=Z2(I,K)-Z1(I,1) - IF(DZ.GE.0) THEN - T2(I,K)=C2(I,K,1) - Q2(I,K,1)=C2(I,K,2) - ELSE - T2(I,K)=T1(I,1)*EXP(DLTDZ*DZ) - Q2(I,K,1)=Q1(I,1,1)*EXP(DLPVDRT*(1/T2(I,K)-1/T1(I,1))-DZ) - ENDIF - ENDDO - ENDDO - DO N=2,NT - DO K=1,KM2 - DO I=1,IM - Q2(I,K,N)=C2(I,K,1+N) - ENDDO - ENDDO - ENDDO - END SUBROUTINE VINTTR - -!----------------------------------------------------------------------- - subroutine getomega(jcap,nc,km,idvc,idvm,idrt,idsl,nvcoord, & - vcoord,lonb,latb,ijl,ijn,j1,j2,jc,sd,sps,psi,ti,ui,vi,wi) - use sigio_module, only : sigio_modprd - implicit none -! - integer,intent(in):: jcap,nc,km,idvc,idvm,idrt,idsl,nvcoord - integer,intent(in):: lonb,latb,ijl,j1,j2,jc,ijn - real,intent(in):: vcoord(km+1,nvcoord) - real,intent(in):: sd(nc,km),sps(nc) - real,intent(in):: psi(ijn),ti(ijn,km),ui(ijn,km),vi(ijn,km) - real,intent(out):: wi(ijn,km) - real :: pd(ijn,km),pi(ijn,km+1),pm(ijn,km) - real :: os - real dpmdps(ijn,km),dpddps(ijn,km),dpidps(ijn,km+1),vgradp,psmean - real di(ijn,km),psx(ijn),psy(ijn) - integer k,i,ij,lonb2,in,is,iret -!----1. spectral transform - lonb2=lonb*2 - ij=lonb2*(j2-j1+1) - in=1 - is=1+lonb - call sptrand(0,jcap,idrt,lonb,latb,1,1,1,lonb2,lonb2,nc,ijn, & - j1,j2,jc,sps,psmean, & - psx(in),psx(is),psy(in),psy(is),1) - SELECT CASE(MOD(IDVM,10)) - CASE(0,1) - continue - CASE(2) -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(i) - do i=1,ijn - psx(i)=psx(i)/(psi(i)*1.0E-3) - psy(i)=psy(i)/(psi(i)*1.0E-3) - enddo -!$OMP END PARALLEL DO - CASE DEFAULT -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(i) - do i=1,ijn - psx(i)=psx(i)/psi(i) - psy(i)=psy(i)/psi(i) - enddo -!$OMP END PARALLEL DO - END SELECT - -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(K) - do K=1,km - call sptran(0,jcap,idrt,lonb,latb,1,1,1,lonb2,lonb2,nc,ijn, & - j1,j2,jc,sd(1,k),di(in,k),di(is,k),1) - enddo -!$OMP END PARALLEL DO - - call sigio_modprd(ijl,ijn,km,nvcoord,idvc,idsl,vcoord,iret, & - ps=psi,t=ti,pm=pm,pd=pd,dpmdps=dpmdps,dpddps=dpddps) - -!----3.omeda from modstuff -!$OMP PARALLEL DO DEFAULT(SHARED) , & -!$OMP& PRIVATE(i) - do i=1,ijl - pi(i,1)=psi(i) - dpidps(i,1)=1. - do k=1,km - pi(i,k+1)=pi(i,k)-pd(i,k) - dpidps(i,k+1)=dpidps(i,k)-dpddps(i,k) - enddo - os=0. - do k=km,1,-1 - vgradp=ui(i,k)*psx(i)+vi(i,k)*psy(i) - os=os-vgradp*psi(i)*(dpmdps(i,k)-dpidps(i,k+1))- & - di(i,k)*(pm(i,k)-pi(i,k+1)) - wi(i,k)=vgradp*psi(i)*dpmdps(i,k)+os - os=os-vgradp*psi(i)*(dpidps(i,k)-dpmdps(i,k))- & - di(i,k)*(pi(i,k)-pm(i,k)) - enddo -! - enddo -!$OMP END PARALLEL DO - return - end subroutine getomega - subroutine sptrrj(imax,lonsperlat,grid,gred,idir) - implicit none - integer,intent(in):: imax,lonsperlat,idir - real,intent(inout):: grid(imax),gred(imax) - real four(imax+2),gour(lonsperlat) - integer i,iour - real rred - - rred = lonsperlat/real(imax) - four = 0 -!! take transformed to full 'grid' and make it like transformed to reduc - if(idir > 0) then - call spfft1(imax,imax/2+1,imax,1,four,grid,-idir) - call spfft1(lonsperlat,imax/2+1,imax,1,four,gour,idir) - do i=1,imax - iour = nint((i-1)*rred)+1 - if(iour == lonsperlat+1) iour =1 - gred(i) = gour(iour) - enddo -!! take transformed to reduced and interpolated 'gred' and make it like - elseif(idir < 0) then - do iour=1,lonsperlat - i = nint((iour-1)/rred)+1 - if(i == imax+1) i = 1 - gour(iour) = gred(i) - enddo - call spfft1(lonsperlat,imax/2+1,imax,1,four,gour,idir) - call spfft1(imax,imax/2+1,imax,1,four,grid,-idir) - endif - end subroutine sptrrj - subroutine compute_zh(im, jm, levp, ak_in, bk_in, ps, zs, t, sphum, zh) - implicit none - integer, intent(in):: levp, im,jm - real, intent(in), dimension(levp+1):: ak_in, bk_in - real, intent(in), dimension(im,jm):: ps, zs - real, intent(in), dimension(im,jm,levp):: t - real, intent(in), dimension(im,jm,levp):: sphum - real, intent(out), dimension(im,jm,levp+1):: zh - ! Local: - real, dimension(im,levp+1):: pe0, pn0 - real, dimension(levp+1) :: ak, bk - integer i,j,k - real, parameter :: GRAV = 9.80665 - real, parameter :: RDGAS = 287.05 - real, parameter :: RVGAS = 461.50 - real, parameter :: e0 = 610.71 - real, parameter :: hlv = 2.501e6 - real, parameter :: tfreeze = 273.15 - real :: zvir - real:: grd - grd = grav/rdgas - zvir = rvgas/rdgas - 1. - ak = ak_in - bk = bk_in - ak(levp+1) = max(1.e-9, ak(levp+1)) - - do j = 1, jm - do i=1, im - pe0(i,levp+1) = ak(levp+1) - pn0(i,levp+1) = log(pe0(i,levp+1)) - enddo - - do k=levp,1, -1 - do i=1,im - pe0(i,k) = ak(k) + bk(k)*ps(i,j) - pn0(i,k) = log(pe0(i,k)) - enddo - enddo - - zh(1:im,j,1) = zs(1:im,j) - do k = 2, levp+1 - do i = 1, im - zh(i,j,k) = zh(i,j,k-1)+t(i,j,k-1)*(1.+zvir*sphum(i,j,k-1))* & - (pn0(i,k-1)-pn0(i,k))/grd - enddo - enddo - - enddo - - end subroutine compute_zh - SUBROUTINE GET_TRACERS(IDVT, NTRACO, I_CLD, I_OZN, TRAC_NAME) - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IDVT, NTRACO - - CHARACTER(LEN=16), INTENT(OUT) :: TRAC_NAME(NTRACO) - - INTEGER, INTENT(OUT) :: I_CLD, I_OZN - - TRAC_NAME = ' ' - - TRAC_NAME(1) = 'spfh' - IF (NTRACO == 2) THEN - IF(IDVT == 1) THEN - TRAC_NAME(2) = 'o3mr' - I_OZN = 2 - I_CLD = 0 - ELSEIF(IDVT == 2) THEN - TRAC_NAME(2) = 'clwmr' - I_OZN = 0 - I_CLD = 2 - ENDIF - ELSEIF (NTRACO == 3) THEN - IF(IDVT == 0) THEN - TRAC_NAME(2) = 'o3mr' - TRAC_NAME(3) = 'clwmr' - I_OZN = 2 - I_CLD = 0 - ELSEIF(IDVT == 21) THEN - TRAC_NAME(2) = 'o3mr' - TRAC_NAME(3) = 'clwmr' - I_OZN = 2 - I_CLD = 3 - ELSEIF(IDVT == 12) THEN - TRAC_NAME(2) = 'clwmr' - TRAC_NAME(3) = 'o3mr' - I_OZN = 3 - I_CLD = 2 - ENDIF - ELSEIF (NTRACO == 4) THEN - TRAC_NAME(4) = 'tke' - IF(IDVT == 0) THEN - TRAC_NAME(2) = 'o3mr' - TRAC_NAME(3) = 'clwmr' - I_OZN = 2 - I_CLD = 0 - ELSEIF(IDVT == 21) THEN - TRAC_NAME(2) = 'o3mr' - TRAC_NAME(3) = 'clwmr' - I_OZN = 2 - I_CLD = 3 - ELSEIF(IDVT == 12) THEN - TRAC_NAME(2) = 'clwmr' - TRAC_NAME(3) = 'o3mr' - I_OZN = 3 - I_CLD = 2 - ENDIF - ELSEIF(IDVT == 100) THEN - TRAC_NAME(2) = 'clwmr' - TRAC_NAME(3) = 'o3mr' - I_OZN = 2 - I_CLD = 3 - ! for WAM - ELSEIF(IDVT == 200) THEN - TRAC_NAME(2) = 'clwmr' - TRAC_NAME(3) = 'o3mr' - TRAC_NAME(4) = 'o' - TRAC_NAME(5) = 'o2' - I_OZN = 2 - I_CLD = 3 - ENDIF - - END SUBROUTINE GET_TRACERS - SUBROUTINE VINTG_IDEA(IMO,LATCH,KM2,NT,P2,RLAT,JMO,J1,J2,IDAY, & - U2,V2,T2,Q2) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! ABSTRACT: MAKE UPPER-AIR FIELDS MORE REAL -! WIND, TEMPERATURE, HUMIDITY AND OTHER TRACER -! -! USAGE: CALL VINTG_IDEA(IMO,LATCH,KM2,NT,P2,RLAT,JMO,J1,J2,IDAY, -! &U2,V2,T2,Q2) -! INPUT ARGUMENT LIST: -! IMO INTEGER NUMBER OF LOGITUDE -! LATCH INTEGER MAX NUMBER OF LAT TO PROCCESS -! KM2 INTEGER NUMBER OF OUTPUT LEVELS -! NT INTEGER NUMBER OF TRACERS INPUT -! JMO INTEGER NUMDER OF LATITUDE -! J1 INTEGER FIRST LATITUDE INDEX,(NORTH TO SOUTH) -! J2 INTEGER LAST LATITUDE INDEX, -! IDAY INTEGER (4) HOUR MONTH DAY YEAR -! RLAT REAL (JMO) LATITUDE IN DEGREE -! P2 REAL (IMO,2*LATCH,KM2) PRESSURES -! ORDERED FROM BOTTOM TO TOP OF ATMOSPHERE -! OUTPUT AND INPUT ARGUMENT LIST: -! U2 REAL (IMO,2*LATCH,KM2) ZONAL WIND -! V2 REAL (IMO,2*LATCH,KM2) MERIDIONAL WIND -! T2 REAL (IMO,2*LATCH,KM2) TEMPERATURE (K) -! Q2 REAL (IMO,2*LATCH,KM2,NT+2) TRACERS (HUMIDITY FIRST) -! -! SUBPROGRAMS CALLED: -! GETTEMP Calculate temperature -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN -! -!C$$$ - IMPLICIT NONE - INTEGER, INTENT(IN) :: imo,latch,km2,nt,jmo,j1,j2,iday(4) - REAL , INTENT(IN) :: rlat(jmo),p2(imo,2*latch,km2) - REAL , INTENT(INOUT) :: u2(imo,2*latch,km2), & - v2(imo,2*latch,km2), & - t2(imo,2*latch,km2), & - q2(imo,2*latch,km2,nt) - REAL, parameter:: top=64.25 - ! molecular wght of O (g/mol) - REAL, parameter:: amo=15.9994 - ! molecular wght of O2 (g/mol) - REAL, parameter:: amo2=31.999 - ! molecular wght of N2 (g/mol) - REAL, parameter:: amn2=28.013 - REAL temps(km2),tempn(km2),zmprn(km2),zmprs(km2),wfun(10) - REAL n_os(km2),n_on(km2),n_o2s(km2),n_o2n(km2) - REAL n_n2s(km2),n_n2n(km2) - REAL sumn,sums,rlats,coe,hold - INTEGER i, j, k, kref, jjn, jjs, ciday, ik,idat(8),jdow,jday -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get weight function at joints - do i=1,10 - wfun(i)=(i-1)/9. - enddo -! get calendar day -! call getcday(iday,ciday) -! ciday=iday(3)+30*(iday(2)-1) - idat(1)=iday(4) - idat(2)=iday(2) - idat(3)=iday(3) - idat(5)=iday(1) - call w3doxdat(idat,jdow,ciday,jday) -! print*,idat - print*,iday - print*,'ciday',ciday -! - do i=1,imo - do j=1,16 - do k=1,km2 - if(p2(i,j,k).le.0.) print*,i,j,k - enddo - enddo - enddo -! For EACH LATITUDE couple - do j=j1,j2 -! second index of data array for latitude couple - jjn=2*(j-j1)+1 - jjs=2*(j-j1)+2 -! Get zonal meam pressure - do k=1,km2 - sumn=0. - sums=0. - do i=1,imo - sumn=sumn+p2(i,jjn,k) - sums=sums+p2(i,jjs,k) - enddo - zmprn(k)=sumn/float(imo)*.01 - zmprs(k)=sums/float(imo)*.01 - enddo -! GET TEMP PROFILE - call gettemp(ciday,1,rlat(j),1,zmprn,km2,tempn,n_on,n_o2n, & - n_n2n) - rlats=-1.*rlat(j) - call gettemp(ciday,1,rlats,1,zmprs,km2,temps,n_os,n_o2s, & - n_n2s) -! JIONT WITH EACH LONGITUDE north - do i=1,imo - do k=1,km2 - hold = 1./(n_on(k)*amo+amo2*n_o2n(k)+amn2*n_n2n(k)) -! q2(i,jjn,k,nt+1)=(amo*n_on(k))*hold -! q2(i,jjn,k,nt+2)=(amo2*n_o2n(k))*hold - q2(i,jjn,k,nt-1) = (amo*n_on(k)) * hold - q2(i,jjn,k,nt) = (amo2*n_o2n(k)) * hold - enddo -! find joint location (orig data top) - do k=1,km2 - if(p2(i,jjn,k).le.top) then - kref=k - go to 10 - endif - enddo - 10 continue -! temperature joint - do k=kref,km2 - t2(i,jjn,k) = tempn(k) - enddo - do k=kref-10,kref-1 - t2(i,jjn,k) = wfun(k-kref+11) * tempn(k)+ & - (1.-wfun(k-kref+11)) * t2(i,jjn,k) - enddo -! others : u v q - do k=kref,km2 - coe = p2(i,jjn,k)/p2(i,jjn,kref) -! coe = log(p2(i,jjn,kref))/log(p2(i,jjn,k)) - u2(i,jjn,k) = coe*u2(i,jjn,kref) - v2(i,jjn,k) = coe*v2(i,jjn,kref) - enddo - enddo -! JIONT WITH EACH LONGITUDE south - do i=1,imo - do k=1,km2 - hold = 1./(n_os(k)*amo+amo2*n_o2s(k)+amn2*n_n2s(k)) - q2(i,jjs,k,nt-1) = (amo*n_os(k)) * hold - q2(i,jjs,k,nt) = (amo2*n_o2s(k)) * hold - enddo -! find joint location (orig data top) - do k=1,km2 - if(p2(i,jjs,k).le.top) then - kref=k - go to 11 - endif - enddo - 11 continue -! temperature joint - do k=kref,km2 - t2(i,jjs,k) = temps(k) - enddo - do k=kref-10,kref-1 - t2(i,jjs,k) = wfun(k-kref+11) * temps(k)+ & - (1.- wfun(k-kref+11)) * t2(i,jjs,k) - enddo -! others : u v q ........... - do k=kref,km2 - coe = p2(i,jjs,k)/p2(i,jjs,kref) -! coe = log(p2(i,jjs,kref))/log(p2(i,jjs,k)) - u2(i,jjs,k) = coe*u2(i,jjs,kref) - v2(i,jjs,k) = coe*v2(i,jjs,kref) - enddo - !logitude - enddo - enddo -! print*,'www1' -! print'(12f6.1)',(q2(1,i,km2,4),i=1,2*latch) - end subroutine vintg_idea -!----------------------------------------------------------------------- - subroutine gettemp(iday,nday,xlat,nlat,pr,np,temp,n_o,n_o2,n_n2) -! calculate temperature at each grid point useing nrlmsise00_sub - implicit none - !number of days - integer, intent(in) :: nday - !number of latitudes - integer, intent(in) :: nlat - !number of pressure le - integer, intent(in) :: np - ! pressure in mb - real, intent(in) :: pr(np) - !latitude in degree - real, intent(in) :: xlat(nlat) - !calender day - integer, intent(in) :: iday(nday) - ! temperature - real, intent(out) :: temp(np,nlat,nday) - ! number density of o ( - real, intent(out) :: n_o(np,nlat,nday) - ! number density of o2 - real, intent(out) :: n_o2(np,nlat,nday) - ! number density of N2 - real, intent(out) :: n_n2(np,nlat,nday) - ! altitude in km - real :: alt(np,nlat,nday) - real :: D(9),T(2),SW(25),AP(7),ut,xlong,xlst,f107, & - f107a - integer :: k,il,ip -! set magnetic index average value - DATA AP/7*9./ -! set swich 7,8,10,14 zero to avoid diurnal changes in output temperatu -! swich #7 is for diurnal,#8 is for semidiurnal,# 10 is for all UT/longi -! effect,#14 is for terdiurnal - data sw/1.,1.,1.,1.,1.,1.,0.,0.,1.,0.,1.,1.,1.,0.,1.,1.,1.,1.,1., & - 1.,1.,1.,1.,1.,1./ -! set 10.7cm flux be average value - f107=150. - f107a=150. -! turn on swich - CALL TSELEC(SW) -! set longitude, UT, local time , It should not make difference to outpu - ut=0. - xlong=0. - xlst=ut/3600.+xlong/15. -! calculate temperature for each lat,pres level,day - do k=1,nday - do il=1,nlat - do ip=1,np - CALL GHP7(IDAY(k),UT,ALT(ip,il,k),XLAT(il),XLONG,XLST,F107A,F107, & - AP,D,T,pr(ip)) - temp(ip,il,k)=t(2) - n_o(ip,il,k)=D(2) - n_o2(ip,il,k)=D(4) - n_n2(ip,il,k)=D(3) - enddo - enddo - enddo - end subroutine gettemp diff --git a/sorc/global_chgres.fd/funcphys.f90 b/sorc/global_chgres.fd/funcphys.f90 deleted file mode 100755 index d6a06b709..000000000 --- a/sorc/global_chgres.fd/funcphys.f90 +++ /dev/null @@ -1,2892 +0,0 @@ -!> @file -!! -!! Module: funcphys API for basic thermodynamic physics -!! Author: Iredell Org: W/NX23 Date: 1999-03-01 -!! -!! Abstract: This module provides an Application Program Interface -!! for computing basic thermodynamic physics functions, in particular -!! (1) saturation vapor pressure as a function of temperature, -!! (2) dewpoint temperature as a function of vapor pressure, -!! (3) equivalent potential temperature as a function of temperature -!! and scaled pressure to the kappa power, -!! (4) temperature and specific humidity along a moist adiabat -!! as functions of equivalent potential temperature and -!! scaled pressure to the kappa power, -!! (5) scaled pressure to the kappa power as a function of pressure, and -!! (6) temperature at the lifting condensation level as a function -!! of temperature and dewpoint depression. -!! The entry points required to set up lookup tables start with a "g". -!! All the other entry points are functions starting with an "f" or -!! are subroutines starting with an "s". These other functions and -!! subroutines are elemental; that is, they return a scalar if they -!! are passed only scalars, but they return an array if they are passed -!! an array. These other functions and subroutines can be inlined, too. -!! -!! Program History Log: -!! - 1999-03-01 Mark Iredell -!! - 1999-10-15 Mark Iredell SI unit for pressure (Pascals) -!! - 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi -!! -!! Public Variables: -!! - krealfp Integer parameter kind or length of reals (=kind_phys) -!! -!! 
-!! Public Subprograms:
-!!   gpvsl            Compute saturation vapor pressure over liquid table
-!!
-!!   fpvsl           Elementally compute saturation vapor pressure over liquid
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvslq          Elementally compute saturation vapor pressure over liquid
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvslx          Elementally compute saturation vapor pressure over liquid
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   gpvsi            Compute saturation vapor pressure over ice table
-!!
-!!   fpvsi           Elementally compute saturation vapor pressure over ice
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvsiq          Elementally compute saturation vapor pressure over ice
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvsix          Elementally compute saturation vapor pressure over ice
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   gpvs            Compute saturation vapor pressure table
-!!
-!!   fpvs            Elementally compute saturation vapor pressure
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvsq           Elementally compute saturation vapor pressure
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   fpvsx           Elementally compute saturation vapor pressure
-!!     function result Real(krealfp) saturation vapor pressure in Pascals
-!!     t               Real(krealfp) temperature in Kelvin
-!!
-!!   gtdpl           Compute dewpoint temperature over liquid table
-!!
-!!   ftdpl           Elementally compute dewpoint temperature over liquid
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdplq          Elementally compute dewpoint temperature over liquid
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdplx          Elementally compute dewpoint temperature over liquid
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdplxg         Elementally compute dewpoint temperature over liquid
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     t               Real(krealfp) guess dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   gtdpi           Compute dewpoint temperature table over ice
-!!
-!!   ftdpi           Elementally compute dewpoint temperature over ice
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpiq          Elementally compute dewpoint temperature over ice
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpix          Elementally compute dewpoint temperature over ice
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpixg         Elementally compute dewpoint temperature over ice
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     t               Real(krealfp) guess dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   gtdp            Compute dewpoint temperature table
-!!
-!!   ftdp            Elementally compute dewpoint temperature
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpq           Elementally compute dewpoint temperature
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpx           Elementally compute dewpoint temperature
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   ftdpxg          Elementally compute dewpoint temperature
-!!     function result Real(krealfp) dewpoint temperature in Kelvin
-!!     t               Real(krealfp) guess dewpoint temperature in Kelvin
-!!     pv              Real(krealfp) vapor pressure in Pascals
-!!
-!!   gthe            Compute equivalent potential temperature table
-!!
-!!   fthe            Elementally compute equivalent potential temperature
-!!     function result Real(krealfp) equivalent potential temperature in Kelvin
-!!     t               Real(krealfp) LCL temperature in Kelvin
-!!     pk              Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
-!!
-!!   ftheq           Elementally compute equivalent potential temperature
-!!     function result Real(krealfp) equivalent potential temperature in Kelvin
-!!     t               Real(krealfp) LCL temperature in Kelvin
-!!     pk              Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
-!!
-!!   fthex           Elementally compute equivalent potential temperature
-!!     function result Real(krealfp) equivalent potential temperature in Kelvin
-!!     t               Real(krealfp) LCL temperature in Kelvin
-!!     pk              Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
-!!
-!!   gtma            Compute moist adiabat tables
-!!
-!!   stma            Elementally compute moist adiabat temperature and moisture
-!!     the             Real(krealfp) equivalent potential temperature in Kelvin
-!!     pk              Real(krealfp) pressure over 1e5 Pa to the kappa power
-!!     tma             Real(krealfp) parcel temperature in Kelvin
-!!     qma             Real(krealfp) parcel specific humidity in kg/kg
-!!
-!!   stmaq           Elementally compute moist adiabat temperature and moisture
-!!     the             Real(krealfp) equivalent potential temperature in Kelvin
-!!     pk              Real(krealfp) pressure over 1e5 Pa to the kappa power
-!!     tma             Real(krealfp) parcel temperature in Kelvin
-!!     qma             Real(krealfp) parcel specific humidity in kg/kg
-!!
-!!   stmax           Elementally compute moist adiabat temperature and moisture
-!!     the             Real(krealfp) equivalent potential temperature in Kelvin
-!!     pk              Real(krealfp) pressure over 1e5 Pa to the kappa power
-!!     tma             Real(krealfp) parcel temperature in Kelvin
-!!     qma             Real(krealfp) parcel specific humidity in kg/kg
-!!
-!!   stmaxg          Elementally compute moist adiabat temperature and moisture
-!!     tg              Real(krealfp) guess parcel temperature in Kelvin
-!!     the             Real(krealfp) equivalent potential temperature in Kelvin
-!!     pk              Real(krealfp) pressure over 1e5 Pa to the kappa power
-!!     tma             Real(krealfp) parcel temperature in Kelvin
-!!     qma             Real(krealfp) parcel specific humidity in kg/kg
-!!
-!!   gpkap           Compute pressure to the kappa table
-!!
-!!   fpkap           Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) p over 1e5 Pa to the kappa power
-!!     p               Real(krealfp) pressure in Pascals
-!!
-!!   fpkapq          Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) p over 1e5 Pa to the kappa power
-!!     p               Real(krealfp) pressure in Pascals
-!!
-!!   fpkapo          Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) p over 1e5 Pa to the kappa power
-!!     p               Real(krealfp) surface pressure in Pascals
-!!
-!!   fpkapx          Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) p over 1e5 Pa to the kappa power
-!!     p               Real(krealfp) pressure in Pascals
-!!
-!!   grkap           Compute pressure to the 1/kappa table
-!!
-!!   frkap           Elementally raise pressure to the 1/kappa power.
-!!     function result Real(krealfp) pressure in Pascals
-!!     pkap            Real(krealfp) p over 1e5 Pa to the 1/kappa power
-!!
-!!   frkapq          Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) pressure in Pascals
-!!     pkap            Real(krealfp) p over 1e5 Pa to the kappa power
-!!
-!!   frkapx          Elementally raise pressure to the kappa power.
-!!     function result Real(krealfp) pressure in Pascals
-!!     pkap            Real(krealfp) p over 1e5 Pa to the kappa power
-!!
-!!   gtlcl           Compute LCL temperature table
-!!
-!!   ftlcl           Elementally compute LCL temperature.
-!!     function result Real(krealfp) temperature at the LCL in Kelvin
-!!     t               Real(krealfp) temperature in Kelvin
-!!     tdpd            Real(krealfp) dewpoint depression in Kelvin
-!!
-!!   ftlclq          Elementally compute LCL temperature.
-!!     function result Real(krealfp) temperature at the LCL in Kelvin
-!!     t               Real(krealfp) temperature in Kelvin
-!!     tdpd            Real(krealfp) dewpoint depression in Kelvin
-!!
-!!   ftlclo          Elementally compute LCL temperature.
-!!     function result Real(krealfp) temperature at the LCL in Kelvin
-!!     t               Real(krealfp) temperature in Kelvin
-!!     tdpd            Real(krealfp) dewpoint depression in Kelvin
-!!
-!!   ftlclx          Elementally compute LCL temperature.
-!!     function result Real(krealfp) temperature at the LCL in Kelvin
-!!     t               Real(krealfp) temperature in Kelvin
-!!     tdpd            Real(krealfp) dewpoint depression in Kelvin
-!!
-!!   gfuncphys       Compute all physics function tables
-!!
-!! -module funcphys - use machine,only:kind_phys - use physcons - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables -! integer,public,parameter:: krealfp=selected_real_kind(15,45) - integer,public,parameter:: krealfp=kind_phys -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Private Variables - real(krealfp),parameter:: psatb=con_psat*1.e-5 - integer,parameter:: nxpvsl=7501 - real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) - integer,parameter:: nxpvsi=7501 - real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi) - integer,parameter:: nxpvs=7501 - real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs) - integer,parameter:: nxtdpl=5001 - real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl) - integer,parameter:: nxtdpi=5001 - real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi) - integer,parameter:: nxtdp=5001 - real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp) - integer,parameter:: nxthe=241,nythe=151 - real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe) - integer,parameter:: nxma=151,nyma=121 - real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma) - integer,parameter:: nxpkap=11001 - real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap) - integer,parameter:: nxrkap=11001 - real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) - integer,parameter:: nxtlcl=151,nytlcl=61 - real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public gpvsl,fpvsl,fpvslq,fpvslx - public gpvsi,fpvsi,fpvsiq,fpvsix - public gpvs,fpvs,fpvsq,fpvsx - public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg - public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg - public gtdp,ftdp,ftdpq,ftdpx,ftdpxg - public gthe,fthe,ftheq,fthex - public gtma,stma,stmaq,stmax,stmaxg - public gpkap,fpkap,fpkapq,fpkapo,fpkapx - public grkap,frkap,frkapq,frkapx - public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx - public gfuncphys -contains -!------------------------------------------------------------------------------- - subroutine gpvsl -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsl Compute saturation vapor pressure table over liquid -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsl. -! Exact saturation vapor pressures are calculated in subprogram fpvslx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gpvsl -! -! Subprograms called: -! (fpvslx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsl-1) - c1xpvsl=1.-xmin/xinc - c2xpvsl=1./xinc - do jx=1,nxpvsl - x=xmin+(jx-1)*xinc - t=x - tbpvsl(jx)=fpvslx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsl(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsl Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsl is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvsl(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsl Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsl - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(xj,nxpvsl-1._krealfp) - fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslq Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsl. See documentation for fpvslx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvslq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) - jx=min(max(nint(xj),2),nxpvsl-1) - dxj=xj-jx - fj1=tbpvsl(jx-1) - fj2=tbpvsl(jx) - fj3=tbpvsl(jx+1) - fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvslx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvslx Compute saturation vapor pressure over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: pvsl=fpvslx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvslx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvslx - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvsi -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvsi Compute saturation vapor pressure table over ice -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvsi. -! Exact saturation vapor pressures are calculated in subprogram fpvsix. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvsi -! -! Subprograms called: -! (fpvsix) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvsi-1) - c1xpvsi=1.-xmin/xinc - c2xpvsi=1./xinc - do jx=1,nxpvsi - x=xmin+(jx-1)*xinc - t=x - tbpvsi(jx)=fpvsix(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvsi(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsi Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvsi is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsi(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsi Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsi - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(xj,nxpvsi-1._krealfp) - fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsiq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsiq Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvsi. See documentation for fpvsix for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsiq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsiq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsiq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsiq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) - jx=min(max(nint(xj),2),nxpvsi-1) - dxj=xj-jx - fj1=tbpvsi(jx-1) - fj2=tbpvsi(jx) - fj3=tbpvsi(jx+1) - fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsix(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsix Compute saturation vapor pressure over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of condensation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvsi=fpvsix(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsix Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsix - real(krealfp),intent(in):: t - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) tr -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gpvs -!$$$ Subprogram Documentation Block -! -! Subprogram: gpvs Compute saturation vapor pressure table -! Author: N Phillips W/NMC2X2 Date: 30 dec 82 -! -! Abstract: Computes saturation vapor pressure table as a function of -! temperature for the table lookup function fpvs. -! Exact saturation vapor pressures are calculated in subprogram fpvsx. -! The current implementation computes a table with a length -! of 7501 for temperatures ranging from 180. to 330. Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gpvs -! -! Subprograms called: -! (fpvsx) inlinable function to compute saturation vapor pressure -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180.0_krealfp - xmax=330.0_krealfp - xinc=(xmax-xmin)/(nxpvs-1) - c1xpvs=1.-xmin/xinc - c2xpvs=1./xinc - do jx=1,nxpvs - x=xmin+(jx-1)*xinc - t=x - tbpvs(jx)=fpvsx(t) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpvs(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvs Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A linear interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 6 decimal places. -! On the Cray, fpvs is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvs(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvs Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvs - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(xj,nxpvs-1._krealfp) - fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsq(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsq Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute saturation vapor pressure from the temperature. -! A quadratic interpolation is done between values in a lookup table -! computed in gpvs. See documentation for fpvsx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is almost 9 decimal places. -! On the Cray, fpvsq is about 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsq(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsq Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsq - real(krealfp),intent(in):: t - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) - jx=min(max(nint(xj),2),nxpvs-1) - dxj=xj-jx - fj1=tbpvs(jx-1) - fj2=tbpvs(jx) - fj3=tbpvs(jx+1) - fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpvsx(t) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpvsx Compute saturation vapor pressure -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute saturation vapor pressure from temperature. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this computation is Emanuel(1994), pages 116-117. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: pvs=fpvsx(t) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! -! Output argument list: -! fpvsx Real(krealfp) saturation vapor pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpvsx - real(krealfp),intent(in):: t - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) tr,w,pvl,pvi -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/t - if(t.ge.tliq) then - fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - elseif(t.lt.tice) then - fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - else - w=(t-tice)/(tliq-tice) - pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - fpvsx=w*pvl+(1.-w)*pvi - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpl Compute dewpoint temperature over liquid table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpl. -! Exact dewpoint temperatures are calculated in subprogram ftdplxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 1 to 10001 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtdpl -! -! Subprograms called: -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=1 - xmax=10001 - xinc=(xmax-xmin)/(nxtdpl-1) - c1xtdpl=1.-xmin/xinc - c2xtdpl=1./xinc - t=208.0 - do jx=1,nxtdpl - x=xmin+(jx-1)*xinc - pv=x - t=ftdplxg(t,pv) - tbtdpl(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpl(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpl Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpl. See documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpl is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdpl(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpl Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpl - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(xj,nxtdpl-1._krealfp) - ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplq Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpl. see documentation for ftdplxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdplq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) - jx=min(max(nint(xj),2),nxtdpl-1) - dxj=xj-jx - fj1=tbtdpl(jx-1) - fj2=tbtdpl(jx) - fj3=tbtdpl(jx+1) - ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplx Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdplxg -! is obtained using ftdpl so gtdpl must be already called. -! See documentation for ftdplxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpl) inlinable function to compute dewpoint temperature over liquid -! (ftdplxg) inlinable function to compute dewpoint temperature over liquid -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpl(pv) - ftdplx=ftdplxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdplxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdplxg Compute dewpoint temperature over liquid -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: tdpl=ftdplxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdplxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdplxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_cliq - real(krealfp),parameter:: heat=con_hvap - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdplxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdpi -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdpi Compute dewpoint temperature over ice table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdpi. -! Exact dewpoint temperatures are calculated in subprogram ftdpixg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals -! giving a dewpoint temperature range of 197 to 279 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdpi -! -! Subprograms called: -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.1 - xmax=1000.1 - xinc=(xmax-xmin)/(nxtdpi-1) - c1xtdpi=1.-xmin/xinc - c2xtdpi=1./xinc - t=197.0 - do jx=1,nxtdpi - x=xmin+(jx-1)*xinc - pv=x - t=ftdpixg(t,pv) - tbtdpi(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdpi(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpi Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdpi. See documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpi is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpi(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpi Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpi - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(xj,nxtdpi-1._krealfp) - ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpiq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpiq Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdpi. see documentation for ftdpixg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpiq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpiq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpiq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpiq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) - jx=min(max(nint(xj),2),nxtdpi-1) - dxj=xj-jx - fj1=tbtdpi(jx-1) - fj2=tbtdpi(jx) - fj3=tbtdpi(jx+1) - ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpix(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpix Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpixg -! is obtained using ftdpi so gtdpi must be already called. -! See documentation for ftdpixg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpix(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpix Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdpi) inlinable function to compute dewpoint temperature over ice -! (ftdpixg) inlinable function to compute dewpoint temperature over ice -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpix - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdpi(pv) - ftdpix=ftdpixg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpixg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpixg Compute dewpoint temperature over ice -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The water model assumes a perfect gas, constant specific heats -! for gas and ice, and neglects the volume of the ice. -! The model does account for the variation of the latent heat -! of sublimation with temperature. The liquid option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdpi=ftdpixg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpixg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpixg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: dldt=con_cvap-con_csol - real(krealfp),parameter:: heat=con_hvap+con_hfus - real(krealfp),parameter:: xpona=-dldt/con_rv - real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) - real(krealfp) t,tr,pvt,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) - el=heat+dldt*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpixg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtdp -!$$$ Subprogram Documentation Block -! -! Subprogram: gtdp Compute dewpoint temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature table as a function of -! vapor pressure for inlinable function ftdp. -! Exact dewpoint temperatures are calculated in subprogram ftdpxg. -! The current implementation computes a table with a length -! of 5001 for vapor pressures ranging from 0.5 to 1000.5 Pascals -! giving a dewpoint temperature range of 208 to 319 Kelvin. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: call gtdp -! -! Subprograms called: -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,t,x,pv -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0.5 - xmax=10000.5 - xinc=(xmax-xmin)/(nxtdp-1) - c1xtdp=1.-xmin/xinc - c2xtdp=1./xinc - t=208.0 - do jx=1,nxtdp - x=xmin+(jx-1)*xinc - pv=x - t=ftdpxg(t,pv) - tbtdp(jx)=t - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftdp(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdp Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A linear interpolation is done between values in a lookup table -! computed in gtdp. See documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdp is about 75 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdp(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdp Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdp - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(xj,nxtdp-1._krealfp) - ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpq(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpq Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute dewpoint temperature from vapor pressure. -! A quadratic interpolation is done between values in a lookup table -! computed in gtdp. see documentation for ftdpxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.00001 Kelvin -! for dewpoint temperatures greater than 250 Kelvin, -! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. -! On the Cray, ftdpq is about 60 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpq(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpq Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpq - real(krealfp),intent(in):: pv - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) - jx=min(max(nint(xj),2),nxtdp-1) - dxj=xj-jx - fj1=tbtdp(jx-1) - fj2=tbtdp(jx) - fj3=tbtdp(jx+1) - ftdpq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpx(pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpx Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute dewpoint temperature from vapor pressure. -! An approximate dewpoint temperature for function ftdpxg -! is obtained using ftdp so gtdp must be already called. -! See documentation for ftdpxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpx(pv) -! -! Input argument list: -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpx Real(krealfp) dewpoint temperature in Kelvin -! -! Subprograms called: -! (ftdp) inlinable function to compute dewpoint temperature -! (ftdpxg) inlinable function to compute dewpoint temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpx - real(krealfp),intent(in):: pv - real(krealfp) tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tg=ftdp(pv) - ftdpx=ftdpxg(tg,pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftdpxg(tg,pv) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftdpxg Compute dewpoint temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute dewpoint temperature from vapor pressure. -! A guess dewpoint temperature must be provided. -! The saturation vapor pressure over either liquid and ice is computed -! over liquid for temperatures above the triple point, -! over ice for temperatures 20 degress below the triple point, -! and a linear combination of the two for temperatures in between. -! The water model assumes a perfect gas, constant specific heats -! for gas, liquid and ice, and neglects the volume of the condensate. -! The model does account for the variation of the latent heat -! of condensation and sublimation with temperature. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formula -! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) -! where tr is ttp/t and other values are physical constants. -! The reference for this decision is Emanuel(1994), pages 116-117. -! The formula is inverted by iterating Newtonian approximations -! for each pvs until t is found to within 1.e-6 Kelvin. -! This function can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! 2001-02-26 Iredell ice phase -! -! Usage: tdp=ftdpxg(tg,pv) -! -! Input argument list: -! tg Real(krealfp) guess dewpoint temperature in Kelvin -! pv Real(krealfp) vapor pressure in Pascals -! -! Output argument list: -! ftdpxg Real(krealfp) dewpoint temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftdpxg - real(krealfp),intent(in):: tg,pv - real(krealfp),parameter:: terrm=1.e-6 - real(krealfp),parameter:: tliq=con_ttp - real(krealfp),parameter:: tice=con_ttp-20.0 - real(krealfp),parameter:: dldtl=con_cvap-con_cliq - real(krealfp),parameter:: heatl=con_hvap - real(krealfp),parameter:: xponal=-dldtl/con_rv - real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) - real(krealfp),parameter:: dldti=con_cvap-con_csol - real(krealfp),parameter:: heati=con_hvap+con_hfus - real(krealfp),parameter:: xponai=-dldti/con_rv - real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) - real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - do i=1,100 - tr=con_ttp/t - if(t.ge.tliq) then - pvt=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - el=heatl+dldtl*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - elseif(t.lt.tice) then - pvt=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - el=heati+dldti*(t-con_ttp) - dpvt=el*pvt/(con_rv*t**2) - else - w=(t-tice)/(tliq-tice) - pvtl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) - pvti=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) - pvt=w*pvtl+(1.-w)*pvti - ell=heatl+dldtl*(t-con_ttp) - eli=heati+dldti*(t-con_ttp) - dpvt=(w*ell*pvtl+(1.-w)*eli*pvti)/(con_rv*t**2) - endif - terr=(pvt-pv)/dpvt - t=t-terr - if(abs(terr).le.terrm) exit - enddo - ftdpxg=t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gthe -!$$$ Subprogram Documentation Block -! -! Subprogram: gthe Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature table -! as a function of LCL temperature and pressure over 1e5 Pa -! to the kappa power for function fthe. -! Equivalent potential temperatures are calculated in subprogram fthex -! the current implementation computes a table with a first dimension -! of 241 for temperatures ranging from 183.16 to 303.16 Kelvin -! and a second dimension of 151 for pressure over 1e5 Pa -! to the kappa power ranging from 0.04**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gthe -! -! Subprograms called: -! (fthex) inlinable function to compute equiv. pot. temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=con_ttp-90._krealfp - xmax=con_ttp+30._krealfp - ymin=0.04_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxthe-1) - c1xthe=1.-xmin/xinc - c2xthe=1./xinc - yinc=(ymax-ymin)/(nythe-1) - c1ythe=1.-ymin/yinc - c2ythe=1./yinc - do jy=1,nythe - y=ymin+(jy-1)*yinc - pk=y - do jx=1,nxthe - x=xmin+(jx-1)*xinc - t=x - tbthe(jx,jy)=fthex(t,pk) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fthe(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthe Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A bilinear interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.01 Kelvin. -! On the Cray, fthe is almost 6 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthe(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthe Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthe - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(xj,nxthe-1._krealfp) - jy=min(yj,nythe-1._krealfp) - ftx1=tbthe(jx,jy)+(xj-jx)*(tbthe(jx+1,jy)-tbthe(jx,jy)) - ftx2=tbthe(jx,jy+1)+(xj-jx)*(tbthe(jx+1,jy+1)-tbthe(jx,jy+1)) - fthe=ftx1+(yj-jy)*(ftx2-ftx1) - else - fthe=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftheq(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftheq Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! A biquadratic interpolation is done between values in a lookup table -! computed in gthe. see documentation for fthex for details. -! Input values outside table range are reset to table extrema, -! except zero is returned for too cold or high LCLs. -! The interpolation accuracy is better than 0.0002 Kelvin. -! On the Cray, ftheq is almost 3 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: the=ftheq(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! ftheq Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftheq - real(krealfp),intent(in):: t,pk - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) - yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) - if(xj.ge.1..and.yj.ge.1.) then - jx=min(max(nint(xj),2),nxthe-1) - jy=min(max(nint(yj),2),nythe-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbthe(jx-1,jy-1) - ft12=tbthe(jx-1,jy) - ft13=tbthe(jx-1,jy+1) - ft21=tbthe(jx,jy-1) - ft22=tbthe(jx,jy) - ft23=tbthe(jx,jy+1) - ft31=tbthe(jx+1,jy-1) - ft32=tbthe(jx+1,jy) - ft33=tbthe(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftheq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - else - ftheq=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- -! elemental function fthex(t,pk) - function fthex(t,pk) -!$$$ Subprogram Documentation Block -! -! Subprogram: fthex Compute equivalent potential temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute equivalent potential temperature at the LCL -! from temperature and pressure over 1e5 Pa to the kappa power. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! Zero is returned if the input values make saturation impossible. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: the=fthex(t,pk) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! fthex Real(krealfp) equivalent potential temperature in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fthex - real(krealfp),intent(in):: t,pk - real(krealfp) p,tr,pv,pd,el,expo,expmax -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - p=pk**con_cpor - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - if(pd.gt.pv) then - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - fthex=t*pd**(-con_rocp)*exp(expo) - else - fthex=0. - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtma -!$$$ Subprogram Documentation Block -! -! Subprogram: gtma Compute moist adiabat tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity tables -! as a function of equivalent potential temperature and -! pressure over 1e5 Pa to the kappa power for subprogram stma. -! Exact parcel temperatures are calculated in subprogram stmaxg. -! The current implementation computes a table with a first dimension -! of 151 for equivalent potential temperatures ranging from 200 to 500 -! Kelvin and a second dimension of 121 for pressure over 1e5 Pa -! to the kappa power ranging from 0.01**rocp to 1.10**rocp. -! -! Program History Log: -! 91-05-07 Iredell -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call gtma -! -! Subprograms called: -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=200._krealfp - xmax=500._krealfp - ymin=0.01_krealfp**con_rocp - ymax=1.10_krealfp**con_rocp - xinc=(xmax-xmin)/(nxma-1) - c1xma=1.-xmin/xinc - c2xma=1./xinc - yinc=(ymax-ymin)/(nyma-1) - c1yma=1.-ymin/yinc - c2yma=1./yinc - do jy=1,nyma - y=ymin+(jy-1)*yinc - pk=y - tg=xmin*y - do jx=1,nxma - x=xmin+(jx-1)*xinc - the=x - call stmaxg(tg,the,pk,t,q) - tbtma(jx,jy)=t - tbqma(jx,jy)=q - tg=t - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stma(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stma Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Bilinear interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.01 Kelvin -! and 5.e-6 kg/kg for temperature and humidity, respectively. -! On the Cray, stma is about 35 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell expand table -! 1999-03-01 Iredell f90 module -! -! Usage: call stma(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(xj,nxma-1._krealfp) - jy=min(yj,nyma-1._krealfp) - ftx1=tbtma(jx,jy)+(xj-jx)*(tbtma(jx+1,jy)-tbtma(jx,jy)) - ftx2=tbtma(jx,jy+1)+(xj-jx)*(tbtma(jx+1,jy+1)-tbtma(jx,jy+1)) - tma=ftx1+(yj-jy)*(ftx2-ftx1) - qx1=tbqma(jx,jy)+(xj-jx)*(tbqma(jx+1,jy)-tbqma(jx,jy)) - qx2=tbqma(jx,jy+1)+(xj-jx)*(tbqma(jx+1,jy+1)-tbqma(jx,jy+1)) - qma=qx1+(yj-jy)*(qx2-qx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaq(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaq Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature and specific humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! Biquadratic interpolations are done between values in a lookup table -! computed in gtma. See documentation for stmaxg for details. -! Input values outside table range are reset to table extrema. -! the interpolation accuracy is better than 0.0005 Kelvin -! and 1.e-7 kg/kg for temperature and humidity, respectively. -! On the Cray, stmaq is about 25 times faster than exact calculation. -! This subprogram should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell quadratic interpolation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaq(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tmaq Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 - real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) - yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) - jx=min(max(nint(xj),2),nxma-1) - jy=min(max(nint(yj),2),nyma-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtma(jx-1,jy-1) - ft12=tbtma(jx-1,jy) - ft13=tbtma(jx-1,jy+1) - ft21=tbtma(jx,jy-1) - ft22=tbtma(jx,jy) - ft23=tbtma(jx,jy+1) - ft31=tbtma(jx+1,jy-1) - ft32=tbtma(jx+1,jy) - ft33=tbtma(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - tma=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 - q11=tbqma(jx-1,jy-1) - q12=tbqma(jx-1,jy) - q13=tbqma(jx-1,jy+1) - q21=tbqma(jx,jy-1) - q22=tbqma(jx,jy) - q23=tbqma(jx,jy+1) - q31=tbqma(jx+1,jy-1) - q32=tbqma(jx+1,jy) - q33=tbqma(jx+1,jy+1) - qx1=(((q31+q11)/2-q21)*dxj+(q31-q11)/2)*dxj+q21 - qx2=(((q32+q12)/2-q22)*dxj+(q32-q12)/2)*dxj+q22 - qx3=(((q33+q13)/2-q23)*dxj+(q33-q13)/2)*dxj+q23 - qma=(((qx3+qx1)/2-qx2)*dyj+(qx3-qx1)/2)*dyj+qx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmax(the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmax Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! An approximate parcel temperature for subprogram stmaxg -! is obtained using stma so gtma must be already called. -! See documentation for stmaxg for details. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmax(the,pk,tma,qma) -! -! Input argument list: -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Subprograms called: -! (stma) inlinable subprogram to compute parcel temperature -! (stmaxg) inlinable subprogram to compute parcel temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp) tg,qg -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call stma(the,pk,tg,qg) - call stmaxg(tg,the,pk,tma,qma) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental subroutine stmaxg(tg,the,pk,tma,qma) -!$$$ Subprogram Documentation Block -! -! Subprogram: stmaxg Compute moist adiabat temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: exactly compute temperature and humidity of a parcel -! lifted up a moist adiabat from equivalent potential temperature -! at the LCL and pressure over 1e5 Pa to the kappa power. -! A guess parcel temperature must be provided. -! Equivalent potential temperature is constant for a saturated parcel -! rising adiabatically up a moist adiabat when the heat and mass -! of the condensed water are neglected. Ice is also neglected. -! The formula for equivalent potential temperature (Holton) is -! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) -! where t is the temperature, pv is the saturated vapor pressure, -! pd is the dry pressure p-pv, el is the temperature dependent -! latent heat of condensation hvap+dldt*(t-ttp), and other values -! are physical constants defined in parameter statements in the code. -! The formula is inverted by iterating Newtonian approximations -! for each the and p until t is found to within 1.e-4 Kelvin. -! The specific humidity is then computed from pv and pd. -! This subprogram can be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell exact computation -! 1999-03-01 Iredell f90 module -! -! Usage: call stmaxg(tg,the,pk,tma,qma) -! -! Input argument list: -! tg Real(krealfp) guess parcel temperature in Kelvin -! the Real(krealfp) equivalent potential temperature in Kelvin -! pk Real(krealfp) pressure over 1e5 Pa to the kappa power -! -! Output argument list: -! tma Real(krealfp) parcel temperature in Kelvin -! qma Real(krealfp) parcel specific humidity in kg/kg -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp),intent(in):: tg,the,pk - real(krealfp),intent(out):: tma,qma - real(krealfp),parameter:: terrm=1.e-4 - real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - t=tg - p=pk**con_cpor - do i=1,100 - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - el=con_hvap+con_dldt*(t-con_ttp) - expo=el*con_eps*pv/(con_cp*t*pd) - thet=t*pd**(-con_rocp)*exp(expo) - dthet=thet/t*(1.+expo*(con_dldt*t/el+el*p/(con_rv*t*pd))) - terr=(thet-the)/dthet - t=t-terr - if(abs(terr).le.terrm) exit - enddo - tma=t - tr=con_ttp/t - pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - pd=p-pv - qma=con_eps*pv/(pd+con_eps*pv) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine gpkap -!$$$ Subprogram documentation block -! -! Subprogram: gpkap Compute coefficients for p**kappa -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the kappa table as a function of pressure -! for the table lookup function fpkap. -! Exact pressure to the kappa values are calculated in subprogram fpkapx. -! The current implementation computes a table with a length -! of 11001 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call gpkap -! -! Subprograms called: -! fpkapx function to compute exact pressure to the kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=110000._krealfp - xinc=(xmax-xmin)/(nxpkap-1) - c1xpkap=1.-xmin/xinc - c2xpkap=1./xinc - do jx=1,nxpkap - x=xmin+(jx-1)*xinc - p=x - tbpkap(jx)=fpkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function fpkap(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkap raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A linear interpolation is done between values in a lookup table -! computed in gpkap. See documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 9 decimal places -! at 100000 Pascals to 5 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 5 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkap(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkap - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(xj,nxpkap-1._krealfp) - fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapq(p) -!$$$ Subprogram Documentation Block -! -! Subprogram: fpkapq raise pressure to the kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in gpkap. see documentation for fpkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy ranges from 12 decimal places -! at 100000 Pascals to 7 decimal places at 1000 Pascals. -! On the Cray, fpkap is over 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: pkap=fpkapq(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapq Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapq - real(krealfp),intent(in):: p - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) - jx=min(max(nint(xj),2),nxpkap-1) - dxj=xj-jx - fj1=tbpkap(jx-1) - fj2=tbpkap(jx) - fj3=tbpkap(jx+1) - fpkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function fpkapo(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapo raise surface pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Raise surface pressure over 1e5 Pa to the kappa power -! using a rational weighted chebyshev approximation. -! The numerator is of order 2 and the denominator is of order 4. -! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx. -! The accuracy of this approximation is almost 8 decimal places. -! On the Cray, fpkap is over 10 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapo(p) -! -! Input argument list: -! p Real(krealfp) surface pressure in Pascals -! p should be in the range 40000 to 110000 -! -! Output argument list: -! fpkapo Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapo - real(krealfp),intent(in):: p - integer,parameter:: nnpk=2,ndpk=4 - real(krealfp):: cnpk(0:nnpk)=(/3.13198449e-1,5.78544829e-2,& - 8.35491871e-4/) - real(krealfp):: cdpk(0:ndpk)=(/1.,8.15968401e-2,5.72839518e-4,& - -4.86959812e-7,5.24459889e-10/) - integer n - real(krealfp) pkpa,fnpk,fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - pkpa=p*1.e-3_krealfp - fnpk=cnpk(nnpk) - do n=nnpk-1,0,-1 - fnpk=pkpa*fnpk+cnpk(n) - enddo - fdpk=cdpk(ndpk) - do n=ndpk-1,0,-1 - fdpk=pkpa*fdpk+cdpk(n) - enddo - fpkapo=fnpk/fdpk -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function fpkapx(p) -!$$$ Subprogram documentation block -! -! Subprogram: fpkapx raise pressure to the kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: pkap=fpkapx(p) -! -! Input argument list: -! p Real(krealfp) pressure in Pascals -! -! Output argument list: -! fpkapx Real(krealfp) p over 1e5 Pa to the kappa power -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) fpkapx - real(krealfp),intent(in):: p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - fpkapx=(p/1.e5_krealfp)**con_rocp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine grkap -!$$$ Subprogram documentation block -! -! Subprogram: grkap Compute coefficients for p**(1/kappa) -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Computes pressure to the 1/kappa table as a function of pressure -! for the table lookup function frkap. -! Exact pressure to the 1/kappa values are calculated in subprogram frkapx. -! The current implementation computes a table with a length -! of 11001 for pressures ranging up to 110000 Pascals. -! -! Program History Log: -! 94-12-30 Iredell -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: call grkap -! -! Subprograms called: -! frkapx function to compute exact pressure to the 1/kappa -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx - real(krealfp) xmin,xmax,xinc,x,p -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=0._krealfp - xmax=fpkapx(110000._krealfp) - xinc=(xmax-xmin)/(nxrkap-1) - c1xrkap=1.-xmin/xinc - c2xrkap=1./xinc - do jx=1,nxrkap - x=xmin+(jx-1)*xinc - p=x - tbrkap(jx)=frkapx(p) - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function frkap(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkap raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A linear interpolation is done between values in a lookup table -! computed in grkap. See documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 7 decimal places. -! On the IBM, fpkap is about 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkap(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkap Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkap - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(xj,nxrkap-1._krealfp) - frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapq(pkap) -!$$$ Subprogram Documentation Block -! -! Subprogram: frkapq raise pressure to the 1/kappa power. -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. -! A quadratic interpolation is done between values in a lookup table -! computed in grkap. see documentation for frkapx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 11 decimal places. -! On the IBM, fpkap is almost 4 times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 94-12-30 Iredell standardized kappa, -! increased range and accuracy -! 1999-03-01 Iredell f90 module -! 1999-03-24 Iredell table lookup -! -! Usage: p=frkapq(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapq Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapq - real(krealfp),intent(in):: pkap - integer jx - real(krealfp) xj,dxj,fj1,fj2,fj3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) - jx=min(max(nint(xj),2),nxrkap-1) - dxj=xj-jx - fj1=tbrkap(jx-1) - fj2=tbrkap(jx) - fj3=tbrkap(jx+1) - frkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function frkapx(pkap) -!$$$ Subprogram documentation block -! -! Subprogram: frkapx raise pressure to the 1/kappa power. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: raise pressure over 1e5 Pa to the 1/kappa power. -! Kappa is equal to rd/cp where rd and cp are physical constants. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 94-12-30 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: p=frkapx(pkap) -! -! Input argument list: -! pkap Real(krealfp) p over 1e5 Pa to the kappa power -! -! Output argument list: -! frkapx Real(krealfp) pressure in Pascals -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) frkapx - real(krealfp),intent(in):: pkap -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - frkapx=pkap**(1/con_rocp)*1.e5_krealfp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gtlcl -!$$$ Subprogram Documentation Block -! -! Subprogram: gtlcl Compute equivalent potential temperature table -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute lifting condensation level temperature table -! as a function of temperature and dewpoint depression for function ftlcl. -! Lifting condensation level temperature is calculated in subprogram ftlclx -! The current implementation computes a table with a first dimension -! of 151 for temperatures ranging from 180.0 to 330.0 Kelvin -! and a second dimension of 61 for dewpoint depression ranging from -! 0 to 60 Kelvin. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gtlcl -! -! Subprograms called: -! (ftlclx) inlinable function to compute LCL temperature -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - integer jx,jy - real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,tdpd,t -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xmin=180._krealfp - xmax=330._krealfp - ymin=0._krealfp - ymax=60._krealfp - xinc=(xmax-xmin)/(nxtlcl-1) - c1xtlcl=1.-xmin/xinc - c2xtlcl=1./xinc - yinc=(ymax-ymin)/(nytlcl-1) - c1ytlcl=1.-ymin/yinc - c2ytlcl=1./yinc - do jy=1,nytlcl - y=ymin+(jy-1)*yinc - tdpd=y - do jx=1,nxtlcl - x=xmin+(jx-1)*xinc - t=x - tbtlcl(jx,jy)=ftlclx(t,tdpd) - enddo - enddo -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - elemental function ftlcl(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlcl Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A bilinear interpolation is done between values in a lookup table -! computed in gtlcl. See documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.0005 Kelvin. -! On the Cray, ftlcl is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlcl(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlcl - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,ftx1,ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(xj,nxtlcl-1._krealfp) - jy=min(yj,nytlcl-1._krealfp) - ftx1=tbtlcl(jx,jy)+(xj-jx)*(tbtlcl(jx+1,jy)-tbtlcl(jx,jy)) - ftx2=tbtlcl(jx,jy+1)+(xj-jx)*(tbtlcl(jx+1,jy+1)-tbtlcl(jx,jy+1)) - ftlcl=ftx1+(yj-jy)*(ftx2-ftx1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclq(t,tdpd) -!$$$ Subprogram Documentation Block -! -! Subprogram: ftlclq Compute LCL temperature -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. -! A biquadratic interpolation is done between values in a lookup table -! computed in gtlcl. see documentation for ftlclx for details. -! Input values outside table range are reset to table extrema. -! The interpolation accuracy is better than 0.000003 Kelvin. -! On the Cray, ftlclq is ? times faster than exact calculation. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclq(t,tdpd) -! -! Input argument list: -! t Real(krealfp) LCL temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlcl Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclq - real(krealfp),intent(in):: t,tdpd - integer jx,jy - real(krealfp) xj,yj,dxj,dyj - real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 - real(krealfp) ftx1,ftx2,ftx3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) - yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) - jx=min(max(nint(xj),2),nxtlcl-1) - jy=min(max(nint(yj),2),nytlcl-1) - dxj=xj-jx - dyj=yj-jy - ft11=tbtlcl(jx-1,jy-1) - ft12=tbtlcl(jx-1,jy) - ft13=tbtlcl(jx-1,jy+1) - ft21=tbtlcl(jx,jy-1) - ft22=tbtlcl(jx,jy) - ft23=tbtlcl(jx,jy+1) - ft31=tbtlcl(jx+1,jy-1) - ft32=tbtlcl(jx+1,jy) - ft33=tbtlcl(jx+1,jy+1) - ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 - ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 - ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 - ftlclq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - function ftlclo(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclo Compute LCL temperature. -! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. the formula used is -! a polynomial taken from Phillips mstadb routine which empirically -! approximates the original exact implicit relationship. -! (This kind of approximation is customary (inman, 1969), but -! the original source for this particular one is not yet known. -MI) -! Its accuracy is about 0.03 Kelvin for a dewpoint depression of 30. -! This function should be expanded inline in the calling routine. -! -! Program History Log: -! 91-05-07 Iredell made into inlinable function -! 1999-03-01 Iredell f90 module -! -! Usage: tlcl=ftlclo(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclo Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclo - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& - clcl3=-0.710321e-3,clcl4=-0.270742e-5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - elemental function ftlclx(t,tdpd) -!$$$ Subprogram documentation block -! -! Subprogram: ftlclx Compute LCL temperature. -! Author: Iredell org: w/NMC2X2 Date: 25 March 1999 -! -! Abstract: Compute temperature at the lifting condensation level -! from temperature and dewpoint depression. A parcel lifted -! adiabatically becomes saturated at the lifting condensation level. -! The water model assumes a perfect gas, constant specific heats -! for gas and liquid, and neglects the volume of the liquid. -! The model does account for the variation of the latent heat -! of condensation with temperature. The ice option is not included. -! The Clausius-Clapeyron equation is integrated from the triple point -! to get the formulas -! pvlcl=con_psat*(trlcl**xa)*exp(xb*(1.-trlcl)) -! pvdew=con_psat*(trdew**xa)*exp(xb*(1.-trdew)) -! where pvlcl is the saturated parcel vapor pressure at the LCL, -! pvdew is the unsaturated parcel vapor pressure initially, -! trlcl is ttp/tlcl and trdew is ttp/tdew. The adiabatic lifting -! of the parcel is represented by the following formula -! pvdew=pvlcl*(t/tlcl)**(1/kappa) -! This formula is inverted by iterating Newtonian approximations -! until tlcl is found to within 1.e-6 Kelvin. Note that the minimum -! returned temperature is 180 Kelvin. -! -! Program History Log: -! 1999-03-25 Iredell -! -! Usage: tlcl=ftlclx(t,tdpd) -! -! Input argument list: -! t Real(krealfp) temperature in Kelvin -! tdpd Real(krealfp) dewpoint depression in Kelvin -! -! Output argument list: -! ftlclx Real(krealfp) temperature at the LCL in Kelvin -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none - real(krealfp) ftlclx - real(krealfp),intent(in):: t,tdpd - real(krealfp),parameter:: terrm=1.e-4,tlmin=180.,tlminx=tlmin-5. - real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr,terrp - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tr=con_ttp/(t-tdpd) - pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) - tlcl=t-tdpd - do i=1,100 - tr=con_ttp/tlcl - ta=t/tlcl - pvlcl=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr))*ta**(1/con_rocp) - el=con_hvap+con_dldt*(tlcl-con_ttp) - dpvlcl=(el/(con_rv*t**2)+1/(con_rocp*tlcl))*pvlcl - terr=(pvlcl-pvdew)/dpvlcl - tlcl=tlcl-terr - if(abs(terr).le.terrm.or.tlcl.lt.tlminx) exit - enddo - ftlclx=max(tlcl,tlmin) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function -!------------------------------------------------------------------------------- - subroutine gfuncphys -!$$$ Subprogram Documentation Block -! -! Subprogram: gfuncphys Compute all physics function tables -! Author: N Phillips w/NMC2X2 Date: 30 dec 82 -! -! Abstract: Compute all physics function tables. Lookup tables are -! set up for computing saturation vapor pressure, dewpoint temperature, -! equivalent potential temperature, moist adiabatic temperature and humidity, -! pressure to the kappa, and lifting condensation level temperature. -! -! Program History Log: -! 1999-03-01 Iredell f90 module -! -! Usage: call gfuncphys -! -! Subprograms called: -! gpvsl compute saturation vapor pressure over liquid table -! gpvsi compute saturation vapor pressure over ice table -! gpvs compute saturation vapor pressure table -! gtdpl compute dewpoint temperature over liquid table -! gtdpi compute dewpoint temperature over ice table -! gtdp compute dewpoint temperature table -! gthe compute equivalent potential temperature table -! gtma compute moist adiabat tables -! gpkap compute pressure to the kappa table -! grkap compute pressure to the 1/kappa table -! gtlcl compute LCL temperature table -! -! Attributes: -! Language: Fortran 90. -! -!$$$ - implicit none -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call gpvsl - call gpvsi - call gpvs - call gtdpl - call gtdpi - call gtdp - call gthe - call gtma - call gpkap - call grkap - call gtlcl -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/sorc/global_chgres.fd/global_chgres_users_guide.md b/sorc/global_chgres.fd/global_chgres_users_guide.md deleted file mode 100755 index f4fd94187..000000000 --- a/sorc/global_chgres.fd/global_chgres_users_guide.md +++ /dev/null @@ -1,141 +0,0 @@ -@brief HOW TO CONVERT A SURFACE RESTART FILE @anchor global_chgres_users_guide - -1.0 INTRODUCTION - -NEAREST NEIGHBOR INTERPOLATION IS PERFORMED SO THAT LAND/NONLAND -POINTS ON THE INPUT GRID ARE MAPPED TO LAND/NONLAND POINTS -ON THE TARGET GRID. IF THE INPUT FILE CONTAINS LANDICE -AND THE OUTPUT GRID IS TO HAVE LANDICE, THEN NONLAND IS -MAPPED TO NONLAND, LANDICE IS MAPPED TO LANDICE, ICE FREE -LAND IS MAPPED TO ICE FREE LAND. OPTIONALLY, THE CLIMO FIELDS -SUCH AS ALBEDO, ROUGHNESS, ETC, MAY DETERMINED ON THE OUTPUT -GRID FROM SFCCYCLE (WHICH IS CALLED FROM THE SURFACE -CHGRES MODULE). THE LATTER IS RECOMMENDED WHEN CONVERTING -FROM A LOW TO HIGH RESOLUTION GRID. A NEW LAND-SEA MASK IS -OPTIONALLY READ IN. IF IT IS MISSING, THE NEW LAND-SEA MASK IS -INTERPOLATED FROM THE OLD MASK. SKIN AND SOIL TEMPERATURE OVER -LAND ARE ADJUSTED FOR DIFFERENCES BETWEEN THE INPUT AND OUTPUT -OROGRAPHY. LIQ SOIL MOISTURE IS CALCULATED ACCORDING TO THE -ADJUSTED TEMP. OUTPUT OROGRAPHY MAY BE READ IN FROM FILE OR INTERPOLATED -FROM INPUT OROGRAPHY. NOTE: OLDER VERSIONS OF THE SURFACE -RESTART FILE (BEFORE IVS 200501) DO NOT HAVE OROGRAPHY RECORDS. -IN CASES WHERE THE INPUT SURFACE FILE IS PRE 200501, -THE PROGRAM WILL GET THE OROGRAPHY FROM THE SIGMA FILE. -THEREFORE, YOU MUST SET THE OPTIONS TO CONVERT A SIGMA FILE -AS WELL AS A SURFACE FILE. WHEN CHANGING A PRE 200501 FILE, -THE PROGRAM WILL INTERPOLATE ONLY THOSE LAND FIELDS NEEDED -TO RUN THE OLD OSU LAND MODEL AND OLD SEA ICE PHYSICS. -WHEN CHANGING A 200501 FILE, THE PROGRAM WILL INTERPOLATE/CALC -THOSE ADDITIONAL FIELDS NEEDED BY THE NOAH LSM (MAX SNOW ALB, -LIQ. SOIL MOIST, SNOW DEPTH, PRECIP, PRECIP TYPE, SLOPE TYPE, -MAX/MIN GREENNESS) AND THE NEW SEA ICE MODEL (ICE DEPTH AND -FRACTION). WHEN CHANGING A PRE 200501 FILE TO A 200501 FILE, -THE PROGRAM WILL AUTOMATICALLY INITIALIZE THE ABOVE -MENTIONED FIELDS USING EITHER GUESS VALUES OR VALUES -CALCULATED FROM SFCCYCLE. THE PROGRAM WILL ALSO CONVERT FROM TWO -TO FOUR SOIL LAYERS AND VICE VERSA. THE PROGRAM WILL RUN -ON THE FULL OR REDUCED GRID DEPENDING ON THE LONSPERLAT -RECORD OF THE INPUT FILE OR WHETHER THE USER SPECIFIES -AN EXTERNAL LONSPERLAT FILE. THE PROGRAM WILL INITIALIZE -ALL LAND STATES FOR THE LANDICE PHYSICS IF DESIRED. THE PROGRAM -WILL SCALE TOTAL SOIL MOISTURE FOR ANY DIFFERENCES IN SOIL -TYPE BETWEEN THE INPUT AND OUTPUT GRIDS. CONTACT G. GAYNO -WITH QUESTIONS. - -2.0 HOW TO RUN CHGRES - -THE PROGRAM IS CONTROLLED BY SETTING SEVERAL ENVIRONMENT VARIABLES -IN THE DRIVER SCRIPT. - -LSOIL - NUMBER OF SOIL LAYERS ON OUTPUT GRID. WHEN NOT SET, THE - DEFAULT IS SAME AS INPUT GRID. OTHERWISE, MAY BE SET TO - 2 OR 4 LAYERS. - -IVSSFC - THE VERSION NUMBER OF THE SURFACE RESTART FILE - -LANDICE_OPT - THE LANDICE PHYSICS OPTIONS: - 1-NO LANDICE ON INPUT GRID -> INITIALIZE LANDICE ON OUTPUT GRID - 2-LANDICE ON INPUT GRID -> LANDICE ON OUTPUT GRID - 3-NO LANDICE ON INPUT GRID -> NO LANDICE ON OUTPUT GRID - 4-LANDICE ON INPUT GRID -> REMOVE LANDICE FROM OUTPUT GRID - 5-INITIALIZE LANDICE OUTPUT GRID REGARDLESS OF WHETHER - INPUT GRID HAS LANDICE OR NOT. - -CLIMO_FIELDS_OPT - OPTION FOR DETERMINING CLIMATOLOGICAL FIELDS ON - OUTPUT GRID. - 1-INTERPOLATE ALL FROM INPUT GRID - 2-INTERPOLATE VEG, SOIL, SLOPE TYPE - FROM INPUT GRID. OTHERS FROM - SFCCYCLE PROGRAM. - 3-ALL FROM SFCCYCLE PROGRAM. - -#-------------------------------------------------------------------- -# Example #1: convert a t382 file with 4 soil layers and noah lsm -# physics and NO landice, to a 254 file with 2 soil layers and -# osu lsm physics (and no landice). -#-------------------------------------------------------------------- - -export CLIMO_FIELDS_OPT=3 -export LANDICE_OPT=3 -export IVSSFC=200004 -export LSOIL=2 - -./global_chgres.sh NULL \ - ./t382.sfc.input.file \ - NULL \ - ./t254.sfc.output.file \ - 254 0 768 384 - -#-------------------------------------------------------------------- -# Example #2: convert a t382 file with 4 soil layers and noah lsm -# physics AND landice fields, to a 254 file with 2 soil layers and -# osu lsm physics (and no landice). -#-------------------------------------------------------------------- - -export CLIMO_FIELDS_OPT=3 -export LANDICE_OPT=4 -export IVSSFC=200004 -export LSOIL=2 - -./global_chgres.sh NULL \ - ./t382.sfc.input.file \ - NULL \ - ./t254.sfc.output.file \ - 254 0 768 384 - -#-------------------------------------------------------------------- -# Example #3: convert a t254 file with 2 soil layers and osu lsm -# physics, to a t382 file with 4 soil layers and noah lsm physics and -# NO landice initialization. -# note: the old style surface files do not have terrain, so you -# must get this field from a sigma file. -#-------------------------------------------------------------------- - -export CLIMO_FIELDS_OPT=3 -export LANDICE_OPT=3 -export IVSSFC=200501 -export LSOIL=4 - -./global_chgres.sh ./t254.sig.input.file \ - ./t254.sfc.input.file \ - ./t382.sig.output.file \ - ./t382.sfc.output.file 382 0 1152 576 - -#-------------------------------------------------------------------- -# Example #4: convert a t254 file with 2 soil layers and osu lsm -# physics, to a t382 file with 4 soil layers and noah lsm physics -# and landice initialization. -# note: the old style surface files do not have terrain, so you -# must get this field from a sigma file. -#-------------------------------------------------------------------- - -export CLIMO_FIELDS_OPT=3 -export LANDICE_OPT=1 -export IVSSFC=200501 -export LSOIL=4 - -./global_chgres.sh ./t254.sig.input.file \ - ./t254.sfc.input.file \ - ./t382.sig.output.file \ - ./t382.sfc.output.file 382 0 1152 576 - diff --git a/sorc/global_chgres.fd/machine_8.f90 b/sorc/global_chgres.fd/machine_8.f90 deleted file mode 100755 index 381348421..000000000 --- a/sorc/global_chgres.fd/machine_8.f90 +++ /dev/null @@ -1,18 +0,0 @@ -!> @file -MODULE MACHINE - -! Machine dependant constants - - IMPLICIT NONE - - SAVE - - integer kind_io4,kind_io8,kind_phys,kind_rad - parameter (kind_rad = selected_real_kind(13,60)) ! the '60' maps to 64-bit real - parameter (kind_phys = selected_real_kind(13,60)) ! the '60' maps to 64-bit real - parameter (kind_io4 = 4) - parameter (kind_io8 = 8) - integer kint_mpi - parameter (kint_mpi = 4) - - END MODULE MACHINE diff --git a/sorc/global_chgres.fd/nrlmsise00_sub.f90 b/sorc/global_chgres.fd/nrlmsise00_sub.f90 deleted file mode 100755 index 2da0575af..000000000 --- a/sorc/global_chgres.fd/nrlmsise00_sub.f90 +++ /dev/null @@ -1,2428 +0,0 @@ -!> @file -! -!> Neutral Atmosphere Empirical Model from the surface to lower -!! exosphere -!! -!! NEW FEATURES: -!! *Extensive satellite drag database used in model generation -!! *Revised O2 (and O) in lower thermosphere -!! *Additional nonlinear solar activity term -!! *"ANOMALOUS OXYGEN" NUMBER DENSITY, OUTPUT D(9) -!! At high altitudes (> 500 km), hot atomic oxygen or ionized -!! oxygen can become appreciable for some ranges of subroutine -!! inputs, thereby affecting drag on satellites and debris. We -!! group these species under the term "anomalous oxygen," since -!! their individual variations are not presently separable with -!! the drag data used to define this model component. -!! -!! SUBROUTINES FOR SPECIAL OUTPUTS: -!! -!! HIGH ALTITUDE DRAG: EFFECTIVE TOTAL MASS DENSITY -!! (SUBROUTINE GTD7D, OUTPUT D(6)) -!! For atmospheric drag calculations at altitudes above 500 km, -!! call SUBROUTINE GTD7D to compute the "effective total mass -!! density" by including contributions from "anomalous oxygen." -!! See "NOTES ON OUTPUT VARIABLES" below on D(6). -!! -!! PRESSURE GRID (SUBROUTINE GHP7) -!! See subroutine GHP7 to specify outputs at a pressure level -!! rather than at an altitude. -!! -!! OUTPUT IN M-3 and KG/M3: CALL METERS(.TRUE.) -!! -!! INPUT VARIABLES: -!! - IYD - YEAR AND DAY AS YYDDD (day of year from 1 to 365 (or 366) -!! (Year ignored in current model) -!! - SEC - UT(SEC) -!! - ALT - ALTITUDE(KM) -!! - GLAT - GEODETIC LATITUDE(DEG) -!! - GLONG - GEODETIC LONGITUDE(DEG) -!! - STL - LOCAL APPARENT SOLAR TIME(HRS; see Note below) -!! - F107A - 81 day AVERAGE OF F10.7 FLUX (centered on day DDD) -!! - F107 - DAILY F10.7 FLUX FOR PREVIOUS DAY -!! - AP - MAGNETIC INDEX(DAILY) OR WHEN SW(9)=-1. : -!! ARRAY CONTAINING: -!! (1) DAILY AP -!! (2) 3 HR AP INDEX FOR CURRENT TIME -!! (3) 3 HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME -!! (4) 3 HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME -!! (5) 3 HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME -!! (6) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 12 TO 33 HRS PR -!! TO CURRENT TIME -!! (7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 57 HRS PR -!! TO CURRENT TIME -!! - MASS - MASS NUMBER (ONLY DENSITY FOR SELECTED GAS IS -!! CALCULATED. MASS 0 IS TEMPERATURE. MASS 48 FOR ALL. -!! MASS 17 IS Anomalous O ONLY.) -!! -!! ## NOTES ON INPUT VARIABLES: -!! UT, Local Time, and Longitude are used independently in the -!! model and are not of equal importance for every situation. -!! For the most physically realistic calculation these three -!! variables should be consistent (STL=SEC/3600+GLONG/15). -!! The Equation of Time departures from the above formula -!! for apparent local time can be included if available but -!! are of minor importance. -!! -!! F107 and F107A values used to generate the model correspond -!! to the 10.7 cm radio flux at the actual distance of the Earth -!! from the Sun rather than the radio flux at 1 AU. The following -!! site provides both classes of values: -!! ftp://ftp.ngdc.noaa.gov/STP/SOLAR_DATA/SOLAR_RADIO/FLUX/ -!! -!! F107, F107A, and AP effects are neither large nor well -!! established below 80 km and these parameters should be set to -!! 150., 150., and 4. respectively. -!! -!! OUTPUT VARIABLES: -!! - D(1) - HE NUMBER DENSITY(CM-3) -!! - D(2) - O NUMBER DENSITY(CM-3) -!! - D(3) - N2 NUMBER DENSITY(CM-3) -!! - D(4) - O2 NUMBER DENSITY(CM-3) -!! - D(5) - AR NUMBER DENSITY(CM-3) -!! - D(6) - TOTAL MASS DENSITY(GM/CM3) -!! - D(7) - H NUMBER DENSITY(CM-3) -!! - D(8) - N NUMBER DENSITY(CM-3) -!! - D(9) - Anomalous oxygen NUMBER DENSITY(CM-3) -!! - T(1) - EXOSPHERIC TEMPERATURE -!! - T(2) - TEMPERATURE AT ALT -!! -!! NOTES ON OUTPUT VARIABLES: -!! TO GET OUTPUT IN M-3 and KG/M3: CALL METERS(.TRUE.) -!! -!! O, H, and N are set to zero below 72.5 km -!! -!! T(1), Exospheric temperature, is set to global average for -!! altitudes below 120 km. The 120 km gradient is left at global -!! average value for altitudes below 72 km. -!! -!! D(6), TOTAL MASS DENSITY, is NOT the same for subroutines GTD7 -!! and GTD7D -!! -!! - SUBROUTINE GTD7 -- D(6) is the sum of the mass densities of t -!! species labeled by indices 1-5 and 7-8 in output variable D. -!! This includes He, O, N2, O2, Ar, H, and N but does NOT includ -!! anomalous oxygen (species index 9). -!! -!! - SUBROUTINE GTD7D -- D(6) is the "effective total mass density -!! for drag" and is the sum of the mass densities of all species -!! in this model, INCLUDING anomalous oxygen. -!! -!! SWITCHES: The following is for test and special purposes: -!! -!! TO TURN ON AND OFF PARTICULAR VARIATIONS CALL TSELEC(SW), -!! WHERE SW IS A 25 ELEMENT ARRAY CONTAINING 0. FOR OFF, 1. -!! FOR ON, OR 2. FOR MAIN EFFECTS OFF BUT CROSS TERMS ON -!! FOR THE FOLLOWING VARIATIONS -!! 
-!!               1 - F10.7 EFFECT ON MEAN  2 - TIME INDEPENDENT          
-!!               3 - SYMMETRICAL ANNUAL    4 - SYMMETRICAL SEMIANNUAL    
-!!               5 - ASYMMETRICAL ANNUAL   6 - ASYMMETRICAL SEMIANNUAL   
-!!               7 - DIURNAL               8 - SEMIDIURNAL               
-!!               9 - DAILY AP             10 - ALL UT/LONG EFFECTS       
-!!              11 - LONGITUDINAL         12 - UT AND MIXED UT/LONG      
-!!              13 - MIXED AP/UT/LONG     14 - TERDIURNAL                
-!!              15 - DEPARTURES FROM DIFFUSIVE EQUILIBRIUM               
-!!              16 - ALL TINF VAR         17 - ALL TLB VAR               
-!!              18 - ALL TN1 VAR           19 - ALL S VAR                
-!!              20 - ALL TN2 VAR           21 - ALL NLB VAR              
-!!              22 - ALL TN3 VAR           23 - TURBO SCALE HEIGHT VAR   
-!!
-!! -!! To get current values of SW: CALL TRETRV(SW) -!! - SUBROUTINE GTD7(IYD,SEC,ALT,GLAT,GLONG,STL,F107A,F107,AP,MASS,D,T) - DIMENSION D(9),T(2),AP(7),DS(9),TS(2) - DIMENSION ZN3(5),ZN2(4),SV(25) - COMMON/GTS3C/TLB,S,DB04,DB16,DB28,DB32,DB40,DB48,DB01,ZA,T0,Z0 & - ,G0,RL,DD,DB14,TR12 - COMMON/MESO7/TN1(5),TN2(4),TN3(5),TGN1(2),TGN2(2),TGN3(2) - COMMON/LOWER7/PTM(10),PDM(10,8) - COMMON/PARM7/PT(150),PD(150,9),PS(150),PDL(25,2),PTL(100,4), & - PMA(100,10),SAM(100) - COMMON/DATIM7/ISD(3),IST(2),NAM(2) - COMMON/DATIME/ISDATE(3),ISTIME(2),NAME(2) -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - COMMON/MAVG7/PAVGM(10) - COMMON/DMIX/DM04,DM16,DM28,DM32,DM40,DM01,DM14 - COMMON/PARMB/GSURF,RE - COMMON/METSEL/IMR - SAVE - EXTERNAL GTD7BK - DATA MN3/5/,ZN3/32.5,20.,15.,10.,0./ - DATA MN2/4/,ZN2/72.5,55.,45.,32.5/ - DATA ZMIX/62.5/,ALAST/99999./,MSSL/-999/ - DATA SV/25*1./ - IF(ISW.NE.64999) CALL TSELEC(SV) -! Put identification data into common/datime/ - DO 1 I=1,3 - ISDATE(I)=ISD(I) - 1 END DO - DO 2 I=1,2 - ISTIME(I)=IST(I) - NAME(I)=NAM(I) - 2 END DO -! -! Test for changed input - V1=VTST7(IYD,SEC,GLAT,GLONG,STL,F107A,F107,AP,1) -! Latitude variation of gravity (none for SW(2)=0) - XLAT=GLAT - IF(SW(2).EQ.0) XLAT=45. - CALL GLATF(XLAT,GSURF,RE) -! - XMM=PDM(5,3) -! -! THERMOSPHERE/MESOSPHERE (above ZN2(1)) - ALTT=AMAX1(ALT,ZN2(1)) - MSS=MASS -! Only calculate N2 in thermosphere if alt in mixed region - IF(ALT.LT.ZMIX.AND.MASS.GT.0) MSS=28 -! Only calculate thermosphere if input parameters changed -! or altitude above ZN2(1) in mesosphere - IF(V1.EQ.1..OR.ALT.GT.ZN2(1).OR.ALAST.GT.ZN2(1).OR.MSS.NE.MSSL) THEN - CALL GTS7(IYD,SEC,ALTT,GLAT,GLONG,STL,F107A,F107,AP,MSS,DS,TS) - DM28M=DM28 -! metric adjustment - IF(IMR.EQ.1) DM28M=DM28*1.E6 - MSSL=MSS - ENDIF - T(1)=TS(1) - T(2)=TS(2) - IF(ALT.GE.ZN2(1)) THEN - DO 5 J=1,9 - D(J)=DS(J) - 5 CONTINUE - GOTO 10 - ENDIF -! -! LOWER MESOSPHERE/UPPER STRATOSPHERE [between ZN3(1) and ZN2(1)] -! Temperature at nodes and gradients at end nodes -! Inverse temperature a linear function of spherical harmonics -! Only calculate nodes if input changed - IF(V1.EQ.1..OR.ALAST.GE.ZN2(1)) THEN - TGN2(1)=TGN1(2) - TN2(1)=TN1(5) - TN2(2)=PMA(1,1)*PAVGM(1)/(1.-SW(20)*GLOB7S(PMA(1,1))) - TN2(3)=PMA(1,2)*PAVGM(2)/(1.-SW(20)*GLOB7S(PMA(1,2))) - TN2(4)=PMA(1,3)*PAVGM(3)/(1.-SW(20)*SW(22)*GLOB7S(PMA(1,3))) - TGN2(2)=PAVGM(9)*PMA(1,10)*(1.+SW(20)*SW(22)*GLOB7S(PMA(1,10))) & - *TN2(4)*TN2(4)/(PMA(1,3)*PAVGM(3))**2 - TN3(1)=TN2(4) - ENDIF - IF(ALT.GE.ZN3(1)) GOTO 6 -! -! LOWER STRATOSPHERE AND TROPOSPHERE [below ZN3(1)] -! Temperature at nodes and gradients at end nodes -! Inverse temperature a linear function of spherical harmonics -! Only calculate nodes if input changed - IF(V1.EQ.1..OR.ALAST.GE.ZN3(1)) THEN - TGN3(1)=TGN2(2) - TN3(2)=PMA(1,4)*PAVGM(4)/(1.-SW(22)*GLOB7S(PMA(1,4))) - TN3(3)=PMA(1,5)*PAVGM(5)/(1.-SW(22)*GLOB7S(PMA(1,5))) - TN3(4)=PMA(1,6)*PAVGM(6)/(1.-SW(22)*GLOB7S(PMA(1,6))) - TN3(5)=PMA(1,7)*PAVGM(7)/(1.-SW(22)*GLOB7S(PMA(1,7))) - TGN3(2)=PMA(1,8)*PAVGM(8)*(1.+SW(22)*GLOB7S(PMA(1,8))) & - *TN3(5)*TN3(5)/(PMA(1,7)*PAVGM(7))**2 - ENDIF - 6 CONTINUE - IF(MASS.EQ.0) GOTO 50 -! LINEAR TRANSITION TO FULL MIXING BELOW ZN2(1) - DMC=0 - IF(ALT.GT.ZMIX) DMC=1.-(ZN2(1)-ALT)/(ZN2(1)-ZMIX) - DZ28=DS(3) -! ***** N2 DENSITY **** - DMR=DS(3)/DM28M-1. - D(3)=DENSM(ALT,DM28M,XMM,TZ,MN3,ZN3,TN3,TGN3,MN2,ZN2,TN2,TGN2) - D(3)=D(3)*(1.+DMR*DMC) -! ***** HE DENSITY **** - D(1)=0 - IF(MASS.NE.4.AND.MASS.NE.48) GOTO 204 - DMR=DS(1)/(DZ28*PDM(2,1))-1. - D(1)=D(3)*PDM(2,1)*(1.+DMR*DMC) - 204 CONTINUE -! **** O DENSITY **** - D(2)=0 - D(9)=0 - 216 CONTINUE -! ***** O2 DENSITY **** - D(4)=0 - IF(MASS.NE.32.AND.MASS.NE.48) GOTO 232 - DMR=DS(4)/(DZ28*PDM(2,4))-1. - D(4)=D(3)*PDM(2,4)*(1.+DMR*DMC) - 232 CONTINUE -! ***** AR DENSITY **** - D(5)=0 - IF(MASS.NE.40.AND.MASS.NE.48) GOTO 240 - DMR=DS(5)/(DZ28*PDM(2,5))-1. - D(5)=D(3)*PDM(2,5)*(1.+DMR*DMC) - 240 CONTINUE -! ***** HYDROGEN DENSITY **** - D(7)=0 -! ***** ATOMIC NITROGEN DENSITY **** - D(8)=0 -! -! TOTAL MASS DENSITY -! - IF(MASS.EQ.48) THEN - D(6) = 1.66E-24*(4.*D(1)+16.*D(2)+28.*D(3)+32.*D(4)+40.*D(5)+ & - D(7)+14.*D(8)) - IF(IMR.EQ.1) D(6)=D(6)/1000. - ENDIF - T(2)=TZ - 10 CONTINUE - GOTO 90 - 50 CONTINUE - DD=DENSM(ALT,1.,0,TZ,MN3,ZN3,TN3,TGN3,MN2,ZN2,TN2,TGN2) - T(2)=TZ - 90 CONTINUE - ALAST=ALT - RETURN - END SUBROUTINE GTD7 -!----------------------------------------------------------------------- - SUBROUTINE GTD7D(IYD,SEC,ALT,GLAT,GLONG,STL,F107A,F107,AP,MASS,D,T) -! -! NRLMSISE-00 -! ----------- -! This subroutine provides Effective Total Mass Density for -! output D(6) which includes contributions from "anomalous -! oxygen" which can affect satellite drag above 500 km. This -! subroutine is part of the distribution package for the -! Neutral Atmosphere Empirical Model from the surface to lower -! exosphere. See subroutine GTD7 for more extensive comments. -! -! INPUT VARIABLES: -! IYD - YEAR AND DAY AS YYDDD (day of year from 1 to 365 (or 366) -! (Year ignored in current model) -! SEC - UT(SEC) -! ALT - ALTITUDE(KM) -! GLAT - GEODETIC LATITUDE(DEG) -! GLONG - GEODETIC LONGITUDE(DEG) -! STL - LOCAL APPARENT SOLAR TIME(HRS; see Note below) -! F107A - 81 day AVERAGE OF F10.7 FLUX (centered on day DDD) -! F107 - DAILY F10.7 FLUX FOR PREVIOUS DAY -! AP - MAGNETIC INDEX(DAILY) OR WHEN SW(9)=-1. : -! - ARRAY CONTAINING: -! (1) DAILY AP -! (2) 3 HR AP INDEX FOR CURRENT TIME -! (3) 3 HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME -! (4) 3 HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME -! (5) 3 HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME -! (6) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 12 TO 33 HRS PR -! TO CURRENT TIME -! (7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 57 HRS PR -! TO CURRENT TIME -! MASS - MASS NUMBER (ONLY DENSITY FOR SELECTED GAS IS -! CALCULATED. MASS 0 IS TEMPERATURE. MASS 48 FOR ALL. -! MASS 17 IS Anomalous O ONLY.) -! -! NOTES ON INPUT VARIABLES: -! UT, Local Time, and Longitude are used independently in the -! model and are not of equal importance for every situation. -! For the most physically realistic calculation these three -! variables should be consistent (STL=SEC/3600+GLONG/15). -! The Equation of Time departures from the above formula -! for apparent local time can be included if available but -! are of minor importance. -! -! F107 and F107A values used to generate the model correspond -! to the 10.7 cm radio flux at the actual distance of the Earth -! from the Sun rather than the radio flux at 1 AU. -! -! OUTPUT VARIABLES: -! D(1) - HE NUMBER DENSITY(CM-3) -! D(2) - O NUMBER DENSITY(CM-3) -! D(3) - N2 NUMBER DENSITY(CM-3) -! D(4) - O2 NUMBER DENSITY(CM-3) -! D(5) - AR NUMBER DENSITY(CM-3) -! D(6) - TOTAL MASS DENSITY(GM/CM3) [includes anomalous oxygen] -! D(7) - H NUMBER DENSITY(CM-3) -! D(8) - N NUMBER DENSITY(CM-3) -! D(9) - Anomalous oxygen NUMBER DENSITY(CM-3) -! T(1) - EXOSPHERIC TEMPERATURE -! T(2) - TEMPERATURE AT ALT -! - DIMENSION D(9),T(2),AP(7),DS(9),TS(2) - COMMON/METSEL/IMR - CALL GTD7(IYD,SEC,ALT,GLAT,GLONG,STL,F107A,F107,AP,MASS,D,T) -! TOTAL MASS DENSITY -! - IF(MASS.EQ.48) THEN - D(6) = 1.66E-24*(4.*D(1)+16.*D(2)+28.*D(3)+32.*D(4)+40.*D(5)+ & - D(7)+14.*D(8)+16.*D(9)) - IF(IMR.EQ.1) D(6)=D(6)/1000. - ENDIF - RETURN - END SUBROUTINE GTD7D -!----------------------------------------------------------------------- - SUBROUTINE GHP7(IYD,SEC,ALT,GLAT,GLONG,STL,F107A,F107,AP,D,T,PRESS) -! FIND ALTITUDE OF PRESSURE SURFACE (PRESS) FROM GTD7 -! INPUT: -! IYD - YEAR AND DAY AS YYDDD -! SEC - UT(SEC) -! GLAT - GEODETIC LATITUDE(DEG) -! GLONG - GEODETIC LONGITUDE(DEG) -! STL - LOCAL APPARENT SOLAR TIME(HRS) -! F107A - 3 MONTH AVERAGE OF F10.7 FLUX -! F107 - DAILY F10.7 FLUX FOR PREVIOUS DAY -! AP - MAGNETIC INDEX(DAILY) OR WHEN SW(9)=-1. : -! - ARRAY CONTAINING: -! (1) DAILY AP -! (2) 3 HR AP INDEX FOR CURRENT TIME -! (3) 3 HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME -! (4) 3 HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME -! (5) 3 HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME -! (6) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 12 TO 33 HRS PR -! TO CURRENT TIME -! (7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 59 HRS PR -! TO CURRENT TIME -! PRESS - PRESSURE LEVEL(MB) -! OUTPUT: -! ALT - ALTITUDE(KM) -! D(1) - HE NUMBER DENSITY(CM-3) -! D(2) - O NUMBER DENSITY(CM-3) -! D(3) - N2 NUMBER DENSITY(CM-3) -! D(4) - O2 NUMBER DENSITY(CM-3) -! D(5) - AR NUMBER DENSITY(CM-3) -! D(6) - TOTAL MASS DENSITY(GM/CM3) -! D(7) - H NUMBER DENSITY(CM-3) -! D(8) - N NUMBER DENSITY(CM-3) -! D(9) - HOT O NUMBER DENSITY(CM-3) -! T(1) - EXOSPHERIC TEMPERATURE -! T(2) - TEMPERATURE AT ALT -! - COMMON/PARMB/GSURF,RE - COMMON/METSEL/IMR - DIMENSION D(9),T(2),AP(7) - SAVE - DATA BM/1.3806E-19/,RGAS/831.4/ - DATA TEST/.00043/,LTEST/12/ - PL=ALOG10(PRESS) -! Initial altitude estimate - IF(PL.GE.-5.) THEN - IF(PL.GT.2.5) ZI=18.06*(3.00-PL) - IF(PL.GT..75.AND.PL.LE.2.5) ZI=14.98*(3.08-PL) - IF(PL.GT.-1..AND.PL.LE..75) ZI=17.8*(2.72-PL) - IF(PL.GT.-2..AND.PL.LE.-1.) ZI=14.28*(3.64-PL) - IF(PL.GT.-4..AND.PL.LE.-2.) ZI=12.72*(4.32-PL) - IF(PL.LE.-4.) ZI=25.3*(.11-PL) - IDAY=MOD(IYD,1000) - CL=GLAT/90. - CL2=CL*CL - IF(IDAY.LT.182) CD=1.-IDAY/91.25 - IF(IDAY.GE.182) CD=IDAY/91.25-3. - CA=0 - IF(PL.GT.-1.11.AND.PL.LE.-.23) CA=1.0 - IF(PL.GT.-.23) CA=(2.79-PL)/(2.79+.23) - IF(PL.LE.-1.11.AND.PL.GT.-3.) CA=(-2.93-PL)/(-2.93+1.11) - Z=ZI-4.87*CL*CD*CA-1.64*CL2*CA+.31*CA*CL - ENDIF - IF(PL.LT.-5.) Z=22.*(PL+4.)**2+110 -! ITERATION LOOP - L=0 - 10 CONTINUE - L=L+1 - CALL GTD7(IYD,SEC,Z,GLAT,GLONG,STL,F107A,F107,AP,48,D,T) - XN=D(1)+D(2)+D(3)+D(4)+D(5)+D(7)+D(8) - P=BM*XN*T(2) - IF(IMR.EQ.1) P=P*1.E-6 - DIFF=PL-ALOG10(P) - IF(ABS(DIFF).LT.TEST .OR. L.EQ.LTEST) GOTO 20 - XM=D(6)/XN/1.66E-24 - IF(IMR.EQ.1) XM = XM*1.E3 - G=GSURF/(1.+Z/RE)**2 - SH=RGAS*T(2)/(XM*G) -! New altitude estimate using scale height - IF(L.LT.6) THEN - Z=Z-SH*DIFF*2.302 - ELSE - Z=Z-SH*DIFF - ENDIF - GOTO 10 - 20 CONTINUE - IF(L.EQ.LTEST) WRITE(6,100) PRESS,DIFF - 100 FORMAT(1X,29HGHP7 NOT CONVERGING FOR PRESS, 1PE12.2,E12.2) - ALT=Z - RETURN - END SUBROUTINE GHP7 -!----------------------------------------------------------------------- - SUBROUTINE GLATF(LAT,GV,REFF) -! CALCULATE LATITUDE VARIABLE GRAVITY (GV) AND EFFECTIVE -! RADIUS (REFF) - REAL LAT - SAVE - DATA DGTR/1.74533E-2/ - C2 = COS(2.*DGTR*LAT) - GV = 980.616*(1.-.0026373*C2) - REFF = 2.*GV/(3.085462E-6 + 2.27E-9*C2)*1.E-5 - RETURN - END SUBROUTINE GLATF -!----------------------------------------------------------------------- - FUNCTION VTST7(IYD,SEC,GLAT,GLONG,STL,F107A,F107,AP,IC) -! Test if geophysical variables or switches changed and save -! Return 0 if unchanged and 1 if changed - DIMENSION AP(7),IYDL(2),SECL(2),GLATL(2),GLL(2),STLL(2) - DIMENSION FAL(2),FL(2),APL(7,2),SWL(25,2),SWCL(25,2) -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - SAVE - DATA IYDL/2*-999/,SECL/2*-999./,GLATL/2*-999./,GLL/2*-999./ - DATA STLL/2*-999./,FAL/2*-999./,FL/2*-999./,APL/14*-999./ - DATA SWL/50*-999./,SWCL/50*-999./ - VTST7=0 - IF(IYD.NE.IYDL(IC)) GOTO 10 - IF(SEC.NE.SECL(IC)) GOTO 10 - IF(GLAT.NE.GLATL(IC)) GOTO 10 - IF(GLONG.NE.GLL(IC)) GOTO 10 - IF(STL.NE.STLL(IC)) GOTO 10 - IF(F107A.NE.FAL(IC)) GOTO 10 - IF(F107.NE.FL(IC)) GOTO 10 - DO 5 I=1,7 - IF(AP(I).NE.APL(I,IC)) GOTO 10 - 5 END DO - DO 7 I=1,25 - IF(SW(I).NE.SWL(I,IC)) GOTO 10 - IF(SWC(I).NE.SWCL(I,IC)) GOTO 10 - 7 END DO - GOTO 20 - 10 CONTINUE - VTST7=1 - IYDL(IC)=IYD - SECL(IC)=SEC - GLATL(IC)=GLAT - GLL(IC)=GLONG - STLL(IC)=STL - FAL(IC)=F107A - FL(IC)=F107 - DO 15 I=1,7 - APL(I,IC)=AP(I) - 15 END DO - DO 16 I=1,25 - SWL(I,IC)=SW(I) - SWCL(I,IC)=SWC(I) - 16 END DO - 20 CONTINUE - RETURN - END FUNCTION VTST7 -!----------------------------------------------------------------------- - SUBROUTINE GTS7(IYD,SEC,ALT,GLAT,GLONG,STL,F107A,F107,AP,MASS,D,T) -! -! Thermospheric portion of NRLMSISE-00 -! See GTD7 for more extensive comments -! -! OUTPUT IN M-3 and KG/M3: CALL METERS(.TRUE.) -! -! INPUT VARIABLES: -! IYD - YEAR AND DAY AS YYDDD (day of year from 1 to 365 (or 366) -! (Year ignored in current model) -! SEC - UT(SEC) -! ALT - ALTITUDE(KM) (>72.5 km) -! GLAT - GEODETIC LATITUDE(DEG) -! GLONG - GEODETIC LONGITUDE(DEG) -! STL - LOCAL APPARENT SOLAR TIME(HRS; see Note below) -! F107A - 81 day AVERAGE OF F10.7 FLUX (centered on day DDD) -! F107 - DAILY F10.7 FLUX FOR PREVIOUS DAY -! AP - MAGNETIC INDEX(DAILY) OR WHEN SW(9)=-1. : -! - ARRAY CONTAINING: -! (1) DAILY AP -! (2) 3 HR AP INDEX FOR CURRENT TIME -! (3) 3 HR AP INDEX FOR 3 HRS BEFORE CURRENT TIME -! (4) 3 HR AP INDEX FOR 6 HRS BEFORE CURRENT TIME -! (5) 3 HR AP INDEX FOR 9 HRS BEFORE CURRENT TIME -! (6) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 12 TO 33 HRS PR -! TO CURRENT TIME -! (7) AVERAGE OF EIGHT 3 HR AP INDICIES FROM 36 TO 57 HRS PR -! TO CURRENT TIME -! MASS - MASS NUMBER (ONLY DENSITY FOR SELECTED GAS IS -! CALCULATED. MASS 0 IS TEMPERATURE. MASS 48 FOR ALL. -! MASS 17 IS Anomalous O ONLY.) -! -! NOTES ON INPUT VARIABLES: -! UT, Local Time, and Longitude are used independently in the -! model and are not of equal importance for every situation. -! For the most physically realistic calculation these three -! variables should be consistent (STL=SEC/3600+GLONG/15). -! The Equation of Time departures from the above formula -! for apparent local time can be included if available but -! are of minor importance. -! -! F107 and F107A values used to generate the model correspond -! to the 10.7 cm radio flux at the actual distance of the Earth -! from the Sun rather than the radio flux at 1 AU. The following -! site provides both classes of values: -! ftp://ftp.ngdc.noaa.gov/STP/SOLAR_DATA/SOLAR_RADIO/FLUX/ -! -! F107, F107A, and AP effects are neither large nor well -! established below 80 km and these parameters should be set to -! 150., 150., and 4. respectively. -! -! OUTPUT VARIABLES: -! D(1) - HE NUMBER DENSITY(CM-3) -! D(2) - O NUMBER DENSITY(CM-3) -! D(3) - N2 NUMBER DENSITY(CM-3) -! D(4) - O2 NUMBER DENSITY(CM-3) -! D(5) - AR NUMBER DENSITY(CM-3) -! D(6) - TOTAL MASS DENSITY(GM/CM3) [Anomalous O NOT included] -! D(7) - H NUMBER DENSITY(CM-3) -! D(8) - N NUMBER DENSITY(CM-3) -! D(9) - Anomalous oxygen NUMBER DENSITY(CM-3) -! T(1) - EXOSPHERIC TEMPERATURE -! T(2) - TEMPERATURE AT ALT -! - DIMENSION ZN1(5),ALPHA(9) - COMMON/GTS3C/TLB,S,DB04,DB16,DB28,DB32,DB40,DB48,DB01,ZA,T0,Z0 & - ,G0,RL,DD,DB14,TR12 - COMMON/MESO7/TN1(5),TN2(4),TN3(5),TGN1(2),TGN2(2),TGN3(2) - DIMENSION D(9),T(2),MT(11),AP(*),ALTL(8) - COMMON/LOWER7/PTM(10),PDM(10,8) - COMMON/PARM7/PT(150),PD(150,9),PS(150),PDL(25,2),PTL(100,4), & - PMA(100,10),SAM(100) -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - COMMON/TTEST/TINFG,GB,ROUT,TT(15) - COMMON/DMIX/DM04,DM16,DM28,DM32,DM40,DM01,DM14 - COMMON/METSEL/IMR - SAVE - DATA MT/48,0,4,16,28,32,40,1,49,14,17/ - DATA ALTL/200.,300.,160.,250.,240.,450.,320.,450./ - DATA MN1/5/,ZN1/120.,110.,100.,90.,72.5/ - DATA DGTR/1.74533E-2/,DR/1.72142E-2/,ALAST/-999./ - DATA ALPHA/-0.38,0.,0.,0.,0.17,0.,-0.38,0.,0./ -! Test for changed input - V2=VTST7(IYD,SEC,GLAT,GLONG,STL,F107A,F107,AP,2) -! - YRD=IYD - ZA=PDL(16,2) - ZN1(1)=ZA - DO 2 J=1,9 - D(J)=0. - 2 END DO -! TINF VARIATIONS NOT IMPORTANT BELOW ZA OR ZN1(1) - IF(ALT.GT.ZN1(1)) THEN - IF(V2.EQ.1..OR.ALAST.LE.ZN1(1)) TINF=PTM(1)*PT(1) & - *(1.+SW(16)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PT)) - ELSE - TINF=PTM(1)*PT(1) - ENDIF - T(1)=TINF -! GRADIENT VARIATIONS NOT IMPORTANT BELOW ZN1(5) - IF(ALT.GT.ZN1(5)) THEN - IF(V2.EQ.1.OR.ALAST.LE.ZN1(5)) G0=PTM(4)*PS(1) & - *(1.+SW(19)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PS)) - ELSE - G0=PTM(4)*PS(1) - ENDIF -! Calculate these temperatures only if input changed - IF(V2.EQ.1. .OR. ALT.LT.300.) & - TLB=PTM(2)*(1.+SW(17)*GLOBE7(YRD,SEC,GLAT,GLONG,STL, & - F107A,F107,AP,PD(1,4)))*PD(1,4) - S=G0/(TINF-TLB) -! Lower thermosphere temp variations not significant for -! density above 300 km - IF(ALT.LT.300.) THEN - IF(V2.EQ.1..OR.ALAST.GE.300.) THEN - TN1(2)=PTM(7)*PTL(1,1)/(1.-SW(18)*GLOB7S(PTL(1,1))) - TN1(3)=PTM(3)*PTL(1,2)/(1.-SW(18)*GLOB7S(PTL(1,2))) - TN1(4)=PTM(8)*PTL(1,3)/(1.-SW(18)*GLOB7S(PTL(1,3))) - TN1(5)=PTM(5)*PTL(1,4)/(1.-SW(18)*SW(20)*GLOB7S(PTL(1,4))) - TGN1(2)=PTM(9)*PMA(1,9)*(1.+SW(18)*SW(20)*GLOB7S(PMA(1,9))) & - *TN1(5)*TN1(5)/(PTM(5)*PTL(1,4))**2 - ENDIF - ELSE - TN1(2)=PTM(7)*PTL(1,1) - TN1(3)=PTM(3)*PTL(1,2) - TN1(4)=PTM(8)*PTL(1,3) - TN1(5)=PTM(5)*PTL(1,4) - TGN1(2)=PTM(9)*PMA(1,9) & - *TN1(5)*TN1(5)/(PTM(5)*PTL(1,4))**2 - ENDIF -! - Z0=ZN1(4) - T0=TN1(4) - TR12=1. -! - IF(MASS.EQ.0) GO TO 50 -! N2 variation factor at Zlb - G28=SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107, & - AP,PD(1,3)) - DAY=AMOD(YRD,1000.) -! VARIATION OF TURBOPAUSE HEIGHT - ZHF=PDL(25,2) & - *(1.+SW(5)*PDL(25,1)*SIN(DGTR*GLAT)*COS(DR*(DAY-PT(14)))) - YRD=IYD - T(1)=TINF - XMM=PDM(5,3) - Z=ALT -! - DO 10 J = 1,11 - IF(MASS.EQ.MT(J)) GO TO 15 - 10 END DO - WRITE(6,100) MASS - GO TO 90 - 15 IF(Z.GT.ALTL(6).AND.MASS.NE.28.AND.MASS.NE.48) GO TO 17 -! -! **** N2 DENSITY **** -! -! Diffusive density at Zlb - DB28 = PDM(1,3)*EXP(G28)*PD(1,3) -! Diffusive density at Alt - D(3)=DENSU(Z,DB28,TINF,TLB, 28.,ALPHA(3),T(2),PTM(6),S,MN1,ZN1, & - TN1,TGN1) - DD=D(3) -! Turbopause - ZH28=PDM(3,3)*ZHF - ZHM28=PDM(4,3)*PDL(6,2) - XMD=28.-XMM -! Mixed density at Zlb - B28=DENSU(ZH28,DB28,TINF,TLB,XMD,ALPHA(3)-1.,TZ,PTM(6),S,MN1, & - ZN1,TN1,TGN1) - IF(Z.GT.ALTL(3).OR.SW(15).EQ.0.) GO TO 17 -! Mixed density at Alt - DM28=DENSU(Z,B28,TINF,TLB,XMM,ALPHA(3),TZ,PTM(6),S,MN1, & - ZN1,TN1,TGN1) -! Net density at Alt - D(3)=DNET(D(3),DM28,ZHM28,XMM,28.) - 17 CONTINUE - GO TO (20,50,20,25,90,35,40,45,25,48,46), J - 20 CONTINUE -! -! **** HE DENSITY **** -! -! Density variation factor at Zlb - G4 = SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,1)) -! Diffusive density at Zlb - DB04 = PDM(1,1)*EXP(G4)*PD(1,1) -! Diffusive density at Alt - D(1)=DENSU(Z,DB04,TINF,TLB, 4.,ALPHA(1),T(2),PTM(6),S,MN1,ZN1, & - TN1,TGN1) - DD=D(1) - IF(Z.GT.ALTL(1).OR.SW(15).EQ.0.) GO TO 24 -! Turbopause - ZH04=PDM(3,1) -! Mixed density at Zlb - B04=DENSU(ZH04,DB04,TINF,TLB,4.-XMM,ALPHA(1)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM04=DENSU(Z,B04,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM04=ZHM28 -! Net density at Alt - D(1)=DNET(D(1),DM04,ZHM04,XMM,4.) -! Correction to specified mixing ratio at ground - RL=ALOG(B28*PDM(2,1)/B04) - ZC04=PDM(5,1)*PDL(1,2) - HC04=PDM(6,1)*PDL(2,2) -! Net density corrected at Alt - D(1)=D(1)*CCOR(Z,RL,HC04,ZC04) - 24 CONTINUE - IF(MASS.NE.48) GO TO 90 - 25 CONTINUE -! -! **** O DENSITY **** -! -! Density variation factor at Zlb - G16= SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,2)) -! Diffusive density at Zlb - DB16 = PDM(1,2)*EXP(G16)*PD(1,2) -! Diffusive density at Alt - D(2)=DENSU(Z,DB16,TINF,TLB, 16.,ALPHA(2),T(2),PTM(6),S,MN1, & - ZN1,TN1,TGN1) - DD=D(2) - IF(Z.GT.ALTL(2).OR.SW(15).EQ.0.) GO TO 34 -! Corrected from PDM(3,1) to PDM(3,2) 12/2/85 -! Turbopause - ZH16=PDM(3,2) -! Mixed density at Zlb - B16=DENSU(ZH16,DB16,TINF,TLB,16-XMM,ALPHA(2)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM16=DENSU(Z,B16,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM16=ZHM28 -! Net density at Alt - D(2)=DNET(D(2),DM16,ZHM16,XMM,16.) -! 3/16/99 Change form to match O2 departure from diff equil near 150 -! km and add dependence on F10.7 -! RL=ALOG(B28*PDM(2,2)*ABS(PDL(17,2))/B16) - RL=PDM(2,2)*PDL(17,2)*(1.+SW(1)*PDL(24,1)*(F107A-150.)) - HC16=PDM(6,2)*PDL(4,2) - ZC16=PDM(5,2)*PDL(3,2) - HC216=PDM(6,2)*PDL(5,2) - D(2)=D(2)*CCOR2(Z,RL,HC16,ZC16,HC216) -! Chemistry correction - HCC16=PDM(8,2)*PDL(14,2) - ZCC16=PDM(7,2)*PDL(13,2) - RC16=PDM(4,2)*PDL(15,2) -! Net density corrected at Alt - D(2)=D(2)*CCOR(Z,RC16,HCC16,ZCC16) - 34 CONTINUE - IF(MASS.NE.48.AND.MASS.NE.49) GO TO 90 - 35 CONTINUE -! -! **** O2 DENSITY **** -! -! Density variation factor at Zlb - G32= SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,5)) -! Diffusive density at Zlb - DB32 = PDM(1,4)*EXP(G32)*PD(1,5) -! Diffusive density at Alt - D(4)=DENSU(Z,DB32,TINF,TLB, 32.,ALPHA(4),T(2),PTM(6),S,MN1, & - ZN1,TN1,TGN1) - IF(MASS.EQ.49) THEN - DD=DD+2.*D(4) - ELSE - DD=D(4) - ENDIF - IF(SW(15).EQ.0.) GO TO 39 - IF(Z.GT.ALTL(4)) GO TO 38 -! Turbopause - ZH32=PDM(3,4) -! Mixed density at Zlb - B32=DENSU(ZH32,DB32,TINF,TLB,32.-XMM,ALPHA(4)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM32=DENSU(Z,B32,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM32=ZHM28 -! Net density at Alt - D(4)=DNET(D(4),DM32,ZHM32,XMM,32.) -! Correction to specified mixing ratio at ground - RL=ALOG(B28*PDM(2,4)/B32) - HC32=PDM(6,4)*PDL(8,2) - ZC32=PDM(5,4)*PDL(7,2) - D(4)=D(4)*CCOR(Z,RL,HC32,ZC32) - 38 CONTINUE -! Correction for general departure from diffusive equilibrium above - HCC32=PDM(8,4)*PDL(23,2) - HCC232=PDM(8,4)*PDL(23,1) - ZCC32=PDM(7,4)*PDL(22,2) - RC32=PDM(4,4)*PDL(24,2)*(1.+SW(1)*PDL(24,1)*(F107A-150.)) -! Net density corrected at Alt - D(4)=D(4)*CCOR2(Z,RC32,HCC32,ZCC32,HCC232) - 39 CONTINUE - IF(MASS.NE.48) GO TO 90 - 40 CONTINUE -! -! **** AR DENSITY **** -! -! Density variation factor at Zlb - G40= SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,6)) -! Diffusive density at Zlb - DB40 = PDM(1,5)*EXP(G40)*PD(1,6) -! Diffusive density at Alt - D(5)=DENSU(Z,DB40,TINF,TLB, 40.,ALPHA(5),T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - DD=D(5) - IF(Z.GT.ALTL(5).OR.SW(15).EQ.0.) GO TO 44 -! Turbopause - ZH40=PDM(3,5) -! Mixed density at Zlb - B40=DENSU(ZH40,DB40,TINF,TLB,40.-XMM,ALPHA(5)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM40=DENSU(Z,B40,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM40=ZHM28 -! Net density at Alt - D(5)=DNET(D(5),DM40,ZHM40,XMM,40.) -! Correction to specified mixing ratio at ground - RL=ALOG(B28*PDM(2,5)/B40) - HC40=PDM(6,5)*PDL(10,2) - ZC40=PDM(5,5)*PDL(9,2) -! Net density corrected at Alt - D(5)=D(5)*CCOR(Z,RL,HC40,ZC40) - 44 CONTINUE - IF(MASS.NE.48) GO TO 90 - 45 CONTINUE -! -! **** HYDROGEN DENSITY **** -! -! Density variation factor at Zlb - G1 = SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,7)) -! Diffusive density at Zlb - DB01 = PDM(1,6)*EXP(G1)*PD(1,7) -! Diffusive density at Alt - D(7)=DENSU(Z,DB01,TINF,TLB,1.,ALPHA(7),T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - DD=D(7) - IF(Z.GT.ALTL(7).OR.SW(15).EQ.0.) GO TO 47 -! Turbopause - ZH01=PDM(3,6) -! Mixed density at Zlb - B01=DENSU(ZH01,DB01,TINF,TLB,1.-XMM,ALPHA(7)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM01=DENSU(Z,B01,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM01=ZHM28 -! Net density at Alt - D(7)=DNET(D(7),DM01,ZHM01,XMM,1.) -! Correction to specified mixing ratio at ground - RL=ALOG(B28*PDM(2,6)*ABS(PDL(18,2))/B01) - HC01=PDM(6,6)*PDL(12,2) - ZC01=PDM(5,6)*PDL(11,2) - D(7)=D(7)*CCOR(Z,RL,HC01,ZC01) -! Chemistry correction - HCC01=PDM(8,6)*PDL(20,2) - ZCC01=PDM(7,6)*PDL(19,2) - RC01=PDM(4,6)*PDL(21,2) -! Net density corrected at Alt - D(7)=D(7)*CCOR(Z,RC01,HCC01,ZCC01) - 47 CONTINUE - IF(MASS.NE.48) GO TO 90 - 48 CONTINUE -! -! **** ATOMIC NITROGEN DENSITY **** -! -! Density variation factor at Zlb - G14 = SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,8)) -! Diffusive density at Zlb - DB14 = PDM(1,7)*EXP(G14)*PD(1,8) -! Diffusive density at Alt - D(8)=DENSU(Z,DB14,TINF,TLB,14.,ALPHA(8),T(2),PTM(6),S,MN1, & - ZN1,TN1,TGN1) - DD=D(8) - IF(Z.GT.ALTL(8).OR.SW(15).EQ.0.) GO TO 49 -! Turbopause - ZH14=PDM(3,7) -! Mixed density at Zlb - B14=DENSU(ZH14,DB14,TINF,TLB,14.-XMM,ALPHA(8)-1., & - T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) -! Mixed density at Alt - DM14=DENSU(Z,B14,TINF,TLB,XMM,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - ZHM14=ZHM28 -! Net density at Alt - D(8)=DNET(D(8),DM14,ZHM14,XMM,14.) -! Correction to specified mixing ratio at ground - RL=ALOG(B28*PDM(2,7)*ABS(PDL(3,1))/B14) - HC14=PDM(6,7)*PDL(2,1) - ZC14=PDM(5,7)*PDL(1,1) - D(8)=D(8)*CCOR(Z,RL,HC14,ZC14) -! Chemistry correction - HCC14=PDM(8,7)*PDL(5,1) - ZCC14=PDM(7,7)*PDL(4,1) - RC14=PDM(4,7)*PDL(6,1) -! Net density corrected at Alt - D(8)=D(8)*CCOR(Z,RC14,HCC14,ZCC14) - 49 CONTINUE - IF(MASS.NE.48) GO TO 90 - 46 CONTINUE -! -! **** Anomalous OXYGEN DENSITY **** -! - G16H = SW(21)*GLOBE7(YRD,SEC,GLAT,GLONG,STL,F107A,F107,AP,PD(1,9)) - DB16H = PDM(1,8)*EXP(G16H)*PD(1,9) - THO=PDM(10,8)*PDL(7,1) - DD=DENSU(Z,DB16H,THO,THO,16.,ALPHA(9),T2,PTM(6),S,MN1, & - ZN1,TN1,TGN1) - ZSHT=PDM(6,8) - ZMHO=PDM(5,8) - ZSHO=SCALH(ZMHO,16.,THO) - D(9)=DD*EXP(-ZSHT/ZSHO*(EXP(-(Z-ZMHO)/ZSHT)-1.)) - IF(MASS.NE.48) GO TO 90 -! -! TOTAL MASS DENSITY -! - D(6) = 1.66E-24*(4.*D(1)+16.*D(2)+28.*D(3)+32.*D(4)+40.*D(5)+ & - D(7)+14.*D(8)) - DB48=1.66E-24*(4.*DB04+16.*DB16+28.*DB28+32.*DB32+40.*DB40+DB01+ & - 14.*DB14) - GO TO 90 -! TEMPERATURE AT ALTITUDE - 50 CONTINUE - Z=ABS(ALT) - DDUM = DENSU(Z,1., TINF,TLB,0.,0.,T(2),PTM(6),S,MN1,ZN1,TN1,TGN1) - 90 CONTINUE -! ADJUST DENSITIES FROM CGS TO KGM - IF(IMR.EQ.1) THEN - DO 95 I=1,9 - D(I)=D(I)*1.E6 - 95 CONTINUE - D(6)=D(6)/1000. - ENDIF - ALAST=ALT - RETURN - 100 FORMAT(1X,'MASS', I5, ' NOT VALID') - END SUBROUTINE GTS7 -!----------------------------------------------------------------------- - SUBROUTINE METERS(METER) -! Convert outputs to Kg & Meters if METER true - LOGICAL METER - COMMON/METSEL/IMR - SAVE - IMR=0 - IF(METER) IMR=1 - END SUBROUTINE METERS -!----------------------------------------------------------------------- - FUNCTION SCALH(ALT,XM,TEMP) -! Calculate scale height (km) - COMMON/PARMB/GSURF,RE - SAVE - DATA RGAS/831.4/ - G=GSURF/(1.+ALT/RE)**2 - SCALH=RGAS*TEMP/(G*XM) - RETURN - END FUNCTION SCALH -!----------------------------------------------------------------------- - FUNCTION GLOBE7(YRD,SEC,LAT,LONG,TLOC,F107A,F107,AP,P) -! CALCULATE G(L) FUNCTION -! Upper Thermosphere Parameters - REAL LAT, LONG - DIMENSION P(*),SV(25),AP(*) - COMMON/TTEST/TINF,GB,ROUT,T(15) -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - COMMON/LPOLY/PLG(9,4),CTLOC,STLOC,C2TLOC,S2TLOC,C3TLOC,S3TLOC, & - DAY,DF,DFA,APD,APDF,APT(4),XLONG,IYR - SAVE - DATA DGTR/1.74533E-2/,DR/1.72142E-2/, XL/1000./,TLL/1000./ - DATA SW9/1./,DAYL/-1./,P14/-1000./,P18/-1000./,P32/-1000./ - DATA HR/.2618/,SR/7.2722E-5/,SV/25*1./,NSW/14/,P39/-1000./ -! 3hr Magnetic activity functions -! Eq. A24d - G0(A)=(A-4.+(P(26)-1.)*(A-4.+(EXP(-ABS(P(25))*(A-4.))-1.)/ABS(P(25)))) -! Eq. A24c - SUMEX(EX)=1.+(1.-EX**19)/(1.-EX)*EX**(.5) -! Eq. A24a - SG0(EX)=(G0(AP(2))+(G0(AP(3))*EX+G0(AP(4))*EX*EX+G0(AP(5))*EX**3 & - +(G0(AP(6))*EX**4+G0(AP(7))*EX**12)*(1.-EX**8)/(1.-EX)) & - )/SUMEX(EX) - IF(ISW.NE.64999) CALL TSELEC(SV) - DO 10 J=1,14 - T(J)=0 - 10 END DO - IF(SW(9).GT.0) SW9=1. - IF(SW(9).LT.0) SW9=-1. - IYR = YRD/1000. - DAY = YRD - IYR*1000. - XLONG=LONG -! Eq. A22 (remainder of code) - IF(XL.EQ.LAT) GO TO 15 -! CALCULATE LEGENDRE POLYNOMIALS - C = SIN(LAT*DGTR) - S = COS(LAT*DGTR) - C2 = C*C - C4 = C2*C2 - S2 = S*S - PLG(2,1) = C - PLG(3,1) = 0.5*(3.*C2 -1.) - PLG(4,1) = 0.5*(5.*C*C2-3.*C) - PLG(5,1) = (35.*C4 - 30.*C2 + 3.)/8. - PLG(6,1) = (63.*C2*C2*C - 70.*C2*C + 15.*C)/8. - PLG(7,1) = (11.*C*PLG(6,1) - 5.*PLG(5,1))/6. -! PLG(8,1) = (13.*C*PLG(7,1) - 6.*PLG(6,1))/7. - PLG(2,2) = S - PLG(3,2) = 3.*C*S - PLG(4,2) = 1.5*(5.*C2-1.)*S - PLG(5,2) = 2.5*(7.*C2*C-3.*C)*S - PLG(6,2) = 1.875*(21.*C4 - 14.*C2 +1.)*S - PLG(7,2) = (11.*C*PLG(6,2)-6.*PLG(5,2))/5. -! PLG(8,2) = (13.*C*PLG(7,2)-7.*PLG(6,2))/6. -! PLG(9,2) = (15.*C*PLG(8,2)-8.*PLG(7,2))/7. - PLG(3,3) = 3.*S2 - PLG(4,3) = 15.*S2*C - PLG(5,3) = 7.5*(7.*C2 -1.)*S2 - PLG(6,3) = 3.*C*PLG(5,3)-2.*PLG(4,3) - PLG(7,3)=(11.*C*PLG(6,3)-7.*PLG(5,3))/4. - PLG(8,3)=(13.*C*PLG(7,3)-8.*PLG(6,3))/5. - PLG(4,4) = 15.*S2*S - PLG(5,4) = 105.*S2*S*C - PLG(6,4)=(9.*C*PLG(5,4)-7.*PLG(4,4))/2. - PLG(7,4)=(11.*C*PLG(6,4)-8.*PLG(5,4))/3. - XL=LAT - 15 CONTINUE - IF(TLL.EQ.TLOC) GO TO 16 - IF(SW(7).EQ.0.AND.SW(8).EQ.0.AND.SW(14).EQ.0) GOTO 16 - STLOC = SIN(HR*TLOC) - CTLOC = COS(HR*TLOC) - S2TLOC = SIN(2.*HR*TLOC) - C2TLOC = COS(2.*HR*TLOC) - S3TLOC = SIN(3.*HR*TLOC) - C3TLOC = COS(3.*HR*TLOC) - TLL = TLOC - 16 CONTINUE - IF(DAY.NE.DAYL.OR.P(14).NE.P14) CD14=COS(DR*(DAY-P(14))) - IF(DAY.NE.DAYL.OR.P(18).NE.P18) CD18=COS(2.*DR*(DAY-P(18))) - IF(DAY.NE.DAYL.OR.P(32).NE.P32) CD32=COS(DR*(DAY-P(32))) - IF(DAY.NE.DAYL.OR.P(39).NE.P39) CD39=COS(2.*DR*(DAY-P(39))) - DAYL = DAY - P14 = P(14) - P18 = P(18) - P32 = P(32) - P39 = P(39) -! F10.7 EFFECT - DF = F107 - F107A - DFA=F107A-150. - T(1) = P(20)*DF*(1.+P(60)*DFA) + P(21)*DF*DF + P(22)*DFA & - + P(30)*DFA**2 - F1 = 1. + (P(48)*DFA +P(20)*DF+P(21)*DF*DF)*SWC(1) - F2 = 1. + (P(50)*DFA+P(20)*DF+P(21)*DF*DF)*SWC(1) -! TIME INDEPENDENT - T(2) = & - (P(2)*PLG(3,1) + P(3)*PLG(5,1)+P(23)*PLG(7,1)) & - +(P(15)*PLG(3,1))*DFA*SWC(1) & - +P(27)*PLG(2,1) -! SYMMETRICAL ANNUAL - T(3) = & - (P(19) )*CD32 -! SYMMETRICAL SEMIANNUAL - T(4) = & - (P(16)+P(17)*PLG(3,1))*CD18 -! ASYMMETRICAL ANNUAL - T(5) = F1* & - (P(10)*PLG(2,1)+P(11)*PLG(4,1))*CD14 -! ASYMMETRICAL SEMIANNUAL - T(6) = P(38)*PLG(2,1)*CD39 -! DIURNAL - IF(SW(7).EQ.0) GOTO 200 - T71 = (P(12)*PLG(3,2))*CD14*SWC(5) - T72 = (P(13)*PLG(3,2))*CD14*SWC(5) - T(7) = F2* & - ((P(4)*PLG(2,2) + P(5)*PLG(4,2) + P(28)*PLG(6,2) & - + T71)*CTLOC & - + (P(7)*PLG(2,2) + P(8)*PLG(4,2) +P(29)*PLG(6,2) & - + T72)*STLOC) - 200 CONTINUE -! SEMIDIURNAL - IF(SW(8).EQ.0) GOTO 210 - T81 = (P(24)*PLG(4,3)+P(36)*PLG(6,3))*CD14*SWC(5) - T82 = (P(34)*PLG(4,3)+P(37)*PLG(6,3))*CD14*SWC(5) - T(8) = F2* & - ((P(6)*PLG(3,3) + P(42)*PLG(5,3) + T81)*C2TLOC & - +(P(9)*PLG(3,3) + P(43)*PLG(5,3) + T82)*S2TLOC) - 210 CONTINUE -! TERDIURNAL - IF(SW(14).EQ.0) GOTO 220 - T(14) = F2* & - ((P(40)*PLG(4,4)+(P(94)*PLG(5,4)+P(47)*PLG(7,4))*CD14*SWC(5))* & - S3TLOC & - +(P(41)*PLG(4,4)+(P(95)*PLG(5,4)+P(49)*PLG(7,4))*CD14*SWC(5))* & - C3TLOC) - 220 CONTINUE -! MAGNETIC ACTIVITY BASED ON DAILY AP - - IF(SW9.EQ.-1.) GO TO 30 - APD=(AP(1)-4.) - P44=P(44) - P45=P(45) - IF(P44.LT.0) P44=1.E-5 - APDF = APD+(P45-1.)*(APD+(EXP(-P44 *APD)-1.)/P44) - IF(SW(9).EQ.0) GOTO 40 - T(9)=APDF*(P(33)+P(46)*PLG(3,1)+P(35)*PLG(5,1)+ & - (P(101)*PLG(2,1)+P(102)*PLG(4,1)+P(103)*PLG(6,1))*CD14*SWC(5)+ & - (P(122)*PLG(2,2)+P(123)*PLG(4,2)+P(124)*PLG(6,2))*SWC(7)* & - COS(HR*(TLOC-P(125)))) - GO TO 40 - 30 CONTINUE - IF(P(52).EQ.0) GO TO 40 - EXP1 = EXP(-10800.*ABS(P(52))/(1.+P(139)*(45.-ABS(LAT)))) - IF(EXP1.GT..99999) EXP1=.99999 - IF(P(25).LT.1.E-4) P(25)=1.E-4 - APT(1)=SG0(EXP1) -! APT(2)=SG2(EXP1) -! APT(3)=SG0(EXP2) -! APT(4)=SG2(EXP2) - IF(SW(9).EQ.0) GOTO 40 - T(9) = APT(1)*(P(51)+P(97)*PLG(3,1)+P(55)*PLG(5,1)+ & - (P(126)*PLG(2,1)+P(127)*PLG(4,1)+P(128)*PLG(6,1))*CD14*SWC(5)+ & - (P(129)*PLG(2,2)+P(130)*PLG(4,2)+P(131)*PLG(6,2))*SWC(7)* & - COS(HR*(TLOC-P(132)))) - 40 CONTINUE - IF(SW(10).EQ.0.OR.LONG.LE.-1000.) GO TO 49 -! LONGITUDINAL - IF(SW(11).EQ.0) GOTO 230 - T(11)= (1.+P(81)*DFA*SWC(1))* & - ((P(65)*PLG(3,2)+P(66)*PLG(5,2)+P(67)*PLG(7,2) & - +P(104)*PLG(2,2)+P(105)*PLG(4,2)+P(106)*PLG(6,2) & - +SWC(5)*(P(110)*PLG(2,2)+P(111)*PLG(4,2)+P(112)*PLG(6,2))*CD14)* & - COS(DGTR*LONG) & - +(P(91)*PLG(3,2)+P(92)*PLG(5,2)+P(93)*PLG(7,2) & - +P(107)*PLG(2,2)+P(108)*PLG(4,2)+P(109)*PLG(6,2) & - +SWC(5)*(P(113)*PLG(2,2)+P(114)*PLG(4,2)+P(115)*PLG(6,2))*CD14)* & - SIN(DGTR*LONG)) - 230 CONTINUE -! UT AND MIXED UT,LONGITUDE - IF(SW(12).EQ.0) GOTO 240 - T(12)=(1.+P(96)*PLG(2,1))*(1.+P(82)*DFA*SWC(1))* & - (1.+P(120)*PLG(2,1)*SWC(5)*CD14)* & - ((P(69)*PLG(2,1)+P(70)*PLG(4,1)+P(71)*PLG(6,1))* & - COS(SR*(SEC-P(72)))) - T(12)=T(12)+SWC(11)* & - (P(77)*PLG(4,3)+P(78)*PLG(6,3)+P(79)*PLG(8,3))* & - COS(SR*(SEC-P(80))+2.*DGTR*LONG)*(1.+P(138)*DFA*SWC(1)) - 240 CONTINUE -! UT,LONGITUDE MAGNETIC ACTIVITY - IF(SW(13).EQ.0) GOTO 48 - IF(SW9.EQ.-1.) GO TO 45 - T(13)= APDF*SWC(11)*(1.+P(121)*PLG(2,1))* & - ((P( 61)*PLG(3,2)+P( 62)*PLG(5,2)+P( 63)*PLG(7,2))* & - COS(DGTR*(LONG-P( 64)))) & - +APDF*SWC(11)*SWC(5)* & - (P(116)*PLG(2,2)+P(117)*PLG(4,2)+P(118)*PLG(6,2))* & - CD14*COS(DGTR*(LONG-P(119))) & - + APDF*SWC(12)* & - (P( 84)*PLG(2,1)+P( 85)*PLG(4,1)+P( 86)*PLG(6,1))* & - COS(SR*(SEC-P( 76))) - GOTO 48 - 45 CONTINUE - IF(P(52).EQ.0) GOTO 48 - T(13)=APT(1)*SWC(11)*(1.+P(133)*PLG(2,1))* & - ((P(53)*PLG(3,2)+P(99)*PLG(5,2)+P(68)*PLG(7,2))* & - COS(DGTR*(LONG-P(98)))) & - +APT(1)*SWC(11)*SWC(5)* & - (P(134)*PLG(2,2)+P(135)*PLG(4,2)+P(136)*PLG(6,2))* & - CD14*COS(DGTR*(LONG-P(137))) & - +APT(1)*SWC(12)* & - (P(56)*PLG(2,1)+P(57)*PLG(4,1)+P(58)*PLG(6,1))* & - COS(SR*(SEC-P(59))) - 48 CONTINUE -! PARMS NOT USED: 83, 90,100,140-150 - 49 CONTINUE - TINF=P(31) - DO 50 I = 1,NSW - 50 TINF = TINF + ABS(SW(I))*T(I) - GLOBE7 = TINF - RETURN - END FUNCTION GLOBE7 -!----------------------------------------------------------------------- - SUBROUTINE TSELEC(SV) -! SET SWITCHES -! Output in COMMON/CSW/SW(25),ISW,SWC(25) -! SW FOR MAIN TERMS, SWC FOR CROSS TERMS -! -! TO TURN ON AND OFF PARTICULAR VARIATIONS CALL TSELEC(SV), -! WHERE SV IS A 25 ELEMENT ARRAY CONTAINING 0. FOR OFF, 1. -! FOR ON, OR 2. FOR MAIN EFFECTS OFF BUT CROSS TERMS ON -! -! To get current values of SW: CALL TRETRV(SW) -! - DIMENSION SV(*),SAV(25),SVV(*) -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - SAVE - DO 100 I = 1,25 - SAV(I)=SV(I) - SW(I)=AMOD(SV(I),2.) - IF(ABS(SV(I)).EQ.1.OR.ABS(SV(I)).EQ.2.) THEN - SWC(I)=1. - ELSE - SWC(I)=0. - ENDIF - 100 END DO - ISW=64999 - RETURN - ENTRY TRETRV(SVV) - DO 200 I=1,25 - SVV(I)=SAV(I) - 200 END DO - END SUBROUTINE TSELEC -!----------------------------------------------------------------------- - FUNCTION GLOB7S(P) -! VERSION OF GLOBE FOR LOWER ATMOSPHERE 10/26/99 - REAL LONG - COMMON/LPOLY/PLG(9,4),CTLOC,STLOC,C2TLOC,S2TLOC,C3TLOC,S3TLOC, & - DAY,DF,DFA,APD,APDF,APT(4),LONG,IYR -! COMMON/CSW/SW(25),ISW,SWC(25) - COMMON/CSW/SW(25),SWC(25),ISW - DIMENSION P(*),T(14) - SAVE - DATA DR/1.72142E-2/,DGTR/1.74533E-2/,PSET/2./ - DATA DAYL/-1./,P32,P18,P14,P39/4*-1000./ -! CONFIRM PARAMETER SET - IF(P(100).EQ.0) P(100)=PSET - IF(P(100).NE.PSET) THEN - WRITE(6,900) PSET,P(100) - 900 FORMAT(1X,'WRONG PARAMETER SET FOR GLOB7S',3F10.1) - STOP - ENDIF - DO 10 J=1,14 - T(J)=0. - 10 END DO - IF(DAY.NE.DAYL.OR.P32.NE.P(32)) CD32=COS(DR*(DAY-P(32))) - IF(DAY.NE.DAYL.OR.P18.NE.P(18)) CD18=COS(2.*DR*(DAY-P(18))) - IF(DAY.NE.DAYL.OR.P14.NE.P(14)) CD14=COS(DR*(DAY-P(14))) - IF(DAY.NE.DAYL.OR.P39.NE.P(39)) CD39=COS(2.*DR*(DAY-P(39))) - DAYL=DAY - P32=P(32) - P18=P(18) - P14=P(14) - P39=P(39) -! -! F10.7 - T(1)=P(22)*DFA -! TIME INDEPENDENT - T(2)=P(2)*PLG(3,1)+P(3)*PLG(5,1)+P(23)*PLG(7,1) & - +P(27)*PLG(2,1)+P(15)*PLG(4,1)+P(60)*PLG(6,1) -! SYMMETRICAL ANNUAL - T(3)=(P(19)+P(48)*PLG(3,1)+P(30)*PLG(5,1))*CD32 -! SYMMETRICAL SEMIANNUAL - T(4)=(P(16)+P(17)*PLG(3,1)+P(31)*PLG(5,1))*CD18 -! ASYMMETRICAL ANNUAL - T(5)=(P(10)*PLG(2,1)+P(11)*PLG(4,1)+P(21)*PLG(6,1))*CD14 -! ASYMMETRICAL SEMIANNUAL - T(6)=(P(38)*PLG(2,1))*CD39 -! DIURNAL - IF(SW(7).EQ.0) GOTO 200 - T71 = P(12)*PLG(3,2)*CD14*SWC(5) - T72 = P(13)*PLG(3,2)*CD14*SWC(5) - T(7) = & - ((P(4)*PLG(2,2) + P(5)*PLG(4,2) & - + T71)*CTLOC & - + (P(7)*PLG(2,2) + P(8)*PLG(4,2) & - + T72)*STLOC) - 200 CONTINUE -! SEMIDIURNAL - IF(SW(8).EQ.0) GOTO 210 - T81 = (P(24)*PLG(4,3)+P(36)*PLG(6,3))*CD14*SWC(5) - T82 = (P(34)*PLG(4,3)+P(37)*PLG(6,3))*CD14*SWC(5) - T(8) = & - ((P(6)*PLG(3,3) + P(42)*PLG(5,3) + T81)*C2TLOC & - +(P(9)*PLG(3,3) + P(43)*PLG(5,3) + T82)*S2TLOC) - 210 CONTINUE -! TERDIURNAL - IF(SW(14).EQ.0) GOTO 220 - T(14) = P(40)*PLG(4,4)*S3TLOC +P(41)*PLG(4,4)*C3TLOC - 220 CONTINUE -! MAGNETIC ACTIVITY - IF(SW(9).EQ.0) GOTO 40 - IF(SW(9).EQ.1) & - T(9)=APDF*(P(33)+P(46)*PLG(3,1)*SWC(2)) - IF(SW(9).EQ.-1) & - T(9)=(P(51)*APT(1)+P(97)*PLG(3,1)*APT(1)*SWC(2)) - 40 CONTINUE - IF(SW(10).EQ.0.OR.SW(11).EQ.0.OR.LONG.LE.-1000.) GO TO 49 -! LONGITUDINAL - T(11)= (1.+PLG(2,1)*(P(81)*SWC(5)*COS(DR*(DAY-P(82))) & - +P(86)*SWC(6)*COS(2.*DR*(DAY-P(87)))) & - +P(84)*SWC(3)*COS(DR*(DAY-P(85))) & - +P(88)*SWC(4)*COS(2.*DR*(DAY-P(89)))) & - *((P(65)*PLG(3,2)+P(66)*PLG(5,2)+P(67)*PLG(7,2) & - +P(75)*PLG(2,2)+P(76)*PLG(4,2)+P(77)*PLG(6,2) & - )*COS(DGTR*LONG) & - +(P(91)*PLG(3,2)+P(92)*PLG(5,2)+P(93)*PLG(7,2) & - +P(78)*PLG(2,2)+P(79)*PLG(4,2)+P(80)*PLG(6,2) & - )*SIN(DGTR*LONG)) - 49 CONTINUE - TT=0. - DO 50 I=1,14 - 50 TT=TT+ABS(SW(I))*T(I) - GLOB7S=TT - RETURN - END FUNCTION GLOB7S -!-------------------------------------------------------------------- - FUNCTION DENSU(ALT,DLB,TINF,TLB,XM,ALPHA,TZ,ZLB,S2, & - MN1,ZN1,TN1,TGN1) -! Calculate Temperature and Density Profiles for MSIS models -! New lower thermo polynomial 10/30/89 - DIMENSION ZN1(MN1),TN1(MN1),TGN1(2),XS(5),YS(5),Y2OUT(5) - COMMON/PARMB/GSURF,RE - COMMON/LSQV/MP,II,JG,LT,QPB(50),IERR,IFUN,N,J,DV(60) - SAVE - DATA RGAS/831.4/ - ZETA(ZZ,ZL)=(ZZ-ZL)*(RE+ZL)/(RE+ZZ) -!CCCCCWRITE(6,*) 'DB',ALT,DLB,TINF,TLB,XM,ALPHA,ZLB,S2,MN1,ZN1,TN1 - DENSU=1. -! Joining altitude of Bates and spline - ZA=ZN1(1) - Z=AMAX1(ALT,ZA) -! Geopotential altitude difference from ZLB - ZG2=ZETA(Z,ZLB) -! Bates temperature - TT=TINF-(TINF-TLB)*EXP(-S2*ZG2) - TA=TT - TZ=TT - DENSU=TZ - IF(ALT.GE.ZA) GO TO 10 -! -! CALCULATE TEMPERATURE BELOW ZA -! Temperature gradient at ZA from Bates profile - DTA=(TINF-TA)*S2*((RE+ZLB)/(RE+ZA))**2 - TGN1(1)=DTA - TN1(1)=TA - Z=AMAX1(ALT,ZN1(MN1)) - MN=MN1 - Z1=ZN1(1) - Z2=ZN1(MN) - T1=TN1(1) - T2=TN1(MN) -! Geopotental difference from Z1 - ZG=ZETA(Z,Z1) - ZGDIF=ZETA(Z2,Z1) -! Set up spline nodes - DO 20 K=1,MN - XS(K)=ZETA(ZN1(K),Z1)/ZGDIF - YS(K)=1./TN1(K) - 20 END DO -! End node derivatives - YD1=-TGN1(1)/(T1*T1)*ZGDIF - YD2=-TGN1(2)/(T2*T2)*ZGDIF*((RE+Z2)/(RE+Z1))**2 -! Calculate spline coefficients - CALL SPLINE(XS,YS,MN,YD1,YD2,Y2OUT) - X=ZG/ZGDIF - CALL SPLINT(XS,YS,Y2OUT,MN,X,Y) -! temperature at altitude - TZ=1./Y - DENSU=TZ - 10 IF(XM.EQ.0.) GO TO 50 -! -! CALCULATE DENSITY ABOVE ZA - GLB=GSURF/(1.+ZLB/RE)**2 - GAMMA=XM*GLB/(S2*RGAS*TINF) - EXPL=EXP(-S2*GAMMA*ZG2) - IF(EXPL.GT.50.OR.TT.LE.0.) THEN - EXPL=50. - ENDIF -! Density at altitude - DENSA=DLB*(TLB/TT)**(1.+ALPHA+GAMMA)*EXPL - DENSU=DENSA - IF(ALT.GE.ZA) GO TO 50 -! -! CALCULATE DENSITY BELOW ZA - GLB=GSURF/(1.+Z1/RE)**2 - GAMM=XM*GLB*ZGDIF/RGAS -! integrate spline temperatures - CALL SPLINI(XS,YS,Y2OUT,MN,X,YI) - EXPL=GAMM*YI - IF(EXPL.GT.50..OR.TZ.LE.0.) THEN - EXPL=50. - ENDIF -! Density at altitude - DENSU=DENSU*(T1/TZ)**(1.+ALPHA)*EXP(-EXPL) - 50 CONTINUE - RETURN - END FUNCTION DENSU -!-------------------------------------------------------------------- - FUNCTION DENSM(ALT,D0,XM,TZ,MN3,ZN3,TN3,TGN3,MN2,ZN2,TN2,TGN2) -! Calculate Temperature and Density Profiles for lower atmos. - DIMENSION ZN3(MN3),TN3(MN3),TGN3(2),XS(10),YS(10),Y2OUT(10) - DIMENSION ZN2(MN2),TN2(MN2),TGN2(2) - COMMON/PARMB/GSURF,RE - COMMON/FIT/TAF - COMMON/LSQV/MP,II,JG,LT,QPB(50),IERR,IFUN,N,J,DV(60) - SAVE - DATA RGAS/831.4/ - ZETA(ZZ,ZL)=(ZZ-ZL)*(RE+ZL)/(RE+ZZ) - DENSM=D0 - IF(ALT.GT.ZN2(1)) GOTO 50 -! STRATOSPHERE/MESOSPHERE TEMPERATURE - Z=AMAX1(ALT,ZN2(MN2)) - MN=MN2 - Z1=ZN2(1) - Z2=ZN2(MN) - T1=TN2(1) - T2=TN2(MN) - ZG=ZETA(Z,Z1) - ZGDIF=ZETA(Z2,Z1) -! Set up spline nodes - DO 210 K=1,MN - XS(K)=ZETA(ZN2(K),Z1)/ZGDIF - YS(K)=1./TN2(K) - 210 END DO - YD1=-TGN2(1)/(T1*T1)*ZGDIF - YD2=-TGN2(2)/(T2*T2)*ZGDIF*((RE+Z2)/(RE+Z1))**2 -! Calculate spline coefficients - CALL SPLINE(XS,YS,MN,YD1,YD2,Y2OUT) - X=ZG/ZGDIF - CALL SPLINT(XS,YS,Y2OUT,MN,X,Y) -! Temperature at altitude - TZ=1./Y - IF(XM.EQ.0.) GO TO 20 -! -! CALCULATE STRATOSPHERE/MESOSPHERE DENSITY - GLB=GSURF/(1.+Z1/RE)**2 - GAMM=XM*GLB*ZGDIF/RGAS -! Integrate temperature profile - CALL SPLINI(XS,YS,Y2OUT,MN,X,YI) - EXPL=GAMM*YI - IF(EXPL.GT.50.) EXPL=50. -! Density at altitude - DENSM=DENSM*(T1/TZ)*EXP(-EXPL) - 20 CONTINUE - IF(ALT.GT.ZN3(1)) GOTO 50 -! -! TROPOSPHERE/STRATOSPHERE TEMPERATURE - Z=ALT - MN=MN3 - Z1=ZN3(1) - Z2=ZN3(MN) - T1=TN3(1) - T2=TN3(MN) - ZG=ZETA(Z,Z1) - ZGDIF=ZETA(Z2,Z1) -! Set up spline nodes - DO 220 K=1,MN - XS(K)=ZETA(ZN3(K),Z1)/ZGDIF - YS(K)=1./TN3(K) - 220 END DO - YD1=-TGN3(1)/(T1*T1)*ZGDIF - YD2=-TGN3(2)/(T2*T2)*ZGDIF*((RE+Z2)/(RE+Z1))**2 -! Calculate spline coefficients - CALL SPLINE(XS,YS,MN,YD1,YD2,Y2OUT) - X=ZG/ZGDIF - CALL SPLINT(XS,YS,Y2OUT,MN,X,Y) -! temperature at altitude - TZ=1./Y - IF(XM.EQ.0.) GO TO 30 -! -! CALCULATE TROPOSPHERIC/STRATOSPHERE DENSITY -! - GLB=GSURF/(1.+Z1/RE)**2 - GAMM=XM*GLB*ZGDIF/RGAS -! Integrate temperature profile - CALL SPLINI(XS,YS,Y2OUT,MN,X,YI) - EXPL=GAMM*YI - IF(EXPL.GT.50.) EXPL=50. -! Density at altitude - DENSM=DENSM*(T1/TZ)*EXP(-EXPL) - 30 CONTINUE - 50 CONTINUE - IF(XM.EQ.0) DENSM=TZ - RETURN - END FUNCTION DENSM -!----------------------------------------------------------------------- - SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2) -! CALCULATE 2ND DERIVATIVES OF CUBIC SPLINE INTERP FUNCTION -! ADAPTED FROM NUMERICAL RECIPES BY PRESS ET AL -! X,Y: ARRAYS OF TABULATED FUNCTION IN ASCENDING ORDER BY X -! N: SIZE OF ARRAYS X,Y -! YP1,YPN: SPECIFIED DERIVATIVES AT X(1) AND X(N); VALUES -! >= 1E30 SIGNAL SIGNAL SECOND DERIVATIVE ZERO -! Y2: OUTPUT ARRAY OF SECOND DERIVATIVES - PARAMETER (NMAX=100) - DIMENSION X(N),Y(N),Y2(N),U(NMAX) - SAVE - IF(YP1.GT..99E30) THEN - Y2(1)=0 - U(1)=0 - ELSE - Y2(1)=-.5 - U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1) - ENDIF - DO 11 I=2,N-1 - SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1)) - P=SIG*Y2(I-1)+2. - Y2(I)=(SIG-1.)/P - U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1)) & - /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P - 11 END DO - IF(YPN.GT..99E30) THEN - QN=0 - UN=0 - ELSE - QN=.5 - UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1))) - ENDIF - Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.) - DO 12 K=N-1,1,-1 - Y2(K)=Y2(K)*Y2(K+1)+U(K) - 12 END DO - RETURN - END SUBROUTINE SPLINE -!----------------------------------------------------------------------- - SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y) -! CALCULATE CUBIC SPLINE INTERP VALUE -! ADAPTED FROM NUMERICAL RECIPES BY PRESS ET AL. -! XA,YA: ARRAYS OF TABULATED FUNCTION IN ASCENDING ORDER BY X -! Y2A: ARRAY OF SECOND DERIVATIVES -! N: SIZE OF ARRAYS XA,YA,Y2A -! X: ABSCISSA FOR INTERPOLATION -! Y: OUTPUT VALUE - DIMENSION XA(N),YA(N),Y2A(N) - SAVE - KLO=1 - KHI=N - 1 CONTINUE - IF(KHI-KLO.GT.1) THEN - K=(KHI+KLO)/2 - IF(XA(K).GT.X) THEN - KHI=K - ELSE - KLO=K - ENDIF - GOTO 1 - ENDIF - H=XA(KHI)-XA(KLO) - IF(H.EQ.0) WRITE(6,*) 'BAD XA INPUT TO SPLINT' - A=(XA(KHI)-X)/H - B=(X-XA(KLO))/H - Y=A*YA(KLO)+B*YA(KHI)+ & - ((A*A*A-A)*Y2A(KLO)+(B*B*B-B)*Y2A(KHI))*H*H/6. - RETURN - END SUBROUTINE SPLINT -!----------------------------------------------------------------------- - SUBROUTINE SPLINI(XA,YA,Y2A,N,X,YI) -! INTEGRATE CUBIC SPLINE FUNCTION FROM XA(1) TO X -! XA,YA: ARRAYS OF TABULATED FUNCTION IN ASCENDING ORDER BY X -! Y2A: ARRAY OF SECOND DERIVATIVES -! N: SIZE OF ARRAYS XA,YA,Y2A -! X: ABSCISSA ENDPOINT FOR INTEGRATION -! Y: OUTPUT VALUE - DIMENSION XA(N),YA(N),Y2A(N) - SAVE - YI=0 - KLO=1 - KHI=2 - 1 CONTINUE - IF(X.GT.XA(KLO).AND.KHI.LE.N) THEN - XX=X - IF(KHI.LT.N) XX=AMIN1(X,XA(KHI)) - H=XA(KHI)-XA(KLO) - A=(XA(KHI)-XX)/H - B=(XX-XA(KLO))/H - A2=A*A - B2=B*B - YI=YI+((1.-A2)*YA(KLO)/2.+B2*YA(KHI)/2.+ & - ((-(1.+A2*A2)/4.+A2/2.)*Y2A(KLO)+ & - (B2*B2/4.-B2/2.)*Y2A(KHI))*H*H/6.)*H - KLO=KLO+1 - KHI=KHI+1 - GOTO 1 - ENDIF - RETURN - END SUBROUTINE SPLINI -!----------------------------------------------------------------------- - FUNCTION DNET(DD,DM,ZHM,XMM,XM) -! TURBOPAUSE CORRECTION FOR MSIS MODELS -! Root mean density -! 8/20/80 -! DD - diffusive density -! DM - full mixed density -! ZHM - transition scale length -! XMM - full mixed molecular weight -! XM - species molecular weight -! DNET - combined density - SAVE - A=ZHM/(XMM-XM) - IF(DM.GT.0.AND.DD.GT.0) GOTO 5 - WRITE(6,*) 'DNET LOG ERROR',DM,DD,XM - IF(DD.EQ.0.AND.DM.EQ.0) DD=1. - IF(DM.EQ.0) GOTO 10 - IF(DD.EQ.0) GOTO 20 - 5 CONTINUE - YLOG=A*ALOG(DM/DD) - IF(YLOG.LT.-10.) GO TO 10 - IF(YLOG.GT.10.) GO TO 20 - DNET=DD*(1.+EXP(YLOG))**(1/A) - GO TO 50 - 10 CONTINUE - DNET=DD - GO TO 50 - 20 CONTINUE - DNET=DM - GO TO 50 - 50 CONTINUE - RETURN - END FUNCTION DNET -!----------------------------------------------------------------------- - FUNCTION CCOR(ALT, R,H1,ZH) -! CHEMISTRY/DISSOCIATION CORRECTION FOR MSIS MODELS -! ALT - altitude -! R - target ratio -! H1 - transition scale length -! ZH - altitude of 1/2 R - SAVE - E=(ALT-ZH)/H1 - IF(E.GT.70.) GO TO 20 - IF(E.LT.-70.) GO TO 10 - EX=EXP(E) - CCOR=R/(1.+EX) - GO TO 50 - 10 CCOR=R - GO TO 50 - 20 CCOR=0. - GO TO 50 - 50 CONTINUE - CCOR=EXP(CCOR) - RETURN - END FUNCTION CCOR -!----------------------------------------------------------------------- - FUNCTION CCOR2(ALT, R,H1,ZH,H2) -! O&O2 CHEMISTRY/DISSOCIATION CORRECTION FOR MSIS MODELS - E1=(ALT-ZH)/H1 - E2=(ALT-ZH)/H2 - IF(E1.GT.70. .OR. E2.GT.70.) GO TO 20 - IF(E1.LT.-70. .AND. E2.LT.-70) GO TO 10 - EX1=EXP(E1) - EX2=EXP(E2) - CCOR2=R/(1.+.5*(EX1+EX2)) - GO TO 50 - 10 CCOR2=R - GO TO 50 - 20 CCOR2=0. - GO TO 50 - 50 CONTINUE - CCOR2=EXP(CCOR2) - RETURN - END FUNCTION CCOR2 -!----------------------------------------------------------------------- - BLOCK DATA GTD7BK -! MSISE-00 01-FEB-02 - COMMON/PARM7/PT1(50),PT2(50),PT3(50),PA1(50),PA2(50),PA3(50), & - PB1(50),PB2(50),PB3(50),PC1(50),PC2(50),PC3(50), & - PD1(50),PD2(50),PD3(50),PE1(50),PE2(50),PE3(50), & - PF1(50),PF2(50),PF3(50),PG1(50),PG2(50),PG3(50), & - PH1(50),PH2(50),PH3(50),PI1(50),PI2(50),PI3(50), & - PJ1(50),PJ2(50),PJ3(50),PK1(50),PL1(50),PL2(50), & - PM1(50),PM2(50),PN1(50),PN2(50),PO1(50),PO2(50), & - PP1(50),PP2(50),PQ1(50),PQ2(50),PR1(50),PR2(50), & - PS1(50),PS2(50),PU1(50),PU2(50),PV1(50),PV2(50), & - PW1(50),PW2(50),PX1(50),PX2(50),PY1(50),PY2(50), & - PZ1(50),PZ2(50),PAA1(50),PAA2(50) - COMMON/LOWER7/PTM(10),PDM(10,8) - COMMON/MAVG7/PAVGM(10) -! COMMON/DATIM7/ISDATE(3),ISTIME(2),NAME(2) - COMMON/METSEL/IMR - common/pres/pr65(2,65),pr151(2,151) - DATA IMR/0/ -! DATA ISDATE/'01-F','EB-0','2 '/,ISTIME/'15:4','9:27'/ -! DATA NAME/'MSIS','E-00'/ -! TEMPERATURE - DATA PT1/ & - 9.86573E-01, 1.62228E-02, 1.55270E-02,-1.04323E-01,-3.75801E-03,& - -1.18538E-03,-1.24043E-01, 4.56820E-03, 8.76018E-03,-1.36235E-01,& - -3.52427E-02, 8.84181E-03,-5.92127E-03,-8.61650E+00, 0.00000E+00,& - 1.28492E-02, 0.00000E+00, 1.30096E+02, 1.04567E-02, 1.65686E-03,& - -5.53887E-06, 2.97810E-03, 0.00000E+00, 5.13122E-03, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00,-7.27026E-06,& - 0.00000E+00, 6.74494E+00, 4.93933E-03, 2.21656E-03, 2.50802E-03,& - 0.00000E+00, 0.00000E+00,-2.08841E-02,-1.79873E+00, 1.45103E-03,& - 2.81769E-04,-1.44703E-03,-5.16394E-05, 8.47001E-02, 1.70147E-01,& - 5.72562E-03, 5.07493E-05, 4.36148E-03, 1.17863E-04, 4.74364E-03/ - DATA PT2/ & - 6.61278E-03, 4.34292E-05, 1.44373E-03, 2.41470E-05, 2.84426E-03,& - 8.56560E-04, 2.04028E-03, 0.00000E+00,-3.15994E+03,-2.46423E-03,& - 1.13843E-03, 4.20512E-04, 0.00000E+00,-9.77214E+01, 6.77794E-03,& - 5.27499E-03, 1.14936E-03, 0.00000E+00,-6.61311E-03,-1.84255E-02,& - -1.96259E-02, 2.98618E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 6.44574E+02, 8.84668E-04, 5.05066E-04, 0.00000E+00, 4.02881E+03,& - -1.89503E-03, 0.00000E+00, 0.00000E+00, 8.21407E-04, 2.06780E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -1.20410E-02,-3.63963E-03, 9.92070E-05,-1.15284E-04,-6.33059E-05,& - -6.05545E-01, 8.34218E-03,-9.13036E+01, 3.71042E-04, 0.00000E+00/ - DATA PT3/ & - 4.19000E-04, 2.70928E-03, 3.31507E-03,-4.44508E-03,-4.96334E-03,& - -1.60449E-03, 3.95119E-03, 2.48924E-03, 5.09815E-04, 4.05302E-03,& - 2.24076E-03, 0.00000E+00, 6.84256E-03, 4.66354E-04, 0.00000E+00,& - -3.68328E-04, 0.00000E+00, 0.00000E+00,-1.46870E+02, 0.00000E+00,& - 0.00000E+00, 1.09501E-03, 4.65156E-04, 5.62583E-04, 3.21596E+00,& - 6.43168E-04, 3.14860E-03, 3.40738E-03, 1.78481E-03, 9.62532E-04,& - 5.58171E-04, 3.43731E+00,-2.33195E-01, 5.10289E-04, 0.00000E+00,& - 0.00000E+00,-9.25347E+04, 0.00000E+00,-1.99639E-03, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! HE DENSITY - DATA PA1/ & - 1.09979E+00,-4.88060E-02,-1.97501E-01,-9.10280E-02,-6.96558E-03,& - 2.42136E-02, 3.91333E-01,-7.20068E-03,-3.22718E-02, 1.41508E+00,& - 1.68194E-01, 1.85282E-02, 1.09384E-01,-7.24282E+00, 0.00000E+00,& - 2.96377E-01,-4.97210E-02, 1.04114E+02,-8.61108E-02,-7.29177E-04,& - 1.48998E-06, 1.08629E-03, 0.00000E+00, 0.00000E+00, 8.31090E-02,& - 1.12818E-01,-5.75005E-02,-1.29919E-02,-1.78849E-02,-2.86343E-06,& - 0.00000E+00,-1.51187E+02,-6.65902E-03, 0.00000E+00,-2.02069E-03,& - 0.00000E+00, 0.00000E+00, 4.32264E-02,-2.80444E+01,-3.26789E-03,& - 2.47461E-03, 0.00000E+00, 0.00000E+00, 9.82100E-02, 1.22714E-01,& - -3.96450E-02, 0.00000E+00,-2.76489E-03, 0.00000E+00, 1.87723E-03/ - DATA PA2/ & - -8.09813E-03, 4.34428E-05,-7.70932E-03, 0.00000E+00,-2.28894E-03,& - -5.69070E-03,-5.22193E-03, 6.00692E-03,-7.80434E+03,-3.48336E-03,& - -6.38362E-03,-1.82190E-03, 0.00000E+00,-7.58976E+01,-2.17875E-02,& - -1.72524E-02,-9.06287E-03, 0.00000E+00, 2.44725E-02, 8.66040E-02,& - 1.05712E-01, 3.02543E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -6.01364E+03,-5.64668E-03,-2.54157E-03, 0.00000E+00, 3.15611E+02,& - -5.69158E-03, 0.00000E+00, 0.00000E+00,-4.47216E-03,-4.49523E-03,& - 4.64428E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 4.51236E-02, 2.46520E-02, 6.17794E-03, 0.00000E+00, 0.00000E+00,& - -3.62944E-01,-4.80022E-02,-7.57230E+01,-1.99656E-03, 0.00000E+00/ - DATA PA3/ & - -5.18780E-03,-1.73990E-02,-9.03485E-03, 7.48465E-03, 1.53267E-02,& - 1.06296E-02, 1.18655E-02, 2.55569E-03, 1.69020E-03, 3.51936E-02,& - -1.81242E-02, 0.00000E+00,-1.00529E-01,-5.10574E-03, 0.00000E+00,& - 2.10228E-03, 0.00000E+00, 0.00000E+00,-1.73255E+02, 5.07833E-01,& - -2.41408E-01, 8.75414E-03, 2.77527E-03,-8.90353E-05,-5.25148E+00,& - -5.83899E-03,-2.09122E-02,-9.63530E-03, 9.77164E-03, 4.07051E-03,& - 2.53555E-04,-5.52875E+00,-3.55993E-01,-2.49231E-03, 0.00000E+00,& - 0.00000E+00, 2.86026E+01, 0.00000E+00, 3.42722E-04, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! O DENSITY - DATA PB1/ & - 1.02315E+00,-1.59710E-01,-1.06630E-01,-1.77074E-02,-4.42726E-03,& - 3.44803E-02, 4.45613E-02,-3.33751E-02,-5.73598E-02, 3.50360E-01,& - 6.33053E-02, 2.16221E-02, 5.42577E-02,-5.74193E+00, 0.00000E+00,& - 1.90891E-01,-1.39194E-02, 1.01102E+02, 8.16363E-02, 1.33717E-04,& - 6.54403E-06, 3.10295E-03, 0.00000E+00, 0.00000E+00, 5.38205E-02,& - 1.23910E-01,-1.39831E-02, 0.00000E+00, 0.00000E+00,-3.95915E-06,& - 0.00000E+00,-7.14651E-01,-5.01027E-03, 0.00000E+00,-3.24756E-03,& - 0.00000E+00, 0.00000E+00, 4.42173E-02,-1.31598E+01,-3.15626E-03,& - 1.24574E-03,-1.47626E-03,-1.55461E-03, 6.40682E-02, 1.34898E-01,& - -2.42415E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 6.13666E-04/ - DATA PB2/ & - -5.40373E-03, 2.61635E-05,-3.33012E-03, 0.00000E+00,-3.08101E-03,& - -2.42679E-03,-3.36086E-03, 0.00000E+00,-1.18979E+03,-5.04738E-02,& - -2.61547E-03,-1.03132E-03, 1.91583E-04,-8.38132E+01,-1.40517E-02,& - -1.14167E-02,-4.08012E-03, 1.73522E-04,-1.39644E-02,-6.64128E-02,& - -6.85152E-02,-1.34414E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 6.07916E+02,-4.12220E-03,-2.20996E-03, 0.00000E+00, 1.70277E+03,& - -4.63015E-03, 0.00000E+00, 0.00000E+00,-2.25360E-03,-2.96204E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 3.92786E-02, 1.31186E-02,-1.78086E-03, 0.00000E+00, 0.00000E+00,& - -3.90083E-01,-2.84741E-02,-7.78400E+01,-1.02601E-03, 0.00000E+00/ - DATA PB3/ & - -7.26485E-04,-5.42181E-03,-5.59305E-03, 1.22825E-02, 1.23868E-02,& - 6.68835E-03,-1.03303E-02,-9.51903E-03, 2.70021E-04,-2.57084E-02,& - -1.32430E-02, 0.00000E+00,-3.81000E-02,-3.16810E-03, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-9.05762E-04,-2.14590E-03,-1.17824E-03, 3.66732E+00,& - -3.79729E-04,-6.13966E-03,-5.09082E-03,-1.96332E-03,-3.08280E-03,& - -9.75222E-04, 4.03315E+00,-2.52710E-01, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! N2 DENSITY - DATA PC1/ & - 1.16112E+00, 0.00000E+00, 0.00000E+00, 3.33725E-02, 0.00000E+00,& - 3.48637E-02,-5.44368E-03, 0.00000E+00,-6.73940E-02, 1.74754E-01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.74712E+02, 0.00000E+00,& - 1.26733E-01, 0.00000E+00, 1.03154E+02, 5.52075E-02, 0.00000E+00,& - 0.00000E+00, 8.13525E-04, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-2.50482E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.48894E-03,& - 6.16053E-04,-5.79716E-04, 2.95482E-03, 8.47001E-02, 1.70147E-01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PC2/ & - 0.00000E+00, 2.47425E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PC3/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! TLB - DATA PD1/ & - 9.44846E-01, 0.00000E+00, 0.00000E+00,-3.08617E-02, 0.00000E+00,& - -2.44019E-02, 6.48607E-03, 0.00000E+00, 3.08181E-02, 4.59392E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.74712E+02, 0.00000E+00,& - 2.13260E-02, 0.00000E+00,-3.56958E+02, 0.00000E+00, 1.82278E-04,& - 0.00000E+00, 3.07472E-04, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 3.83054E-03, 0.00000E+00, 0.00000E+00,& - -1.93065E-03,-1.45090E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.23493E-03, 1.36736E-03, 8.47001E-02, 1.70147E-01,& - 3.71469E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PD2/ & - 5.10250E-03, 2.47425E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 3.68756E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PD3/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! O2 DENSITY - DATA PE1/ & - 1.35580E+00, 1.44816E-01, 0.00000E+00, 6.07767E-02, 0.00000E+00,& - 2.94777E-02, 7.46900E-02, 0.00000E+00,-9.23822E-02, 8.57342E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.38636E+01, 0.00000E+00,& - 7.71653E-02, 0.00000E+00, 8.18751E+01, 1.87736E-02, 0.00000E+00,& - 0.00000E+00, 1.49667E-02, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-3.67874E+02, 5.48158E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 8.47001E-02, 1.70147E-01,& - 1.22631E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PE2/ & - 8.17187E-03, 3.71617E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.10826E-03,& - -3.13640E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -7.35742E-02,-5.00266E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 1.94965E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PE3/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! AR DENSITY - DATA PF1/ & - 1.04761E+00, 2.00165E-01, 2.37697E-01, 3.68552E-02, 0.00000E+00,& - 3.57202E-02,-2.14075E-01, 0.00000E+00,-1.08018E-01,-3.73981E-01,& - 0.00000E+00, 3.10022E-02,-1.16305E-03,-2.07596E+01, 0.00000E+00,& - 8.64502E-02, 0.00000E+00, 9.74908E+01, 5.16707E-02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 3.46193E+02, 1.34297E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-3.48509E-03,& - -1.54689E-04, 0.00000E+00, 0.00000E+00, 8.47001E-02, 1.70147E-01,& - 1.47753E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PF2/ & - 1.89320E-02, 3.68181E-05, 1.32570E-02, 0.00000E+00, 0.00000E+00,& - 3.59719E-03, 7.44328E-03,-1.00023E-03,-6.50528E+03, 0.00000E+00,& - 1.03485E-02,-1.00983E-03,-4.06916E-03,-6.60864E+01,-1.71533E-02,& - 1.10605E-02, 1.20300E-02,-5.20034E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -2.62769E+03, 7.13755E-03, 4.17999E-03, 0.00000E+00, 1.25910E+04,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.23595E-03, 4.60217E-03,& - 5.71794E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -3.18353E-02,-2.35526E-02,-1.36189E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.03522E-02,-6.67837E+01,-1.09724E-03, 0.00000E+00/ - DATA PF3/ & - -1.38821E-02, 1.60468E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.51574E-02,& - -5.44470E-04, 0.00000E+00, 7.28224E-02, 6.59413E-02, 0.00000E+00,& - -5.15692E-03, 0.00000E+00, 0.00000E+00,-3.70367E+03, 0.00000E+00,& - 0.00000E+00, 1.36131E-02, 5.38153E-03, 0.00000E+00, 4.76285E+00,& - -1.75677E-02, 2.26301E-02, 0.00000E+00, 1.76631E-02, 4.77162E-03,& - 0.00000E+00, 5.39354E+00, 0.00000E+00,-7.51710E-03, 0.00000E+00,& - 0.00000E+00,-8.82736E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! H DENSITY - DATA PG1/ & - 1.26376E+00,-2.14304E-01,-1.49984E-01, 2.30404E-01, 2.98237E-02,& - 2.68673E-02, 2.96228E-01, 2.21900E-02,-2.07655E-02, 4.52506E-01,& - 1.20105E-01, 3.24420E-02, 4.24816E-02,-9.14313E+00, 0.00000E+00,& - 2.47178E-02,-2.88229E-02, 8.12805E+01, 5.10380E-02,-5.80611E-03,& - 2.51236E-05,-1.24083E-02, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01,-3.48190E-02, 0.00000E+00, 0.00000E+00, 2.89885E-05,& - 0.00000E+00, 1.53595E+02,-1.68604E-02, 0.00000E+00, 1.01015E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.84552E-04,& - -1.22181E-03, 0.00000E+00, 0.00000E+00, 8.47001E-02, 1.70147E-01,& - -1.04927E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00,-5.91313E-03/ - DATA PG2/ & - -2.30501E-02, 3.14758E-05, 0.00000E+00, 0.00000E+00, 1.26956E-02,& - 8.35489E-03, 3.10513E-04, 0.00000E+00, 3.42119E+03,-2.45017E-03,& - -4.27154E-04, 5.45152E-04, 1.89896E-03, 2.89121E+01,-6.49973E-03,& - -1.93855E-02,-1.48492E-02, 0.00000E+00,-5.10576E-02, 7.87306E-02,& - 9.51981E-02,-1.49422E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 2.65503E+02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 6.37110E-03, 3.24789E-04,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 6.14274E-02, 1.00376E-02,-8.41083E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.27099E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PG3/ & - -3.94077E-03,-1.28601E-02,-7.97616E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-6.71465E-03,-1.69799E-03, 1.93772E-03, 3.81140E+00,& - -7.79290E-03,-1.82589E-02,-1.25860E-02,-1.04311E-02,-3.02465E-03,& - 2.43063E-03, 3.63237E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! N DENSITY - DATA PH1/ & - 7.09557E+01,-3.26740E-01, 0.00000E+00,-5.16829E-01,-1.71664E-03,& - 9.09310E-02,-6.71500E-01,-1.47771E-01,-9.27471E-02,-2.30862E-01,& - -1.56410E-01, 1.34455E-02,-1.19717E-01, 2.52151E+00, 0.00000E+00,& - -2.41582E-01, 5.92939E-02, 4.39756E+00, 9.15280E-02, 4.41292E-03,& - 0.00000E+00, 8.66807E-03, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 9.74701E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 6.70217E+01,-1.31660E-03, 0.00000E+00,-1.65317E-02,& - 0.00000E+00, 0.00000E+00, 8.50247E-02, 2.77428E+01, 4.98658E-03,& - 6.15115E-03, 9.50156E-03,-2.12723E-02, 8.47001E-02, 1.70147E-01,& - -2.38645E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.37380E-03/ - DATA PH2/ & - -8.41918E-03, 2.80145E-05, 7.12383E-03, 0.00000E+00,-1.66209E-02,& - 1.03533E-04,-1.68898E-02, 0.00000E+00, 3.64526E+03, 0.00000E+00,& - 6.54077E-03, 3.69130E-04, 9.94419E-04, 8.42803E+01,-1.16124E-02,& - -7.74414E-03,-1.68844E-03, 1.42809E-03,-1.92955E-03, 1.17225E-01,& - -2.41512E-02, 1.50521E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 1.60261E+03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-3.54403E-04,-1.87270E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 2.76439E-02, 6.43207E-03,-3.54300E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-2.80221E-02, 8.11228E+01,-6.75255E-04, 0.00000E+00/ - DATA PH3/ & - -1.05162E-02,-3.48292E-03,-6.97321E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.45546E-03,-1.31970E-02,-3.57751E-03,-1.09021E+00,& - -1.50181E-02,-7.12841E-03,-6.64590E-03,-3.52610E-03,-1.87773E-02,& - -2.22432E-03,-3.93895E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! HOT O DENSITY - DATA PI1/ & - 6.04050E-02, 1.57034E+00, 2.99387E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-1.51018E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-8.61650E+00, 1.26454E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 5.50878E-03, 0.00000E+00, 0.00000E+00, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 6.23881E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 8.47001E-02, 1.70147E-01,& - -9.45934E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PI2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PI3/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! S PARAM - DATA PJ1/ & - 9.56827E-01, 6.20637E-02, 3.18433E-02, 0.00000E+00, 0.00000E+00,& - 3.94900E-02, 0.00000E+00, 0.00000E+00,-9.24882E-03,-7.94023E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.74712E+02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.74677E-03, 0.00000E+00, 1.54951E-02, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-6.99007E-04, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 1.24362E-02,-5.28756E-03, 8.47001E-02, 1.70147E-01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PJ2/ & - 0.00000E+00, 2.47425E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PJ3/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! TURBO - DATA PK1/ & - 1.09930E+00, 3.90631E+00, 3.07165E+00, 9.86161E-01, 1.63536E+01,& - 4.63830E+00, 1.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 1.28840E+00, 3.10302E-02, 1.18339E-01,& - 1.00000E+00, 7.00000E-01, 1.15020E+00, 3.44689E+00, 1.28840E+00,& - 1.00000E+00, 1.08738E+00, 1.22947E+00, 1.10016E+00, 7.34129E-01,& - 1.15241E+00, 2.22784E+00, 7.95046E-01, 4.01612E+00, 4.47749E+00,& - 1.23435E+02,-7.60535E-02, 1.68986E-06, 7.44294E-01, 1.03604E+00,& - 1.72783E+02, 1.15020E+00, 3.44689E+00,-7.46230E-01, 9.49154E-01/ -! LOWER BOUNDARY - DATA PTM/ & - 1.04130E+03, 3.86000E+02, 1.95000E+02, 1.66728E+01, 2.13000E+02,& - 1.20000E+02, 2.40000E+02, 1.87000E+02,-2.00000E+00, 0.00000E+00/ - DATA PDM/ & - 2.45600E+07, 6.71072E-06, 1.00000E+02, 0.00000E+00, 1.10000E+02,& - 1.00000E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 8.59400E+10, 1.00000E+00, 1.05000E+02,-8.00000E+00, 1.10000E+02,& - 1.00000E+01, 9.00000E+01, 2.00000E+00, 0.00000E+00, 0.00000E+00,& - 2.81000E+11, 0.00000E+00, 1.05000E+02, 2.80000E+01, 2.89500E+01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 3.30000E+10, 2.68270E-01, 1.05000E+02, 1.00000E+00, 1.10000E+02,& - 1.00000E+01, 1.10000E+02,-1.00000E+01, 0.00000E+00, 0.00000E+00,& - 1.33000E+09, 1.19615E-02, 1.05000E+02, 0.00000E+00, 1.10000E+02,& - 1.00000E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 1.76100E+05, 1.00000E+00, 9.50000E+01,-8.00000E+00, 1.10000E+02,& - 1.00000E+01, 9.00000E+01, 2.00000E+00, 0.00000E+00, 0.00000E+00,& - 1.00000E+07, 1.00000E+00, 1.05000E+02,-8.00000E+00, 1.10000E+02,& - 1.00000E+01, 9.00000E+01, 2.00000E+00, 0.00000E+00, 0.00000E+00,& - 1.00000E+06, 1.00000E+00, 1.05000E+02,-8.00000E+00, 5.50000E+02,& - 7.60000E+01, 9.00000E+01, 2.00000E+00, 0.00000E+00, 4.00000E+03/ -! TN1(2) - DATA PL1/ & - 1.00858E+00, 4.56011E-02,-2.22972E-02,-5.44388E-02, 5.23136E-04,& - -1.88849E-02, 5.23707E-02,-9.43646E-03, 6.31707E-03,-7.80460E-02,& - -4.88430E-02, 0.00000E+00, 0.00000E+00,-7.60250E+00, 0.00000E+00,& - -1.44635E-02,-1.76843E-02,-1.21517E+02, 2.85647E-02, 0.00000E+00,& - 0.00000E+00, 6.31792E-04, 0.00000E+00, 5.77197E-03, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-8.90272E+03, 3.30611E-03, 3.02172E-03, 0.00000E+00,& - -2.13673E-03,-3.20910E-04, 0.00000E+00, 0.00000E+00, 2.76034E-03,& - 2.82487E-03,-2.97592E-04,-4.21534E-03, 8.47001E-02, 1.70147E-01,& - 8.96456E-03, 0.00000E+00,-1.08596E-02, 0.00000E+00, 0.00000E+00/ - DATA PL2/ & - 5.57917E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 9.65405E-03, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN1(3) - DATA PM1/ & - 9.39664E-01, 8.56514E-02,-6.79989E-03, 2.65929E-02,-4.74283E-03,& - 1.21855E-02,-2.14905E-02, 6.49651E-03,-2.05477E-02,-4.24952E-02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.19148E+01, 0.00000E+00,& - 1.18777E-02,-7.28230E-02,-8.15965E+01, 1.73887E-02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-1.44691E-02, 2.80259E-04, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.16584E+02, 3.18713E-03, 7.37479E-03, 0.00000E+00,& - -2.55018E-03,-3.92806E-03, 0.00000E+00, 0.00000E+00,-2.89757E-03,& - -1.33549E-03, 1.02661E-03, 3.53775E-04, 8.47001E-02, 1.70147E-01,& - -9.17497E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PM2/ & - 3.56082E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.00902E-02, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN1(4) - DATA PN1/ & - 9.85982E-01,-4.55435E-02, 1.21106E-02, 2.04127E-02,-2.40836E-03,& - 1.11383E-02,-4.51926E-02, 1.35074E-02,-6.54139E-03, 1.15275E-01,& - 1.28247E-01, 0.00000E+00, 0.00000E+00,-5.30705E+00, 0.00000E+00,& - -3.79332E-02,-6.24741E-02, 7.71062E-01, 2.96315E-02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 6.81051E-03,-4.34767E-03, 8.66784E-02,& - 1.58727E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 1.07003E+01,-2.76907E-03, 4.32474E-04, 0.00000E+00,& - 1.31497E-03,-6.47517E-04, 0.00000E+00,-2.20621E+01,-1.10804E-03,& - -8.09338E-04, 4.18184E-04, 4.29650E-03, 8.47001E-02, 1.70147E-01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PN2/ & - -4.04337E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-9.52550E-04,& - 8.56253E-04, 4.33114E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.21223E-03,& - 2.38694E-04, 9.15245E-04, 1.28385E-03, 8.67668E-04,-5.61425E-06,& - 1.04445E+00, 3.41112E+01, 0.00000E+00,-8.40704E-01,-2.39639E+02,& - 7.06668E-01,-2.05873E+01,-3.63696E-01, 2.39245E+01, 0.00000E+00,& - -1.06657E-03,-7.67292E-04, 1.54534E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN1(5) TN2(1) - DATA PO1/ & - 1.00320E+00, 3.83501E-02,-2.38983E-03, 2.83950E-03, 4.20956E-03,& - 5.86619E-04, 2.19054E-02,-1.00946E-02,-3.50259E-03, 4.17392E-02,& - -8.44404E-03, 0.00000E+00, 0.00000E+00, 4.96949E+00, 0.00000E+00,& - -7.06478E-03,-1.46494E-02, 3.13258E+01,-1.86493E-03, 0.00000E+00,& - -1.67499E-02, 0.00000E+00, 0.00000E+00, 5.12686E-04, 8.66784E-02,& - 1.58727E-01,-4.64167E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 4.37353E-03,-1.99069E+02, 0.00000E+00,-5.34884E-03, 0.00000E+00,& - 1.62458E-03, 2.93016E-03, 2.67926E-03, 5.90449E+02, 0.00000E+00,& - 0.00000E+00,-1.17266E-03,-3.58890E-04, 8.47001E-02, 1.70147E-01,& - 0.00000E+00, 0.00000E+00, 1.38673E-02, 0.00000E+00, 0.00000E+00/ - DATA PO2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.60571E-03,& - 6.28078E-04, 5.05469E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-1.57829E-03,& - -4.00855E-04, 5.04077E-05,-1.39001E-03,-2.33406E-03,-4.81197E-04,& - 1.46758E+00, 6.20332E+00, 0.00000E+00, 3.66476E-01,-6.19760E+01,& - 3.09198E-01,-1.98999E+01, 0.00000E+00,-3.29933E+02, 0.00000E+00,& - -1.10080E-03,-9.39310E-05, 1.39638E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN2(2) - DATA PP1/ & - 9.81637E-01,-1.41317E-03, 3.87323E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-3.58707E-02,& - -8.63658E-03, 0.00000E+00, 0.00000E+00,-2.02226E+00, 0.00000E+00,& - -8.69424E-03,-1.91397E-02, 8.76779E+01, 4.52188E-03, 0.00000E+00,& - 2.23760E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-7.07572E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - -4.11210E-03, 3.50060E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-8.36657E-03, 1.61347E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-1.45130E-02, 0.00000E+00, 0.00000E+00/ - DATA PP2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.24152E-03,& - 6.43365E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.33255E-03,& - 2.42657E-03, 1.60666E-03,-1.85728E-03,-1.46874E-03,-4.79163E-06,& - 1.22464E+00, 3.53510E+01, 0.00000E+00, 4.49223E-01,-4.77466E+01,& - 4.70681E-01, 8.41861E+00,-2.88198E-01, 1.67854E+02, 0.00000E+00,& - 7.11493E-04, 6.05601E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN2(3) - DATA PQ1/ & - 1.00422E+00,-7.11212E-03, 5.24480E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-5.28914E-02,& - -2.41301E-02, 0.00000E+00, 0.00000E+00,-2.12219E+01,-1.03830E-02,& - -3.28077E-03, 1.65727E-02, 1.68564E+00,-6.68154E-03, 0.00000E+00,& - 1.45155E-02, 0.00000E+00, 8.42365E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-4.34645E-03, 0.00000E+00, 0.00000E+00, 2.16780E-02,& - 0.00000E+00,-1.38459E+02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 7.04573E-03,-4.73204E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 1.08767E-02, 0.00000E+00, 0.00000E+00/ - DATA PQ2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-8.08279E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 5.21769E-04,& - -2.27387E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.26769E-03,& - 3.16901E-03, 4.60316E-04,-1.01431E-04, 1.02131E-03, 9.96601E-04,& - 1.25707E+00, 2.50114E+01, 0.00000E+00, 4.24472E-01,-2.77655E+01,& - 3.44625E-01, 2.75412E+01, 0.00000E+00, 7.94251E+02, 0.00000E+00,& - 2.45835E-03, 1.38871E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN2(4) TN3(1) - DATA PR1/ & - 1.01890E+00,-2.46603E-02, 1.00078E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-6.70977E-02,& - -4.02286E-02, 0.00000E+00, 0.00000E+00,-2.29466E+01,-7.47019E-03,& - 2.26580E-03, 2.63931E-02, 3.72625E+01,-6.39041E-03, 0.00000E+00,& - 9.58383E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.85291E-03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 1.39717E+02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 9.19771E-03,-3.69121E+02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-1.57067E-02, 0.00000E+00, 0.00000E+00/ - DATA PR2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-7.07265E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.92953E-03,& - -2.77739E-03,-4.40092E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.47280E-03,& - 2.95035E-04,-1.81246E-03, 2.81945E-03, 4.27296E-03, 9.78863E-04,& - 1.40545E+00,-6.19173E+00, 0.00000E+00, 0.00000E+00,-7.93632E+01,& - 4.44643E-01,-4.03085E+02, 0.00000E+00, 1.15603E+01, 0.00000E+00,& - 2.25068E-03, 8.48557E-04,-2.98493E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN3(2) - DATA PS1/ & - 9.75801E-01, 3.80680E-02,-3.05198E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.85575E-02,& - 5.04057E-02, 0.00000E+00, 0.00000E+00,-1.76046E+02, 1.44594E-02,& - -1.48297E-03,-3.68560E-03, 3.02185E+01,-3.23338E-03, 0.00000E+00,& - 1.53569E-02, 0.00000E+00,-1.15558E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 4.89620E-03, 0.00000E+00, 0.00000E+00,-1.00616E-02,& - -8.21324E-03,-1.57757E+02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 6.63564E-03, 4.58410E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-2.51280E-02, 0.00000E+00, 0.00000E+00/ - DATA PS2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 9.91215E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-8.73148E-04,& - -1.29648E-03,-7.32026E-05, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-4.68110E-03,& - -4.66003E-03,-1.31567E-03,-7.39390E-04, 6.32499E-04,-4.65588E-04,& - -1.29785E+00,-1.57139E+02, 0.00000E+00, 2.58350E-01,-3.69453E+01,& - 4.10672E-01, 9.78196E+00,-1.52064E-01,-3.85084E+03, 0.00000E+00,& - -8.52706E-04,-1.40945E-03,-7.26786E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN3(3) - DATA PU1/ & - 9.60722E-01, 7.03757E-02,-3.00266E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.22671E-02,& - 4.10423E-02, 0.00000E+00, 0.00000E+00,-1.63070E+02, 1.06073E-02,& - 5.40747E-04, 7.79481E-03, 1.44908E+02, 1.51484E-04, 0.00000E+00,& - 1.97547E-02, 0.00000E+00,-1.41844E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 5.77884E-03, 0.00000E+00, 0.00000E+00, 9.74319E-03,& - 0.00000E+00,-2.88015E+03, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-4.44902E-03,-2.92760E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 2.34419E-02, 0.00000E+00, 0.00000E+00/ - DATA PU2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 5.36685E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-4.65325E-04,& - -5.50628E-04, 3.31465E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.06179E-03,& - -3.08575E-03,-7.93589E-04,-1.08629E-04, 5.95511E-04,-9.05050E-04,& - 1.18997E+00, 4.15924E+01, 0.00000E+00,-4.72064E-01,-9.47150E+02,& - 3.98723E-01, 1.98304E+01, 0.00000E+00, 3.73219E+03, 0.00000E+00,& - -1.50040E-03,-1.14933E-03,-1.56769E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN3(4) - DATA PV1/ & - 1.03123E+00,-7.05124E-02, 8.71615E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-3.82621E-02,& - -9.80975E-03, 0.00000E+00, 0.00000E+00, 2.89286E+01, 9.57341E-03,& - 0.00000E+00, 0.00000E+00, 8.66153E+01, 7.91938E-04, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 4.68917E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 7.86638E-03, 0.00000E+00, 0.00000E+00, 9.90827E-03,& - 0.00000E+00, 6.55573E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-4.00200E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 7.07457E-03, 0.00000E+00, 0.00000E+00/ - DATA PV2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 5.72268E-03,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.04970E-04,& - 1.21560E-03,-8.05579E-06, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.49941E-03,& - -4.57256E-04,-1.59311E-04, 2.96481E-04,-1.77318E-03,-6.37918E-04,& - 1.02395E+00, 1.28172E+01, 0.00000E+00, 1.49903E-01,-2.63818E+01,& - 0.00000E+00, 4.70628E+01,-2.22139E-01, 4.82292E-02, 0.00000E+00,& - -8.67075E-04,-5.86479E-04, 5.32462E-04, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TN3(5) SURFACE TEMP TSL - DATA PW1/ & - 1.00828E+00,-9.10404E-02,-2.26549E-02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-2.32420E-02,& - -9.08925E-03, 0.00000E+00, 0.00000E+00, 3.36105E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-1.24957E+01,-5.87939E-03, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.79765E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.01237E+03, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-1.75553E-02, 0.00000E+00, 0.00000E+00/ - DATA PW2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.29699E-03,& - 1.26659E-03, 2.68402E-04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 1.17894E-03,& - 1.48746E-03, 1.06478E-04, 1.34743E-04,-2.20939E-03,-6.23523E-04,& - 6.36539E-01, 1.13621E+01, 0.00000E+00,-3.93777E-01, 2.38687E+03,& - 0.00000E+00, 6.61865E+02,-1.21434E-01, 9.27608E+00, 0.00000E+00,& - 1.68478E-04, 1.24892E-03, 1.71345E-03, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TGN3(2) SURFACE GRAD TSLG - DATA PX1/ & - 1.57293E+00,-6.78400E-01, 6.47500E-01, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-7.62974E-02,& - -3.60423E-01, 0.00000E+00, 0.00000E+00, 1.28358E+02, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 4.68038E+01, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.67898E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.90994E+04, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.15706E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PX2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TGN2(1) TGN1(2) - DATA PY1/ & - 8.60028E-01, 3.77052E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-1.17570E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 7.77757E-03, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 1.01024E+02, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 6.54251E+02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ - DATA PY2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,-1.56959E-02,& - 1.91001E-02, 3.15971E-02, 1.00982E-02,-6.71565E-03, 2.57693E-03,& - 1.38692E+00, 2.82132E-01, 0.00000E+00, 0.00000E+00, 3.81511E+02,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! TGN3(1) TGN2(2) - DATA PZ1/ & - 1.06029E+00,-5.25231E-02, 3.73034E-01, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.31072E-02,& - -3.88409E-01, 0.00000E+00, 0.00000E+00,-1.65295E+02,-2.13801E-01,& - -4.38916E-02,-3.22716E-01,-8.82393E+01, 1.18458E-01, 0.00000E+00,& - -4.35863E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00,-1.19782E-01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 2.62229E+01, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00,-5.37443E+01, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00,-4.55788E-01, 0.00000E+00, 0.00000E+00/ - DATA PZ2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 3.84009E-02,& - 3.96733E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 5.05494E-02,& - 7.39617E-02, 1.92200E-02,-8.46151E-03,-1.34244E-02, 1.96338E-02,& - 1.50421E+00, 1.88368E+01, 0.00000E+00, 0.00000E+00,-5.13114E+01,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 5.11923E-02, 3.61225E-02, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 2.00000E+00/ -! SEMIANNUAL MULT SAM - DATA PAA1/ & - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00,& - 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00, 1.00000E+00/ - DATA PAA2/ & - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,& - 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00/ -! MIDDLE ATMOSPHERE AVERAGES - DATA PAVGM/ & - 2.61000E+02, 2.64000E+02, 2.29000E+02, 2.17000E+02, 2.17000E+02,& - 2.23000E+02, 2.86760E+02,-2.93940E+00, 2.50000E+00, 0.00000E+00/ - END diff --git a/sorc/global_chgres.fd/nsst_chgres.f90 b/sorc/global_chgres.fd/nsst_chgres.f90 deleted file mode 100644 index 7fe7e317a..000000000 --- a/sorc/global_chgres.fd/nsst_chgres.f90 +++ /dev/null @@ -1,238 +0,0 @@ -!> @file -! -!> -!! -!! interpolate nsst fields from one grid to another. -!! nearest neighbor interpolation is used because some nsst -!! fields are not continuous. nsst fields are only required -!! at open water points. for consistency, the nsst land-sea -!! mask is set to the land-sea mask from the surface restart -!! file. therefore, when converting an nsst restart file, -!! you must also convert a surface restart file. -!! -!! program history: -!! =============== -!! - 2011-aug-05 initial version gayno -!! - 2017-dec-19 add bilinear option. ensure mask -!! consistency between skin t and tref. -!! -!! @author gayno @date 2011-Aug -!! - subroutine nsst_chgres(im_input, jm_input, & - mask_output, tskin_output, imo, ij_output, kgds_input, & - data_input, mask_input, data_output, num_nsst_fields, & - kgds_output, rlat_output, rlon_output) - - implicit none - - integer, intent(in) :: imo - ! number of grid points on the - ! cubed-sphere side - integer, intent(in) :: ij_output - ! number of grid points - output grid. - integer, intent(in) :: kgds_input(200), kgds_output(200) - ! grib 1 grid desc section - input/output grids - integer, intent(in) :: im_input, jm_input - ! number of grid points in i/j direction - - ! input grid. - integer, intent(in) :: num_nsst_fields - ! number of nsst fields - - real, intent(in) :: mask_output(ij_output) - ! land mask - output grid - real, intent(in) :: tskin_output(ij_output) - ! skin temperature - output grid - real, intent(in) :: rlat_output(ij_output) - ! latitudes on output grid - real, intent(in) :: rlon_output(ij_output) - ! longitudes on output grid - real, intent(in) :: data_input(im_input,jm_input,num_nsst_fields) - ! nsst data on input grid - real, intent(in) :: mask_input(im_input,jm_input) - ! mask on input grid - - integer :: count_water - ! number of output grid points that are open water. - integer :: ij_input - ! number of grid points, input grid - integer :: ip, iret, ipopt(20) - integer :: ibi(num_nsst_fields), ibo(num_nsst_fields) - integer :: i, j, ij, k - integer, allocatable :: ijsav_water(:) - integer :: kgds(200) - - logical*1, allocatable :: bitmap_input(:,:,:) - logical*1, allocatable :: bitmap_water(:,:) - - real :: data_output(ij_output,num_nsst_fields) - real, allocatable :: data_water(:,:) - real, allocatable :: rlat_water(:), rlon_water(:) - real :: mdl_res_input, mdl_res_output - -!---------------------------------------------------------------- -! Set defaults at non-water points. -!---------------------------------------------------------------- - - data_output=0.0 ! zero out fields at non-water points - data_output(:,5) = 30.0 ! filler value for xz at non-water points - data_output(:,17) = tskin_output ! use skin temperature from the - ! land model as fill value - ! for tref at non-water points. - -!---------------------------------------------------------------- -! Only interpolate to output points that are open water. -! Mask values are: 0-open water, 1-land, 2-sea ice. -!---------------------------------------------------------------- - - count_water=0 - do ij=1, ij_output - if (mask_output(ij) < 0.5) then - count_water=count_water+1 - endif - enddo - - if (count_water == 0) return - -!---------------------------------------------------------------- -! Bitmap flag for input data. All input fields will be -! interpolated using the same bitmap. -!---------------------------------------------------------------- - - ibi=1 - -!---------------------------------------------------------------- -! mask is: 0-open water, 1-land, 2-sea ice. nsst model -! only operates at open water points. Mask out these points. -! The one exception is TREF. Here include the TREF -! values at ice points. This is done for consistency with -! the how skin temperature is interpolated in surface_chgres.f90. -! At non-land points, skin temperture is a blend of the ice -! skin temp and the SST. So non-land skin temp is interpolated -! to non-land points. If TREF values at ice points are -! ignored, very large differences between skin/sst and TREF -! can happen near ice edges. -!---------------------------------------------------------------- - - allocate(bitmap_input(im_input,jm_input,num_nsst_fields)) - bitmap_input=.false. - do j=1,jm_input - do i=1,im_input - if (mask_input(i,j) < 0.5) then - bitmap_input(i,j,1:16)=.true. - bitmap_input(i,j,18:num_nsst_fields)=.true. - endif - enddo - enddo - - bitmap_input(:,:,17) = .false. ! TREF - do j=1,jm_input - do i=1,im_input - if (mask_input(i,j) < 0.5 .or. mask_input(i,j) > 1.5) then - bitmap_input(i,j,17)=.true. - endif - enddo - enddo - - allocate(rlat_water(count_water)) - allocate(rlon_water(count_water)) - allocate(ijsav_water(count_water)) - count_water=0 - do ij=1, ij_output - if (mask_output(ij) < 0.5) then - count_water=count_water+1 - rlat_water(count_water)=rlat_output(ij) - rlon_water(count_water)=rlon_output(ij) - ijsav_water(count_water)=ij - endif - enddo - - allocate(data_water(count_water,num_nsst_fields)) - data_water=0.0 - allocate(bitmap_water(count_water,num_nsst_fields)) - bitmap_water=.false. - -!---------------------------------------------------------------- -! ipolates options. Must ensure these are the same -! values used in surface_chgres.f90. -!---------------------------------------------------------------- - - mdl_res_input = 360.0 / float(kgds_input(2)) - mdl_res_output = 360.0 / (float(imo) * 4.0) - - ipopt=0 - - if (mdl_res_input <= (0.75*mdl_res_output)) then - print*,"- INTERPOLATE NSST DATA FIELDS USING BILINEAR METHOD." - ip = 0 - ipopt(1)=1 - ipopt(2) = nint(1.0 / mdl_res_input) + 1 ! search box width of 1 deg. - else - print*,"- INTERPOLATE NSST DATA FIELDS USING NEIGHBOR METHOD." - ipopt(1) = nint(1.0 / mdl_res_input) + 1 ! search box width of 1 deg. - ip = 2 - end if - - kgds=kgds_output - kgds(1)=-1 ! tell ipolates to interpolate to just water points. - ! default is to interpolate to all grid points. - iret =0 - ij_input =im_input*jm_input - - call ipolates(ip,ipopt,kgds_input,kgds,ij_input,count_water,& - num_nsst_fields, ibi, bitmap_input, data_input, & - count_water,rlat_water,rlon_water,ibo,bitmap_water, & - data_water,iret) - - if (iret /=0) then - print*,'fatal error in ipolates interpolating nsst data ',iret - stop 445 - endif - - deallocate(bitmap_input) - -!---------------------------------------------------------------- -! ipolates may not find data at every output grid point. -! This can happen with isolated lakes, for example. -! Need to fill these points with default values. -!---------------------------------------------------------------- - - do k = 1, num_nsst_fields - do ij=1, count_water - if (.not.bitmap_water(ij,k)) then - data_water(ij,k)=0.0 ! default value for most fields - if (k==5) data_water(ij,k)=30.0 ! default value for xz - if (k==16) data_water(ij,k)=1.0 ! default value for ifd - if (k==17) then ! default for tref is skin t (sst) - data_water(ij,k)=tskin_output(ijsav_water(ij)) - write(6,50) rlat_water(ij), rlon_water(ij), data_water(ij,k) - endif - endif - enddo - enddo - -!---------------------------------------------------------------- -! IFD is a flag, but is stored as a float. Remove and -! fractional values. -!---------------------------------------------------------------- - - data_water(:,16) = float(nint(data_water(:,16))) - - deallocate(rlat_water,rlon_water,bitmap_water) - - 50 format(1x,'- USING DEFAULT VALUE FOR TREF AT LAT: ',f6.2, & - ' LON: ',f7.2,' IS ',f5.1) - -!---------------------------------------------------------------- -! Now put the water points back into the array that holds -! all output grid points. -!---------------------------------------------------------------- - - do ij=1, count_water - data_output(ijsav_water(ij),:)=data_water(ij,:) - enddo - - deallocate (ijsav_water) - deallocate (data_water) - - return - end subroutine nsst_chgres diff --git a/sorc/global_chgres.fd/nstio_module.f90 b/sorc/global_chgres.fd/nstio_module.f90 deleted file mode 100755 index 160e6bd54..000000000 --- a/sorc/global_chgres.fd/nstio_module.f90 +++ /dev/null @@ -1,1235 +0,0 @@ -!> @file -!! -!! API for global spectral nst file I/O (modified from sfcio_modul) -!! @author Xu Li @date 2007-10-26. -!! -!! This module provides an Application Program Interface -!! for performing I/O on the nst restart file of the global nst diurnal warming and sub-layer cooling models. -!! Functions include opening, reading, writing, and closing as well as -!! allocating and deallocating data buffers sed in the transfers. -!! The I/O performed here is sequential. -!! The transfers are limited to header records or data records. -!! -!! Program History Log: -!! - 2007-10-26 Xu Li -!! - 2008-03-25 Xu Li: add surface mask field -!! - 2009-06-30 Xu Li: modified for NCEP DTM-1p -!! -!! Public Variables: -!! - nstio_lhead1 Integer parameter length of first header record (=32) -!! - nstio_intkind Integer parameter kind or length of passed integers (=4) -!! - nstio_realkind Integer parameter kind or length of passed reals (=4) -!! - nstio_dblekind Integer parameter kind or length of passed longreals (=8) -!! - nstio_realfill Real(nstio_realkind) fill value (=-9999.) -!! - nstio_dblefill Real(nstio_dblekind) fill value (=-9999.) -!! -!! Public Defined Types: -!! - nstio_head nst file header information -!! - clabnst Character(nstio_lhead1) ON85 label -!! - fhour Real(nstio_realkind) forecast hour -!! - idate Integer(nstio_intkind)(4) initial date -!! (hour, month, day, 4-digit year) -!! - latb Integer(nstio_intkind) latitudes -!! - lonb Integer(nstio_intkind) longitudes -!! - ivo Integer(nstio_intkind) version number -!! - lsea Integer(nstio_intkind) sea levels -!! - irealf Integer(sigio_intkind) floating point flag -!! (=1 for 4-byte ieee, =2 for 8-byte ieee) -!! - lpl Integer(nstio_intkind)(latb/2) lons per lat -!! - zsea Real(nstio_realkind) sea depths (meter) -!! -!! - nstio_data nst file data fields -!! - slmsk Real(nstio_realkind)(:,:) pointer to lonb*latb -!! surface mask: 0 = water; 1 = land; 2 = ice -!! - xt Real(nstio_realkind)(:,:) pointer to lonb*latb -!! heat content in DTL (M*K) -!! - xs Real(nstio_realkind)(:,:) pointer to lonb*latb -!! salinity content in DTL (M*ppt) -!! - xu Real(nstio_realkind)(:,:) pointer to lonb*latb -!! u-current content in DTL (M*M/S) -!! - xv Real(nstio_realkind)(:,:) pointer to lonb*latb -!! v-current content in DTL (M*M/S) -!! - xz Real(nstio_realkind)(:,:) pointer to lonb*latb -!! DTL thickness (M) -!! - zm Real(nstio_realkind)(:,:) pointer to lonb*latb -!! MXL thickness (M) -!! - xtts Real(nstio_realkind)(:,:) pointer to lonb*latb -!! d(xt)/d(Ts) (1/M) -!! - xzts Real(nstio_realkind)(:,:) pointer to lonb*latb -!! d(xz)/d(Ts) (M/K) -!! - dt_cool Real(nstio_realkind)(:,:) pointer to lonb*latb -!! sea surface cooling amount by sub-layer cooling effect -!! - z_c Real(nstio_realkind)(:,:) pointer to lonb*latb -!! sea sub-layer depth in m -!! - c_0 Real(nstio_realkind)(:,:) pointer to lonb*latb -!! coefficient to calculate d(Tz)/d(tr) in dimensionless -!! - c_d Real(nstio_realkind)(:,:) pointer to lonb*latb -!! coefficient to calculate d(Tz)/d(tr) in (1/M) -!! - w_0 Real(nstio_realkind)(:,:) pointer to lonb*latb -!! coefficient to calculate d(Tz)/d(tr) in dimensionless -!! - w_d Real(nstio_realkind)(:,:) pointer to lonb*latb -!! coefficient to calculate d(Tz)/d(tr) (1/M) -!! - d_conv Real(nstio_realkind)(:,:) pointer to lonb*latb -!! FCL thickness (M) -!! - ifd Real(nstio_realkind)(:,:) pointer to lonb*latb -!! index of time integral started mode: 0 = not yet; 1 = started already -!! - Tref Real(nstio_realkind)(:,:) pointer to lonb*latb -!! reference temperature (K) -!! - Qrain Real(nstio_realkind)(:,:) pointer to lonb*latb -!! sensible heat flux due to rainfall (W*M^-2) -!! -!! - nstio_dbta nst file longreal data fields -!! -!! 
-!! Public Subprograms:
-!!   nstio_sropen      Open nst file for sequential reading
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     cfname            Character(*) input filename
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_swopen      Open nst file for sequential writing
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     cfname            Character(*) input filename
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_srclose      Close nst file for sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_srhead      Read header information with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) output header information
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_swhead      Write header information with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) input header information
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_alhead      Allocate head allocatables
-!!     head              Type(nstio_head) input/output header information
-!!     iret              Integer(nstio_intkind) output return code
-!!     latb              Integer(nstio_intkind) optional latitudes
-!!     lsea             Integer(nstio_intkind) optional sea levels
-!!
-!!   nstio_aldata      Allocate data fields
-!!     head              Type(nstio_head) input header information
-!!     data              Type(nstio_data) output data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_axdata      Deallocate data fields
-!!     data              Type(nstio_data) output data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_srdata      Read data fields with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) input header information
-!!     data              Type(nstio_data) output data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_swdata      Write data fields with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) input header information
-!!     data              Type(nstio_data) input data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_srohdc      Open, read header & data and close with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     cfname            Character(*) input filename
-!!     head              Type(nstio_head) output header information
-!!     data              Type(nstio_data) output data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_swohdc      Open, write header & data and close with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     cfname            Character(*) input filename
-!!     head              Type(nstio_head) input header information
-!!     data              Type(nstio_data) input data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_aldbta      Allocate longreal data fields
-!!     head              Type(nstio_head) input header information
-!!     dbta              Type(nstio_dbta) output longreal data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_axdbta      Deallocate longreal data fields
-!!     dbta              Type(nstio_dbta) output longreal data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_srdbta      Read longreal data fields with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) input header information
-!!     dbta              Type(nstio_dbta) output longreal data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!!   nstio_swdbta      Write longreal data fields with sequential I/O
-!!     lu                Integer(nstio_intkind) input logical unit
-!!     head              Type(nstio_head) input header information
-!!     dbta              Type(nstio_dbta) input longreal data fields
-!!     iret              Integer(nstio_intkind) output return code
-!!
-!! Remarks:
-!!   (1) Here's the supported nst file formats.
-!!       For ivo=200907 
-!!         Label containing
-!!           'GFS ','NST ',ivo,nhead,ndata,reserved(3) (8 4-byte words)
-!!         Header records
-!!           lhead(nhead),ldata(ndata) (nhead+ndata 4-byte words)
-!!           fhour, idate(4), lonb, latb, lsea, irealf,
-!!             reserved(16)  (25 4-byte words)
-!!           lpl  (latb/2 4-byte words)
-!!           zsea  (lsea 4-byte words)
-!!         Data records
-!!           slmsk    (lonb*latb 4-byte words)
-!!           xt       (lonb*latb 4-byte words)
-!!           xs       (lonb*latb 4-byte words)
-!!           xu       (lonb*latb 4-byte words)
-!!           xv       (lonb*latb 4-byte words)
-!!           xz       (lonb*latb 4-byte words)
-!!           zm       (lonb*latb 4-byte words)
-!!           xtts     (lonb*latb 4-byte words)
-!!           xzts     (lonb*latb 4-byte words)
-!!           dt_cool  (lonb*latb 4-byte words)
-!!           z_c      (lonb*latb 4-byte words)
-!!           c_0      (lonb*latb 4-byte words)
-!!           c_d      (lonb*latb 4-byte words)
-!!           w_0      (lonb*latb 4-byte words)
-!!           w_d      (lonb*latb 4-byte words)
-!!           d_conv   (lonb*latb 4-byte words)
-!!           ifd      (lonb*latb 4-byte words)
-!!           Tref     (lonb*latb 4-byte words)
-!!           Qrain    (lonb*latb 4-byte words)
-!!
-!!   (2) Possible return codes:
-!!          0   Successful call
-!!         -1   Open or close I/O error
-!!         -2   Header record I/O error or unrecognized version
-!!         -3   Allocation or deallocation error
-!!         -4   Data record I/O error
-!!         -5   Insufficient data dimensions allocated
-!!
-!! Examples:
-!!   (1) Read the entire nst file 'nstf24' and
-!!       print out the northernmost nst temperature at greenwich.
-!!
-!!     use nstio_module
-!!     type(nstio_head):: head
-!!     type(nstio_data):: data
-!!     call nstio_srohdc(11,'nstf24',head,data,iret)
-!!     print '(f8.2)',data%tref(1,1)
-!!     end
-!!
-!! -module nstio_module - implicit none - private -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Variables - integer,parameter,public:: ngrids_nst=19 - integer,parameter,public:: nstio_lhead1=32 - integer,parameter,public:: nstio_intkind=4,nstio_realkind=4,nstio_dblekind=8 - real(nstio_realkind),parameter,public:: nstio_realfill=-9999. - real(nstio_dblekind),parameter,public:: nstio_dblefill=nstio_realfill -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Types - type,public:: nstio_head - character(nstio_lhead1):: clabnst=' ' - real(nstio_realkind):: fhour=0. - integer(nstio_intkind):: idate(4)=(/0,0,0,0/),latb=0,lonb=0,lsea=0,ivo=0 - integer(nstio_intkind):: irealf=1 - integer(nstio_intkind),allocatable:: lpl(:) - real(nstio_realkind),allocatable:: zsea(:) - end type - type,public:: nstio_data - real(nstio_realkind),pointer:: slmsk (:,:)=>null() - real(nstio_realkind),pointer:: xt (:,:)=>null() - real(nstio_realkind),pointer:: xs (:,:)=>null() - real(nstio_realkind),pointer:: xu (:,:)=>null() - real(nstio_realkind),pointer:: xv (:,:)=>null() - real(nstio_realkind),pointer:: xz (:,:)=>null() - real(nstio_realkind),pointer:: zm (:,:)=>null() - real(nstio_realkind),pointer:: xtts (:,:)=>null() - real(nstio_realkind),pointer:: xzts (:,:)=>null() - real(nstio_realkind),pointer:: dt_cool (:,:)=>null() - real(nstio_realkind),pointer:: z_c (:,:)=>null() - real(nstio_realkind),pointer:: c_0 (:,:)=>null() - real(nstio_realkind),pointer:: c_d (:,:)=>null() - real(nstio_realkind),pointer:: w_0 (:,:)=>null() - real(nstio_realkind),pointer:: w_d (:,:)=>null() - real(nstio_realkind),pointer:: d_conv (:,:)=>null() - real(nstio_realkind),pointer:: ifd (:,:)=>null() - real(nstio_realkind),pointer:: tref (:,:)=>null() - real(nstio_realkind),pointer:: Qrain (:,:)=>null() - end type - type,public:: nstio_dbta - real(nstio_dblekind),pointer:: slmsk (:,:)=>null() - real(nstio_dblekind),pointer:: xt (:,:)=>null() - real(nstio_dblekind),pointer:: xs (:,:)=>null() - real(nstio_dblekind),pointer:: xu (:,:)=>null() - real(nstio_dblekind),pointer:: xv (:,:)=>null() - real(nstio_dblekind),pointer:: xz (:,:)=>null() - real(nstio_dblekind),pointer:: zm (:,:)=>null() - real(nstio_dblekind),pointer:: xtts (:,:)=>null() - real(nstio_dblekind),pointer:: xzts (:,:)=>null() - real(nstio_dblekind),pointer:: dt_cool (:,:)=>null() - real(nstio_dblekind),pointer:: z_c (:,:)=>null() - real(nstio_dblekind),pointer:: c_0 (:,:)=>null() - real(nstio_dblekind),pointer:: c_d (:,:)=>null() - real(nstio_dblekind),pointer:: w_0 (:,:)=>null() - real(nstio_dblekind),pointer:: w_d (:,:)=>null() - real(nstio_dblekind),pointer:: d_conv (:,:)=>null() - real(nstio_dblekind),pointer:: ifd (:,:)=>null() - real(nstio_dblekind),pointer:: tref (:,:)=>null() - real(nstio_dblekind),pointer:: Qrain (:,:)=>null() - end type -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! Public Subprograms - public nstio_sropen,nstio_swopen,nstio_srclose,nstio_srhead,nstio_swhead - public nstio_alhead,nstio_aldata,nstio_axdata,nstio_srdata,nstio_swdata - public nstio_aldbta,nstio_axdbta,nstio_srdbta,nstio_swdbta - public nstio_srohdc,nstio_swohdc - interface nstio_srohdc - module procedure nstio_srohdca,nstio_srohdcb - end interface - interface nstio_swohdc - module procedure nstio_swohdca,nstio_swohdcb - end interface -contains -!------------------------------------------------------------------------------- - subroutine nstio_sropen(lu,cfname,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(nstio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='old',action='read',iostat=ios) -! write(*,*) ' successfully opened : ',cfname, ios - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swopen(lu,cfname,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - integer(nstio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - open(lu,file=cfname,form='unformatted',& - status='unknown',action='readwrite',iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srclose(lu,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - integer(nstio_intkind),intent(out):: iret - integer ios -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - close(lu,iostat=ios) - iret=ios - if(iret.ne.0) iret=-1 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srhead(lu,head,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(out):: head - integer(nstio_intkind),intent(out):: iret - integer:: ios - character(4):: cgfs,cnst - integer(nstio_intkind):: nhead,ndata,nresv(3) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - rewind lu - read(lu,iostat=ios) head%clabnst(1:8) -! write(*,*) ' head%clabnst done, ios : ',head%clabnst(1:8), ios - if(ios.ne.0) return - if(head%clabnst(1:8).eq.'GFS NST ') then ! modern nst file - rewind lu - read(lu,iostat=ios) cgfs,cnst,head%ivo,nhead,nresv -! write(*,*) ' cgfs,cnst done, ios : ',cgfs,cnst, ios,head%ivo,nhead - if(ios.ne.0) return - if(head%ivo.eq.200907) then - read(lu,iostat=ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsea,head%irealf -! write(*,*) ' head%fhour, ios : ',head%fhour, ios - if(ios.ne.0) return - call nstio_alhead(head,ios) - if(ios.ne.0) return - read(lu,iostat=ios) head%lpl - if(ios.ne.0) return - read(lu,iostat=ios) head%zsea - if(ios.ne.0) return - else - return - endif - endif - iret=0 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swhead(lu,head,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(in):: head - integer(nstio_intkind),intent(out):: iret - integer:: ios - integer i -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 - if(head%ivo.eq.200907) then - rewind lu - write(lu,iostat=ios) 'GFS NST ',head%ivo,ngrids_nst+4*head%lsea,0,0,0 - if(ios.ne.0) return - write(lu,iostat=ios) 4*(/8,ngrids_nst+4*head%lsea,25,head%latb/2,head%lsea/),& - 4*head%irealf*(/(head%lonb*head%latb,& - i=1,ngrids_nst+4*head%lsea)/) - if(ios.ne.0) return - write(lu,iostat=ios) head%fhour,head%idate,head%lonb,head%latb,& - head%lsea,head%irealf,(0,i=1,16) - if(ios.ne.0) return - write(lu,iostat=ios) head%lpl - if(ios.ne.0) return - write(lu,iostat=ios) head%zsea - if(ios.ne.0) return - iret=0 - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_alhead(head,iret,latb,lsea) - implicit none - type(nstio_head),intent(inout):: head - integer(nstio_intkind),intent(out):: iret - integer(nstio_intkind),optional,intent(in):: latb,lsea - integer dim1l,dim1z -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(present(latb)) then - dim1l=latb/2 - else - dim1l=head%latb/2 - endif - if(present(lsea)) then - dim1z=lsea - else - dim1z=head%lsea - endif - if(allocated(head%lpl)) deallocate(head%lpl) - if(allocated(head%zsea)) deallocate(head%zsea) - allocate(head%lpl(dim1l),head%zsea(dim1z),stat=iret) - if(iret.eq.0) then - head%lpl=0 - head%zsea=nstio_realfill - endif - if(iret.ne.0) then - iret=-3 -! write(*,*) ' fail to allocate nstio%head, iret = ',iret - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_aldata(head,data,iret) - implicit none - type(nstio_head),intent(in):: head - type(nstio_data),intent(inout):: data - integer(nstio_intkind),intent(out):: iret - integer dim1,dim2,dim3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_axdata(data,iret) - dim1=head%lonb - dim2=head%latb - dim3=head%lsea -! write(*,*) 'in nstio_aldata, dim1, dim2, dim3 : ', dim1, dim2, dim3 - allocate(& - data%slmsk(dim1,dim2),& - data%xt(dim1,dim2),& - data%xs(dim1,dim2),& - data%xu(dim1,dim2),& - data%xv(dim1,dim2),& - data%xz(dim1,dim2),& - data%zm(dim1,dim2),& - data%xtts(dim1,dim2),& - data%xzts(dim1,dim2),& - data%dt_cool(dim1,dim2),& - data%z_c(dim1,dim2),& - data%c_0(dim1,dim2),& - data%c_d(dim1,dim2),& - data%w_0(dim1,dim2),& - data%w_d(dim1,dim2),& - data%d_conv(dim1,dim2),& - data%ifd(dim1,dim2),& - data%tref(dim1,dim2),& - data%Qrain(dim1,dim2),& - stat=iret) - if(iret.ne.0) then - iret=-3 -! write(*,*) ' fail to allocate nstio%data, iret = ',iret - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_axdata(data,iret) - implicit none - type(nstio_data),intent(inout):: data - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(& - data%slmsk,& - data%xt,& - data%xs,& - data%xu,& - data%xv,& - data%xz,& - data%zm,& - data%xtts,& - data%xzts,& - data%dt_cool,& - data%z_c,& - data%c_0,& - data%c_d,& - data%w_0,& - data%w_d,& - data%d_conv,& - data%ifd,& - data%tref,& - data%Qrain,& - stat=iret) - nullify(& - data%slmsk,& - data%xt,& - data%xs,& - data%xu,& - data%xv,& - data%xz,& - data%zm,& - data%xtts,& - data%xzts,& - data%dt_cool,& - data%z_c,& - data%c_0,& - data%c_d,& - data%w_0,& - data%w_d,& - data%d_conv,& - data%ifd,& - data%tref,& - data%Qrain) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srdata(lu,head,data,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(in):: head - type(nstio_data),intent(inout):: data - integer(nstio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(nstio_dbta) dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsea - - mdim1=min(& - size(data%slmsk,1),& - size(data%xt,1),& - size(data%xs,1),& - size(data%xu,1),& - size(data%xv,1),& - size(data%xz,1),& - size(data%zm,1),& - size(data%xtts,1),& - size(data%xzts,1),& - size(data%dt_cool,1),& - size(data%z_c,1),& - size(data%c_0,1),& - size(data%c_d,1),& - size(data%w_0,1),& - size(data%w_d,1),& - size(data%d_conv,1),& - size(data%ifd,1),& - size(data%tref,1),& - size(data%Qrain,1)) - mdim2=min(& - size(data%slmsk,2),& - size(data%xt,2),& - size(data%xs,2),& - size(data%xu,2),& - size(data%xv,2),& - size(data%xz,2),& - size(data%zm,2),& - size(data%xtts,2),& - size(data%xzts,2),& - size(data%dt_cool,2),& - size(data%z_c,2),& - size(data%c_0,2),& - size(data%c_d,2),& - size(data%w_0,2),& - size(data%w_d,2),& - size(data%d_conv,2),& - size(data%ifd,2),& - size(data%tref,2),& - size(data%Qrain,2)) - mdim3=0 - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%ivo.eq.200907) then - if(head%irealf.ne.2) then - read(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xt(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xs(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xu(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xv(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xz(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%zm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xtts(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%xzts(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%dt_cool(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%z_c(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%c_0(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%c_d(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%w_0(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%w_d(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%d_conv(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%ifd(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%tref(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) data%Qrain(:dim1,:dim2) - if(ios.ne.0) return - else - call nstio_aldbta(head,dbta,iret) - if(iret.ne.0) return - call nstio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return - data%slmsk(:dim1,:dim2) = dbta%slmsk(:dim1,:dim2) - data%xt(:dim1,:dim2) = dbta%xt(:dim1,:dim2) - data%xs(:dim1,:dim2) = dbta%xs(:dim1,:dim2) - data%xu(:dim1,:dim2) = dbta%xu(:dim1,:dim2) - data%xv(:dim1,:dim2) = dbta%xv(:dim1,:dim2) - data%xz(:dim1,:dim2) = dbta%xz(:dim1,:dim2) - data%zm(:dim1,:dim2) = dbta%zm(:dim1,:dim2) - data%xtts(:dim1,:dim2) = dbta%xtts(:dim1,:dim2) - data%xzts(:dim1,:dim2) = dbta%xzts(:dim1,:dim2) - data%dt_cool(:dim1,:dim2) = dbta%dt_cool(:dim1,:dim2) - data%z_c(:dim1,:dim2) = dbta%z_c(:dim1,:dim2) - data%c_0(:dim1,:dim2) = dbta%c_0(:dim1,:dim2) - data%c_d(:dim1,:dim2) = dbta%c_d(:dim1,:dim2) - data%w_0(:dim1,:dim2) = dbta%w_0(:dim1,:dim2) - data%w_d(:dim1,:dim2) = dbta%w_d(:dim1,:dim2) - data%d_conv(:dim1,:dim2) = dbta%d_conv(:dim1,:dim2) - data%ifd(:dim1,:dim2) = dbta%ifd(:dim1,:dim2) - data%tref(:dim1,:dim2) = dbta%tref(:dim1,:dim2) - data%Qrain(:dim1,:dim2) = dbta%Qrain(:dim1,:dim2) - call nstio_axdbta(dbta,iret) - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swdata(lu,head,data,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(in):: head - type(nstio_data),intent(in):: data - integer(nstio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(nstio_dbta) dbta -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsea - mdim1=min(& - size(data%slmsk,1),& - size(data%xt,1),& - size(data%xs,1),& - size(data%xu,1),& - size(data%xv,1),& - size(data%xz,1),& - size(data%zm,1),& - size(data%xtts,1),& - size(data%xzts,1),& - size(data%dt_cool,1),& - size(data%z_c,1),& - size(data%c_0,1),& - size(data%c_d,1),& - size(data%w_0,1),& - size(data%w_d,1),& - size(data%d_conv,1),& - size(data%ifd,1),& - size(data%tref,1),& - size(data%Qrain,1)) - mdim2=min(& - size(data%slmsk,2),& - size(data%xt,2),& - size(data%xs,2),& - size(data%xu,2),& - size(data%xv,2),& - size(data%xz,2),& - size(data%zm,2),& - size(data%xtts,2),& - size(data%xzts,2),& - size(data%dt_cool,2),& - size(data%z_c,2),& - size(data%c_0,2),& - size(data%c_d,2),& - size(data%w_0,2),& - size(data%w_d,2),& - size(data%d_conv,2),& - size(data%ifd,2),& - size(data%tref,2)) - mdim3=0 - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%ivo.eq.200907) then - if(head%irealf.ne.2) then - write(lu,iostat=ios) data%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xt(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xs(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xu(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xv(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xz(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%zm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xtts(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%xzts(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%dt_cool(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%z_c(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%c_0(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%c_d(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%w_0(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%w_d(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%d_conv(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%ifd(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%tref(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) data%Qrain(:dim1,:dim2) - if(ios.ne.0) return - else - call nstio_aldbta(head,dbta,iret) - if(iret.ne.0) return - dbta%slmsk(:dim1,:dim2) = data%slmsk(:dim1,:dim2) - dbta%xt(:dim1,:dim2) = data%xt(:dim1,:dim2) - dbta%xs(:dim1,:dim2) = data%xs(:dim1,:dim2) - dbta%xu(:dim1,:dim2) = data%xu(:dim1,:dim2) - dbta%xv(:dim1,:dim2) = data%xv(:dim1,:dim2) - dbta%xz(:dim1,:dim2) = data%xz(:dim1,:dim2) - dbta%zm(:dim1,:dim2) = data%zm(:dim1,:dim2) - dbta%xtts(:dim1,:dim2) = data%xtts(:dim1,:dim2) - dbta%xzts(:dim1,:dim2) = data%xzts(:dim1,:dim2) - dbta%dt_cool(:dim1,:dim2) = data%dt_cool(:dim1,:dim2) - dbta%z_c(:dim1,:dim2) = data%z_c(:dim1,:dim2) - dbta%c_0(:dim1,:dim2) = data%c_0(:dim1,:dim2) - dbta%c_d(:dim1,:dim2) = data%c_d(:dim1,:dim2) - dbta%w_0(:dim1,:dim2) = data%w_0(:dim1,:dim2) - dbta%w_d(:dim1,:dim2) = data%w_d(:dim1,:dim2) - dbta%d_conv(:dim1,:dim2) = data%d_conv(:dim1,:dim2) - dbta%ifd(:dim1,:dim2) = data%ifd(:dim1,:dim2) - dbta%tref(:dim1,:dim2) = data%tref(:dim1,:dim2) - dbta%Qrain(:dim1,:dim2) = data%Qrain(:dim1,:dim2) - call nstio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return - call nstio_axdbta(dbta,iret) - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srohdca(lu,cfname,head,data,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(nstio_head),intent(inout):: head - type(nstio_data),intent(inout):: data - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_aldata(head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swohdca(lu,cfname,head,data,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(nstio_head),intent(in):: head - type(nstio_data),intent(in):: data - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swdata(lu,head,data,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_aldbta(head,dbta,iret) - implicit none - type(nstio_head),intent(in):: head - type(nstio_dbta),intent(inout):: dbta - integer(nstio_intkind),intent(out):: iret - integer dim1,dim2,dim3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_axdbta(dbta,iret) - dim1=head%lonb - dim2=head%latb - dim3=head%lsea - allocate(& - dbta%slmsk(dim1,dim2),& - dbta%xt(dim1,dim2),& - dbta%xs(dim1,dim2),& - dbta%xu(dim1,dim2),& - dbta%xv(dim1,dim2),& - dbta%xz(dim1,dim2),& - dbta%zm(dim1,dim2),& - dbta%xtts(dim1,dim2),& - dbta%xzts(dim1,dim2),& - dbta%dt_cool(dim1,dim2),& - dbta%z_c(dim1,dim2),& - dbta%c_0(dim1,dim2),& - dbta%c_d(dim1,dim2),& - dbta%w_0(dim1,dim2),& - dbta%w_d(dim1,dim2),& - dbta%d_conv(dim1,dim2),& - dbta%ifd(dim1,dim2),& - dbta%tref(dim1,dim2),& - dbta%Qrain(dim1,dim2),& - stat=iret) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_axdbta(dbta,iret) - implicit none - type(nstio_dbta),intent(inout):: dbta - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - deallocate(& - dbta%slmsk,& - dbta%xt,& - dbta%xs,& - dbta%xu,& - dbta%xv,& - dbta%xz,& - dbta%zm,& - dbta%xtts,& - dbta%xzts,& - dbta%dt_cool,& - dbta%z_c,& - dbta%c_0,& - dbta%c_d,& - dbta%w_0,& - dbta%w_d,& - dbta%d_conv,& - dbta%ifd,& - dbta%tref,& - dbta%Qrain,& - stat=iret) - nullify(& - dbta%slmsk,& - dbta%xt,& - dbta%xs,& - dbta%xu,& - dbta%xv,& - dbta%xz,& - dbta%zm,& - dbta%xtts,& - dbta%xzts,& - dbta%dt_cool,& - dbta%z_c,& - dbta%c_0,& - dbta%c_d,& - dbta%w_0,& - dbta%w_d,& - dbta%d_conv,& - dbta%ifd,& - dbta%tref) - if(iret.ne.0) iret=-3 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srdbta(lu,head,dbta,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(in):: head - type(nstio_dbta),intent(inout):: dbta - integer(nstio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(nstio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsea - mdim1=min(& - size(dbta%slmsk,1),& - size(dbta%xt,1),& - size(dbta%xs,1),& - size(dbta%xu,1),& - size(dbta%xv,1),& - size(dbta%xz,1),& - size(dbta%zm,1),& - size(dbta%xtts,1),& - size(dbta%xzts,1),& - size(dbta%dt_cool,1),& - size(dbta%z_c,1),& - size(dbta%c_0,1),& - size(dbta%c_d,1),& - size(dbta%w_0,1),& - size(dbta%w_d,1),& - size(dbta%d_conv,1),& - size(dbta%ifd,1),& - size(dbta%tref,1),& - size(dbta%Qrain,1)) - mdim2=min(& - size(dbta%slmsk,2),& - size(dbta%xt,2),& - size(dbta%xs,2),& - size(dbta%xu,2),& - size(dbta%xv,2),& - size(dbta%xz,2),& - size(dbta%zm,2),& - size(dbta%xtts,2),& - size(dbta%xzts,2),& - size(dbta%dt_cool,2),& - size(dbta%z_c,2),& - size(dbta%c_0,2),& - size(dbta%c_d,2),& - size(dbta%w_0,2),& - size(dbta%w_d,2),& - size(dbta%d_conv,2),& - size(dbta%ifd,2),& - size(dbta%tref,2),& - size(dbta%Qrain,2)) - mdim3=0 - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call nstio_aldata(head,data,iret) - if(iret.ne.0) return - call nstio_srdata(lu,head,data,iret) - if(iret.ne.0) return - dbta%slmsk(:dim1,:dim2) = data%slmsk(:dim1,:dim2) - dbta%xt(:dim1,:dim2) = data%xt(:dim1,:dim2) - dbta%xs(:dim1,:dim2) = data%xs(:dim1,:dim2) - dbta%xu(:dim1,:dim2) = data%xu(:dim1,:dim2) - dbta%xv(:dim1,:dim2) = data%xv(:dim1,:dim2) - dbta%xz(:dim1,:dim2) = data%xz(:dim1,:dim2) - dbta%zm(:dim1,:dim2) = data%zm(:dim1,:dim2) - dbta%xtts(:dim1,:dim2) = data%xtts(:dim1,:dim2) - dbta%xzts(:dim1,:dim2) = data%xzts(:dim1,:dim2) - dbta%dt_cool(:dim1,:dim2) = data%dt_cool(:dim1,:dim2) - dbta%z_c(:dim1,:dim2) = data%z_c(:dim1,:dim2) - dbta%c_0(:dim1,:dim2) = data%c_0(:dim1,:dim2) - dbta%c_d(:dim1,:dim2) = data%c_d(:dim1,:dim2) - dbta%w_0(:dim1,:dim2) = data%w_0(:dim1,:dim2) - dbta%w_d(:dim1,:dim2) = data%w_d(:dim1,:dim2) - dbta%d_conv(:dim1,:dim2) = data%d_conv(:dim1,:dim2) - dbta%ifd(:dim1,:dim2) = data%ifd(:dim1,:dim2) - dbta%tref(:dim1,:dim2) = data%tref(:dim1,:dim2) - dbta%Qrain(:dim1,:dim2) = data%Qrain(:dim1,:dim2) - call nstio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivo == 200907) then - read(lu,iostat=ios) dbta%slmsk(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xt(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xs(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xu(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xv(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xz(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%zm(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xtts(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%xzts(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%dt_cool(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%z_c(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%c_0(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%c_d(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%w_0(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%w_d(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%d_conv(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%ifd(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%tref(:dim1,:dim2) - if(ios.ne.0) return - read(lu,iostat=ios) dbta%Qrain(:dim1,:dim2) - if(ios.ne.0) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swdbta(lu,head,dbta,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - type(nstio_head),intent(in):: head - type(nstio_dbta),intent(in):: dbta - integer(nstio_intkind),intent(out):: iret - integer:: dim1,dim2,dim3,mdim1,mdim2,mdim3 - integer:: ios - integer i - type(nstio_data):: data -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1=head%lonb - dim2=head%latb - dim3=head%lsea - mdim1=min(& - size(dbta%slmsk,1),& - size(dbta%xt,1),& - size(dbta%xs,1),& - size(dbta%xu,1),& - size(dbta%xv,1),& - size(dbta%xz,1),& - size(dbta%zm,1),& - size(dbta%xtts,1),& - size(dbta%xzts,1),& - size(dbta%dt_cool,1),& - size(dbta%z_c,1),& - size(dbta%c_0,1),& - size(dbta%c_d,1),& - size(dbta%w_0,1),& - size(dbta%w_d,1),& - size(dbta%d_conv,1),& - size(dbta%ifd,1),& - size(dbta%tref,1),& - size(dbta%Qrain,1)) - mdim2=min(& - size(dbta%slmsk,2),& - size(dbta%xt,2),& - size(dbta%xs,2),& - size(dbta%xu,2),& - size(dbta%xv,2),& - size(dbta%xz,2),& - size(dbta%zm,2),& - size(dbta%xtts,2),& - size(dbta%xzts,2),& - size(dbta%dt_cool,2),& - size(dbta%z_c,2),& - size(dbta%c_0,2),& - size(dbta%c_d,2),& - size(dbta%w_0,2),& - size(dbta%w_d,2),& - size(dbta%d_conv,2),& - size(dbta%ifd,2),& - size(dbta%tref,2),& - size(dbta%Qrain,2)) - mdim3=0 - iret=-5 - if(mdim1.lt.dim1.or.& - mdim2.lt.dim2.or.& - mdim3.lt.dim3) return - iret=-4 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(head%irealf.ne.2) then - call nstio_aldata(head,data,iret) - if(iret.ne.0) return - data%slmsk(:dim1,:dim2) = dbta%slmsk(:dim1,:dim2) - data%xt(:dim1,:dim2) = dbta%xt(:dim1,:dim2) - data%xs(:dim1,:dim2) = dbta%xs(:dim1,:dim2) - data%xu(:dim1,:dim2) = dbta%xu(:dim1,:dim2) - data%xv(:dim1,:dim2) = dbta%xv(:dim1,:dim2) - data%xz(:dim1,:dim2) = dbta%xz(:dim1,:dim2) - data%zm(:dim1,:dim2) = dbta%zm(:dim1,:dim2) - data%xtts(:dim1,:dim2) = dbta%xtts(:dim1,:dim2) - data%xzts(:dim1,:dim2) = dbta%xzts(:dim1,:dim2) - data%dt_cool(:dim1,:dim2) = dbta%dt_cool(:dim1,:dim2) - data%z_c(:dim1,:dim2) = dbta%z_c(:dim1,:dim2) - data%c_0(:dim1,:dim2) = dbta%c_0(:dim1,:dim2) - data%c_d(:dim1,:dim2) = dbta%c_d(:dim1,:dim2) - data%w_0(:dim1,:dim2) = dbta%w_0(:dim1,:dim2) - data%w_d(:dim1,:dim2) = dbta%w_d(:dim1,:dim2) - data%d_conv(:dim1,:dim2) = dbta%d_conv(:dim1,:dim2) - data%ifd(:dim1,:dim2) = dbta%ifd(:dim1,:dim2) - data%tref(:dim1,:dim2) = dbta%tref(:dim1,:dim2) - data%Qrain(:dim1,:dim2) = dbta%Qrain(:dim1,:dim2) - call nstio_swdata(lu,head,data,iret) - if(iret.ne.0) return - call nstio_axdata(data,iret) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - elseif(head%ivo == 200907) then - write(lu,iostat=ios) dbta%slmsk(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xt(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xs(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xu(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xv(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xz(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%zm(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xtts(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%xzts(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%dt_cool(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%z_c(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%c_0(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%c_d(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%w_0(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%w_d(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%d_conv(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%ifd(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%tref(:dim1,:dim2) - if(ios.ne.0) return - write(lu,iostat=ios) dbta%Qrain(:dim1,:dim2) - if(ios.ne.0) return - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=0 - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_srohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(nstio_head),intent(inout):: head - type(nstio_dbta),intent(inout):: dbta - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_sropen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_aldbta(head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- - subroutine nstio_swohdcb(lu,cfname,head,dbta,iret) - implicit none - integer(nstio_intkind),intent(in):: lu - character*(*),intent(in):: cfname - type(nstio_head),intent(in):: head - type(nstio_dbta),intent(in):: dbta - integer(nstio_intkind),intent(out):: iret -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swopen(lu,cfname,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swhead(lu,head,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_swdbta(lu,head,dbta,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - call nstio_srclose(lu,iret) - if(iret.ne.0) return -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine -!------------------------------------------------------------------------------- -end module diff --git a/sorc/global_chgres.fd/num_parthds.f90 b/sorc/global_chgres.fd/num_parthds.f90 deleted file mode 100755 index ac28b0fea..000000000 --- a/sorc/global_chgres.fd/num_parthds.f90 +++ /dev/null @@ -1,13 +0,0 @@ -!> @file -INTEGER FUNCTION NUM_PARTHDS() - use omp_lib -!!$OMP PARALLEL -! num_parthds = omp_get_num_threads() - num_parthds = omp_get_max_threads() -! num_parthds = 6 -! num_parthds = 4 -!!$OMP END PARALLEL - - write(*,*)' NUM_PARTHDS=',num_parthds - return - END FUNCTION NUM_PARTHDS diff --git a/sorc/global_chgres.fd/physcons.f90 b/sorc/global_chgres.fd/physcons.f90 deleted file mode 100755 index 65d6396ea..000000000 --- a/sorc/global_chgres.fd/physcons.f90 +++ /dev/null @@ -1,92 +0,0 @@ -!> @file -!! this module contains some the most frequently used math and -!! physics constatns for gcm models. -!! -!! references: -!! as set in NMC handbook from Smithsonian tables. -!! -!! modification history: -!! - 1990-04-30 g and rd are made consistent with NWS usage -!! - 2001-10-22 g made consistent with SI usage -!! - 2005-04-13 added molicular weights for gases - y-t hou -!! -!! external modules referenced: -!! 'module machine' in 'machine.f' -!! - module physcons ! -!........................................! -! - use machine, only : kind_phys -! - implicit none -! - public - -! --- ... Math constants - - real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 ! pi - real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 ! square root of 2 - real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0 ! square root of 3 - -! --- ... Geophysics/Astronomy constants - - real(kind=kind_phys),parameter:: con_rerth =6.3712e+6 ! radius of earth (m) - real(kind=kind_phys),parameter:: con_g =9.80665e+0 ! gravity (m/s2) - real(kind=kind_phys),parameter:: con_omega =7.2921e-5 ! ang vel of earth (1/s) - real(kind=kind_phys),parameter:: con_p0 =1.01325e5 ! std atms pressure (pa) -! real(kind=kind_phys),parameter:: con_solr =1.36822e+3 ! solar constant (W/m2)-aer(2001) -! real(kind=kind_phys),parameter:: con_solr =1.3660e+3 ! solar constant (W/m2)-liu(2002) - real(kind=kind_phys),parameter:: con_solr =1.36742732e+3 ! solar constant (W/m2)-gfdl(1989) - OPR as of Jan 2006 - -! --- ... Thermodynamics constants - - real(kind=kind_phys),parameter:: con_rgas =8.314472 ! molar gas constant (J/mol/K) - real(kind=kind_phys),parameter:: con_rd =2.8705e+2 ! gas constant air (J/kg/K) - real(kind=kind_phys),parameter:: con_rv =4.6150e+2 ! gas constant H2O (J/kg/K) - real(kind=kind_phys),parameter:: con_cp =1.0046e+3 ! spec heat air @p (J/kg/K) - real(kind=kind_phys),parameter:: con_cv =7.1760e+2 ! spec heat air @v (J/kg/K) - real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 ! spec heat H2O gas (J/kg/K) - real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 ! spec heat H2O liq (J/kg/K) - real(kind=kind_phys),parameter:: con_csol =2.1060e+3 ! spec heat H2O ice (J/kg/K) - real(kind=kind_phys),parameter:: con_hvap =2.5000e+6 ! lat heat H2O cond (J/kg) - real(kind=kind_phys),parameter:: con_hfus =3.3358e+5 ! lat heat H2O fusion (J/kg) - real(kind=kind_phys),parameter:: con_psat =6.1078e+2 ! pres at H2O 3pt (Pa) - real(kind=kind_phys),parameter:: con_t0c =2.7315e+2 ! temp at 0C (K) - real(kind=kind_phys),parameter:: con_ttp =2.7316e+2 ! temp at H2O 3pt (K) - real(kind=kind_phys),parameter:: con_tice =2.7120e+2 ! temp freezing sea (K) - real(kind=kind_phys),parameter:: con_jcal =4.1855E+0 ! joules per calorie () - -! Secondary constants - - real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp - real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd - real(kind=kind_phys),parameter:: con_rog =con_rd/con_g - real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. - real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv - real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. - real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq - real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv - real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) - -! --- ... Other Physics/Chemistry constants - - real(kind=kind_phys),parameter:: con_plnk =6.6260693e-34 ! planck constatn (J/s) -nist(2002) - real(kind=kind_phys),parameter:: con_sbc =5.6730e-8 ! stefan-boltzmann (W/m2/K4) -! real(kind=kind_phys),parameter:: con_sbc =5.670400e-8 ! stefan-boltzmann (W/m2/K4) -nist(2002) -! real(kind=kind_phys),parameter:: con_avgd =6.02214e23 ! avogadro constant (1/mol) -aer - real(kind=kind_phys),parameter:: con_avgd =6.0221415e23 ! avogadro constant (1/mol) -nist(2002) - real(kind=kind_phys),parameter:: con_gasv =22413.996e-6 ! vol of ideal gas at 273.15k, 101.325kpa (m3/mol) -nist(2002) -! real(kind=kind_phys),parameter:: con_amd =28.970 ! molecular wght of dry air (g/mol) - real(kind=kind_phys),parameter:: con_amd =28.9644 ! molecular wght of dry air (g/mol) - real(kind=kind_phys),parameter:: con_amw =18.0154 ! molecular wght of water vapor (g/mol) - real(kind=kind_phys),parameter:: con_amo3 =47.9982 ! molecular wght of o3 (g/mol) -! real(kind=kind_phys),parameter:: con_amo3 =48.0 ! molecular wght of o3 (g/mol) - real(kind=kind_phys),parameter:: con_amco2 =44.011 ! molecular wght of co2 (g/mol) - real(kind=kind_phys),parameter:: con_amo2 =31.9999 ! molecular wght of o2 (g/mol) - real(kind=kind_phys),parameter:: con_amch4 =16.043 ! molecular wght of ch4 (g/mol) - real(kind=kind_phys),parameter:: con_amn2o =44.013 ! molecular wght of n2o (g/mol) - - -!........................................! - end module physcons ! -!========================================! diff --git a/sorc/global_chgres.fd/read_write.f90 b/sorc/global_chgres.fd/read_write.f90 deleted file mode 100644 index 847882c5b..000000000 --- a/sorc/global_chgres.fd/read_write.f90 +++ /dev/null @@ -1,4336 +0,0 @@ -!> @file -SUBROUTINE READ_FV3GFS_ATMS_DATA_NEMSIO(GFILEI, GFSDATAI, GFSHEADI, & - VCOORD, LEVSP1, NVCOORD) - - USE NEMSIO_MODULE - USE NEMSIO_GFS - - IMPLICIT NONE - - TYPE(NEMSIO_GFILE) :: GFILEI - TYPE(NEMSIO_DBTA) :: GFSDATAI - TYPE(NEMSIO_HEAD) :: GFSHEADI - - INTEGER, INTENT(IN) :: LEVSP1, NVCOORD - - REAL, INTENT(IN) :: VCOORD(LEVSP1, NVCOORD) - - INTEGER :: I, J, L, IRET - INTEGER :: LONB, LATB, LEVSI - - REAL, ALLOCATABLE :: TMP(:), P_INTERFACE(:) - - print*,'' - print*,'READ FV3GFS ATMOSPHERIC NEMSIO FILE' - - LONB = GFSHEADI%DIMX - LATB = GFSHEADI%DIMY - LEVSI = GFSHEADI%DIMZ - - ALLOCATE(TMP(LONB*LATB)) - - PRINT*,'READ HGT' - CALL NEMSIO_READRECV(GFILEI, 'hgt', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%ZS = RESHAPE(TMP,(/LONB,LATB/)) - - PRINT*,'READ U WINDS' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'ugrd', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%U(:,:,L) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ V WINDS' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'vgrd', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%V(:,:,L) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ T' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'tmp', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%T(:,:,L) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ Q' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'spfh', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,1) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ O3' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'o3mr', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,2) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ CLWMR' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'clwmr', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,3) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ RWMR' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'rwmr', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,4) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ ICMR' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'icmr', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,5) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ SNMR' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'snmr', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,6) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ GRLE' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'grle', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%Q(:,:,L,7) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ DZDT' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'dzdt', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%W(:,:,L) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - - PRINT*,'READ DPRES' - DO L = 1, LEVSI - CALL NEMSIO_READRECV(GFILEI, 'dpres', 'mid layer', L, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - GFSDATAI%DP(:,:,L) = RESHAPE(TMP,(/LONB,LATB/)) - ENDDO - -! COMPUTE SURFACE PRESSURE AND MID-LAYER PRESSURE FROM DELTA P. -! DO NOT USE THE SURFACE PRESSURE IN THE FILE. AFTER INTERPOLATION -! FROM THE MODEL GRID TO THE GAUSSIAN GRID IN THE WRITE COMPONENT, -! THE SURFACE PRESSURE IS NO LONGER CONSISTENT WITH DELTA P. - - ALLOCATE(P_INTERFACE(LEVSI+1)) - - DO J = 1, LATB - DO I = 1, LONB - P_INTERFACE(LEVSI+1) = VCOORD(LEVSI+1,1) ! MODEL TOP PRESSURE - DO L = LEVSI, 1, -1 - P_INTERFACE(L) = P_INTERFACE(L+1) + GFSDATAI%DP(I,J,L) - ENDDO - GFSDATAI%PS(I,J) = P_INTERFACE(1) ! SURFACE PRESSURE - DO L = 1, LEVSI - GFSDATAI%P(I,J,L) = (P_INTERFACE(L) + P_INTERFACE(L+1)) * 0.5 - ENDDO - ENDDO - ENDDO - - DEALLOCATE(P_INTERFACE) - - DEALLOCATE(TMP) - - RETURN - - 99 CONTINUE - PRINT*,'FATAL ERROR READING FV3GFS ATMOSPHERIC NEMSIO FILE.' - PRINT*,'IRET IS: ', IRET - CALL ERREXIT(22) - - END SUBROUTINE READ_FV3GFS_ATMS_DATA_NEMSIO - - SUBROUTINE WRITE_FV3_ATMS_HEADER_NETCDF(LEVS_P1, NTRACM, NVCOORD, VCOORD) - - use netcdf - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: LEVS_P1 - INTEGER, INTENT(IN) :: NTRACM - INTEGER, INTENT(IN) :: NVCOORD - - REAL, INTENT(IN) :: VCOORD(LEVS_P1, NVCOORD) - - CHARACTER(LEN=13) :: OUTFILE - - INTEGER :: ERROR, NCID - INTEGER :: DIM_NVCOORD, DIM_LEVSP - INTEGER :: ID_NTRAC, ID_VCOORD - INTEGER :: FSIZE=65536, INITAL = 0 - INTEGER :: HEADER_BUFFER_VAL = 16384 - - REAL(KIND=8) :: TMP(LEVS_P1,NVCOORD) - - OUTFILE = "./gfs_ctrl.nc" - - ERROR = NF90_CREATE(OUTFILE, IOR(NF90_NETCDF4,NF90_CLASSIC_MODEL), & - NCID, INITIALSIZE=INITAL, CHUNKSIZE=FSIZE) - CALL NETCDF_ERROR(ERROR, 'Creating file '//TRIM(OUTFILE) ) - - ERROR = NF90_DEF_DIM(NCID, 'nvcoord', NVCOORD, DIM_NVCOORD) - CALL NETCDF_ERROR(ERROR, 'define dimension nvcoord for file='//TRIM(OUTFILE) ) - - ERROR = NF90_DEF_DIM(NCID, 'levsp', LEVS_P1, DIM_LEVSP) - CALL NETCDF_ERROR(ERROR, 'define dimension levsp for file='//TRIM(OUTFILE) ) - - ERROR = NF90_DEF_VAR(NCID, 'ntrac', NF90_INT, ID_NTRAC) - CALL NETCDF_ERROR(ERROR, 'define var ntrac for file='//TRIM(OUTFILE) ) - - ERROR = NF90_DEF_VAR(NCID, 'vcoord', NF90_DOUBLE, (/DIM_LEVSP, DIM_NVCOORD/), ID_VCOORD) - CALL NETCDF_ERROR(ERROR, 'define var vcoord for file='//TRIM(OUTFILE) ) - - ERROR = NF90_ENDDEF(NCID, HEADER_BUFFER_VAL,4,0,4) - CALL NETCDF_ERROR(ERROR, 'end meta define for file='//TRIM(OUTFILE) ) - - ERROR = NF90_PUT_VAR( NCID, ID_NTRAC, NTRACM) - CALL NETCDF_ERROR(ERROR, 'write var ntrac for file='//TRIM(OUTFILE) ) - - TMP(1:LEVS_P1,:) = VCOORD(LEVS_P1:1:-1,:) - ERROR = NF90_PUT_VAR( NCID, ID_VCOORD, TMP) - CALL NETCDF_ERROR(ERROR, 'write var vcoord for file='//TRIM(OUTFILE) ) - - ERROR = NF90_CLOSE(NCID) - - END SUBROUTINE WRITE_FV3_ATMS_HEADER_NETCDF - - subroutine netcdf_error( err, string ) - use netcdf - implicit none - integer, intent(in) :: err - character(len=*), intent(in) :: string - character(len=256) :: errmsg - - if( err.EQ.NF90_NOERR )return - errmsg = NF90_STRERROR(err) - print*,'' - print*,'FATAL ERROR: ', trim(string), ': ', trim(errmsg) - print*,'STOP.' - call errexit(999) - - return - end subroutine netcdf_error - - subroutine write_fv3_sfc_data_netcdf(lonb, latb, lsoil, sfcoutput, f10m, & - t2m, q2m, uustar, ffmm, ffhh, tprcp, srflag, tile, & - num_nsst_fields, nsst_output) - - use netcdf - - use surface_chgres, only : sfc1d - - implicit none - - integer, intent(in) :: latb, lonb, lsoil, tile - integer, intent(in) :: num_nsst_fields - character(len=128) :: outfile - - integer :: fsize=65536, inital = 0 - integer :: header_buffer_val = 16384 - integer :: dim_lon, dim_lat, dim_lsoil - integer :: error, ncid, i - integer :: id_lon, id_lat, id_lsoil - integer :: id_geolon, id_geolat, id_slmsk - integer :: id_tsea, id_sheleg, id_tg3 - integer :: id_zorl, id_alvsf, id_alvwf - integer :: id_alnsf, id_alnwf, id_vfrac - integer :: id_canopy, id_f10m, id_t2m - integer :: id_q2m, id_vtype, id_stype - integer :: id_facsf, id_facwf, id_uustar - integer :: id_ffmm, id_ffhh, id_hice - integer :: id_fice, id_tisfc, id_tprcp - integer :: id_srflag, id_snwdph, id_shdmin - integer :: id_shdmax, id_slope, id_snoalb - integer :: id_stc, id_smc, id_slc - integer :: id_tref, id_z_c, id_c_0 - integer :: id_c_d, id_w_0, id_w_d - integer :: id_xt, id_xs, id_xu, id_xv - integer :: id_xz, id_zm, id_xtts, id_xzts - integer :: id_d_conv, id_ifd, id_dt_cool - integer :: id_qrain - - logical :: write_nsst - - real, intent(in) :: f10m(lonb,latb) - real, intent(in) :: q2m(lonb,latb) - real, intent(in) :: t2m(lonb,latb) - real, intent(in) :: uustar(lonb,latb) - real, intent(in) :: ffmm(lonb,latb) - real, intent(in) :: ffhh(lonb,latb) - real, intent(in) :: tprcp(lonb,latb) - real, intent(in) :: srflag(lonb,latb) - real, intent(in), optional :: nsst_output(lonb*latb,num_nsst_fields) - real(kind=4) :: lsoil_data(lsoil) - real(kind=4), allocatable :: dum2d(:,:), dum3d(:,:,:) - - type(sfc1d) :: sfcoutput - - write_nsst = .false. - if (present(nsst_output)) write_nsst = .true. - - if (write_nsst) then - print*,'- WRITE FV3 SURFACE AND NSST DATA TO NETCDF FILE' - else - print*,'- WRITE FV3 SURFACE DATA TO NETCDF FILE' - endif - - if (tile < 10) then - write(outfile, '(A, I1, A)') 'out.sfc.tile', tile, '.nc' - else - write(outfile, '(A, I2, A)') 'out.sfc.tile', tile, '.nc' - endif - -!--- open the file - error = nf90_create(outfile, ior(nf90_netcdf4,nf90_classic_model), & - ncid, initialsize=inital, chunksize=fsize) - call netcdf_error(error, 'CREATING FILE='//trim(outfile) ) - -!--- define dimension - error = nf90_def_dim(ncid, 'lon', lonb, dim_lon) - call netcdf_error(error, 'DEFINING LON DIMENSION' ) - error = nf90_def_dim(ncid, 'lat', latb, dim_lat) - call netcdf_error(error, 'DEFINING LAT DIMENSION' ) - error = nf90_def_dim(ncid, 'lsoil', lsoil, dim_lsoil) - call netcdf_error(error, 'DEFINING LSOIL DIMENSION' ) - - !--- define field - error = nf90_def_var(ncid, 'lon', NF90_FLOAT, (/dim_lon/), id_lon) - call netcdf_error(error, 'DEFINING LON FIELD' ) - error = nf90_put_att(ncid, id_lon, "cartesian_axis", "X") - call netcdf_error(error, 'WRITING LON FIELD' ) - error = nf90_def_var(ncid, 'lat', NF90_FLOAT, (/dim_lat/), id_lat) - call netcdf_error(error, 'DEFINING LAT FIELD' ) - error = nf90_put_att(ncid, id_lat, "cartesian_axis", "Y") - call netcdf_error(error, 'WRITING LAT FIELD' ) - error = nf90_def_var(ncid, 'lsoil', NF90_FLOAT, (/dim_lsoil/), id_lsoil) - call netcdf_error(error, 'DEFINING LSOIL FIELD' ) - error = nf90_put_att(ncid, id_lsoil, "cartesian_axis", "Z") - call netcdf_error(error, 'WRITING LSOIL FIELD' ) - error = nf90_def_var(ncid, 'geolon', NF90_FLOAT, (/dim_lon,dim_lat/), id_geolon) - call netcdf_error(error, 'DEFINING GEOLON' ) - error = nf90_def_var(ncid, 'geolat', NF90_FLOAT, (/dim_lon,dim_lat/), id_geolat) - call netcdf_error(error, 'DEFINING GEOLAT' ) - error = nf90_def_var(ncid, 'slmsk', NF90_FLOAT, (/dim_lon,dim_lat/), id_slmsk) - call netcdf_error(error, 'DEFINING SLMSK' ) - error = nf90_def_var(ncid, 'tsea', NF90_FLOAT, (/dim_lon,dim_lat/), id_tsea) - call netcdf_error(error, 'DEFINING TSEA' ) - error = nf90_def_var(ncid, 'sheleg', NF90_FLOAT, (/dim_lon,dim_lat/), id_sheleg) - call netcdf_error(error, 'DEFINING SHELEG' ) - error = nf90_def_var(ncid, 'tg3', NF90_FLOAT, (/dim_lon,dim_lat/), id_tg3) - call netcdf_error(error, 'DEFINING TG3' ) - error = nf90_def_var(ncid, 'zorl', NF90_FLOAT, (/dim_lon,dim_lat/), id_zorl) - call netcdf_error(error, 'DEFINING ZORL' ) - error = nf90_def_var(ncid, 'alvsf', NF90_FLOAT, (/dim_lon,dim_lat/), id_alvsf) - call netcdf_error(error, 'DEFINING ALVSF' ) - error = nf90_def_var(ncid, 'alvwf', NF90_FLOAT, (/dim_lon,dim_lat/), id_alvwf) - call netcdf_error(error, 'DEFINING ALVWF' ) - error = nf90_def_var(ncid, 'alnsf', NF90_FLOAT, (/dim_lon,dim_lat/), id_alnsf) - call netcdf_error(error, 'DEFINING ALNSF' ) - error = nf90_def_var(ncid, 'alnwf', NF90_FLOAT, (/dim_lon,dim_lat/), id_alnwf) - call netcdf_error(error, 'DEFINING ALNWF' ) - error = nf90_def_var(ncid, 'vfrac', NF90_FLOAT, (/dim_lon,dim_lat/), id_vfrac) - call netcdf_error(error, 'DEFINING VFRAC' ) - error = nf90_def_var(ncid, 'canopy', NF90_FLOAT, (/dim_lon,dim_lat/), id_canopy) - call netcdf_error(error, 'DEFINING CANOPY' ) - error = nf90_def_var(ncid, 'f10m', NF90_FLOAT, (/dim_lon,dim_lat/), id_f10m) - call netcdf_error(error, 'DEFINING F10M' ) - error = nf90_def_var(ncid, 't2m', NF90_FLOAT, (/dim_lon,dim_lat/), id_t2m) - call netcdf_error(error, 'DEFINING T2M' ) - error = nf90_def_var(ncid, 'q2m', NF90_FLOAT, (/dim_lon,dim_lat/), id_q2m) - call netcdf_error(error, 'DEFINING Q2M' ) - error = nf90_def_var(ncid, 'vtype', NF90_FLOAT, (/dim_lon,dim_lat/), id_vtype) - call netcdf_error(error, 'DEFINING VTYPE' ) - error = nf90_def_var(ncid, 'stype', NF90_FLOAT, (/dim_lon,dim_lat/), id_stype) - call netcdf_error(error, 'DEFINING STYPE' ) - error = nf90_def_var(ncid, 'facsf', NF90_FLOAT, (/dim_lon,dim_lat/), id_facsf) - call netcdf_error(error, 'DEFINING FACSF' ) - error = nf90_def_var(ncid, 'facwf', NF90_FLOAT, (/dim_lon,dim_lat/), id_facwf) - call netcdf_error(error, 'DEFINING FACWF' ) - error = nf90_def_var(ncid, 'uustar', NF90_FLOAT, (/dim_lon,dim_lat/), id_uustar) - call netcdf_error(error, 'DEFINING UUSTAR' ) - error = nf90_def_var(ncid, 'ffmm', NF90_FLOAT, (/dim_lon,dim_lat/), id_ffmm) - call netcdf_error(error, 'DEFINING FFMM' ) - error = nf90_def_var(ncid, 'ffhh', NF90_FLOAT, (/dim_lon,dim_lat/), id_ffhh) - call netcdf_error(error, 'DEFINING FFHH' ) - error = nf90_def_var(ncid, 'hice', NF90_FLOAT, (/dim_lon,dim_lat/), id_hice) - call netcdf_error(error, 'DEFINING HICE' ) - error = nf90_def_var(ncid, 'fice', NF90_FLOAT, (/dim_lon,dim_lat/), id_fice) - call netcdf_error(error, 'DEFINING FICE' ) - error = nf90_def_var(ncid, 'tisfc', NF90_FLOAT, (/dim_lon,dim_lat/), id_tisfc) - call netcdf_error(error, 'DEFINING TISFC' ) - error = nf90_def_var(ncid, 'tprcp', NF90_FLOAT, (/dim_lon,dim_lat/), id_tprcp) - call netcdf_error(error, 'DEFINING TPRCP' ) - error = nf90_def_var(ncid, 'srflag', NF90_FLOAT, (/dim_lon,dim_lat/), id_srflag) - call netcdf_error(error, 'DEFINING SRFLAG' ) - error = nf90_def_var(ncid, 'snwdph', NF90_FLOAT, (/dim_lon,dim_lat/), id_snwdph) - call netcdf_error(error, 'DEFINING SNWDPH' ) - error = nf90_def_var(ncid, 'shdmin', NF90_FLOAT, (/dim_lon,dim_lat/), id_shdmin) - call netcdf_error(error, 'DEFINING SHDMIN' ) - error = nf90_def_var(ncid, 'shdmax', NF90_FLOAT, (/dim_lon,dim_lat/), id_shdmax) - call netcdf_error(error, 'DEFINING SHDMAX' ) - error = nf90_def_var(ncid, 'slope', NF90_FLOAT, (/dim_lon,dim_lat/), id_slope) - call netcdf_error(error, 'DEFINING SLOPE' ) - error = nf90_def_var(ncid, 'snoalb', NF90_FLOAT, (/dim_lon,dim_lat/), id_snoalb) - call netcdf_error(error, 'DEFINING SNOALB' ) - error = nf90_def_var(ncid, 'stc', NF90_FLOAT, (/dim_lon,dim_lat,dim_lsoil/), id_stc) - call netcdf_error(error, 'DEFINING STC' ) - error = nf90_def_var(ncid, 'smc', NF90_FLOAT, (/dim_lon,dim_lat,dim_lsoil/), id_smc) - call netcdf_error(error, 'DEFINING SMC' ) - error = nf90_def_var(ncid, 'slc', NF90_FLOAT, (/dim_lon,dim_lat,dim_lsoil/), id_slc) - call netcdf_error(error, 'DEFINING SLC' ) - if (write_nsst) then - error = nf90_def_var(ncid, 'tref', NF90_FLOAT, (/dim_lon,dim_lat/), id_tref) - call netcdf_error(error, 'DEFINING TREF' ) - error = nf90_def_var(ncid, 'z_c', NF90_FLOAT, (/dim_lon,dim_lat/), id_z_c) - call netcdf_error(error, 'DEFINING Z_C' ) - error = nf90_def_var(ncid, 'c_0', NF90_FLOAT, (/dim_lon,dim_lat/), id_c_0) - call netcdf_error(error, 'DEFINING C_0' ) - error = nf90_def_var(ncid, 'c_d', NF90_FLOAT, (/dim_lon,dim_lat/), id_c_d) - call netcdf_error(error, 'DEFINING C_D' ) - error = nf90_def_var(ncid, 'w_0', NF90_FLOAT, (/dim_lon,dim_lat/), id_w_0) - call netcdf_error(error, 'DEFINING W_0' ) - error = nf90_def_var(ncid, 'w_d', NF90_FLOAT, (/dim_lon,dim_lat/), id_w_d) - call netcdf_error(error, 'DEFINING W_D' ) - error = nf90_def_var(ncid, 'xt', NF90_FLOAT, (/dim_lon,dim_lat/), id_xt) - call netcdf_error(error, 'DEFINING XT' ) - error = nf90_def_var(ncid, 'xs', NF90_FLOAT, (/dim_lon,dim_lat/), id_xs) - call netcdf_error(error, 'DEFINING XS' ) - error = nf90_def_var(ncid, 'xu', NF90_FLOAT, (/dim_lon,dim_lat/), id_xu) - call netcdf_error(error, 'DEFINING XU' ) - error = nf90_def_var(ncid, 'xv', NF90_FLOAT, (/dim_lon,dim_lat/), id_xv) - call netcdf_error(error, 'DEFINING XV' ) - error = nf90_def_var(ncid, 'xz', NF90_FLOAT, (/dim_lon,dim_lat/), id_xz) - call netcdf_error(error, 'DEFINING XZ' ) - error = nf90_def_var(ncid, 'zm', NF90_FLOAT, (/dim_lon,dim_lat/), id_zm) - call netcdf_error(error, 'DEFINING ZM' ) - error = nf90_def_var(ncid, 'xtts', NF90_FLOAT, (/dim_lon,dim_lat/), id_xtts) - call netcdf_error(error, 'DEFINING XTTS' ) - error = nf90_def_var(ncid, 'xzts', NF90_FLOAT, (/dim_lon,dim_lat/), id_xzts) - call netcdf_error(error, 'DEFINING XZTS' ) - error = nf90_def_var(ncid, 'd_conv', NF90_FLOAT, (/dim_lon,dim_lat/), id_d_conv) - call netcdf_error(error, 'DEFINING D_CONV' ) - error = nf90_def_var(ncid, 'ifd', NF90_FLOAT, (/dim_lon,dim_lat/), id_ifd) - call netcdf_error(error, 'DEFINING IFD' ) - error = nf90_def_var(ncid, 'dt_cool', NF90_FLOAT, (/dim_lon,dim_lat/), id_dt_cool) - call netcdf_error(error, 'DEFINING DT_COOL' ) - error = nf90_def_var(ncid, 'qrain', NF90_FLOAT, (/dim_lon,dim_lat/), id_qrain) - call netcdf_error(error, 'DEFINING QRAIN' ) - endif - - error = nf90_enddef(ncid, header_buffer_val, 4, 0, 4) - call netcdf_error(error, 'DEFINING HEADER' ) - - allocate(dum2d(lonb,latb)) - - dum2d = reshape(sfcoutput%lons, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_lon, dum2d(:,1)) - call netcdf_error(error, 'WRITING LON HEADER RECORD' ) - - dum2d = reshape(sfcoutput%lats, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_lat, dum2d(1,:)) - call netcdf_error(error, 'WRITING LAT HEADER RECORD' ) - - do i = 1, lsoil - lsoil_data(i) = float(i) - enddo - error = nf90_put_var( ncid, id_lsoil, lsoil_data) - call netcdf_error(error, 'WRITING LSOIL HEADER' ) - - dum2d = reshape(sfcoutput%lons, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_geolon, dum2d) - call netcdf_error(error, 'WRITING GEOLON RECORD' ) - - dum2d = reshape(sfcoutput%lats, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_geolat, dum2d) - call netcdf_error(error, 'WRITING GEOLAT RECORD' ) - - dum2d = reshape(sfcoutput%lsmask, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_slmsk, dum2d) - call netcdf_error(error, 'WRITING SLMSK RECORD' ) - - dum2d = reshape(sfcoutput%skin_temp, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_tsea, dum2d) - call netcdf_error(error, 'WRITING TSEA RECORD' ) - - dum2d = reshape(sfcoutput%snow_liq_equiv, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_sheleg, dum2d) - call netcdf_error(error, 'WRITING SHELEG RECORD' ) - - dum2d = reshape(sfcoutput%substrate_temp, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_tg3, dum2d) - call netcdf_error(error, 'WRITING TG3 RECORD' ) - - dum2d = reshape(sfcoutput%z0, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_zorl, dum2d) - call netcdf_error(error, 'WRITING ZORL RECORD' ) - - dum2d = reshape(sfcoutput%alvsf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_alvsf, dum2d) - call netcdf_error(error, 'WRITING ALVSF RECORD' ) - - dum2d = reshape(sfcoutput%alvwf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_alvwf, dum2d) - call netcdf_error(error, 'WRITING ALVWF RECORD' ) - - dum2d = reshape(sfcoutput%alnsf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_alnsf, dum2d) - call netcdf_error(error, 'WRITING ALNSF RECORD' ) - - dum2d = reshape(sfcoutput%alnwf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_alnwf, dum2d) - call netcdf_error(error, 'WRITING ALNWF RECORD' ) - - dum2d = reshape(sfcoutput%greenfrc, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_vfrac, dum2d) - call netcdf_error(error, 'WRITING VFRAC RECORD' ) - - dum2d = reshape(sfcoutput%canopy_mc, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_canopy, dum2d) - call netcdf_error(error, 'WRITING CANOPY RECORD' ) - - dum2d = f10m - error = nf90_put_var( ncid, id_f10m, dum2d) - call netcdf_error(error, 'WRITING F10M RECORD' ) - - dum2d = t2m - error = nf90_put_var( ncid, id_t2m, dum2d) - call netcdf_error(error, 'WRITING T2M RECORD' ) - - dum2d = q2m - error = nf90_put_var( ncid, id_q2m, dum2d) - call netcdf_error(error, 'WRITING Q2M RECORD' ) - - dum2d = reshape(float(sfcoutput%veg_type), (/lonb,latb/) ) - error = nf90_put_var( ncid, id_vtype, dum2d) - call netcdf_error(error, 'WRITING VTYPE RECORD' ) - - dum2d = reshape(float(sfcoutput%soil_type), (/lonb,latb/) ) - error = nf90_put_var( ncid, id_stype, dum2d) - call netcdf_error(error, 'WRITING STYPE RECORD' ) - - dum2d = reshape(sfcoutput%facsf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_facsf, dum2d) - call netcdf_error(error, 'WRITING FACSF RECORD' ) - - dum2d = reshape(sfcoutput%facwf, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_facwf, dum2d) - call netcdf_error(error, 'WRITING FACWF RECORD' ) - - dum2d = uustar - error = nf90_put_var( ncid, id_uustar, dum2d) - call netcdf_error(error, 'WRITING UUSTAR RECORD' ) - - dum2d = ffmm - error = nf90_put_var( ncid, id_ffmm, dum2d) - call netcdf_error(error, 'WRITING FFMM RECORD' ) - - dum2d = ffhh - error = nf90_put_var( ncid, id_ffhh, dum2d) - call netcdf_error(error, 'WRITING FFHH RECORD' ) - - dum2d = reshape(sfcoutput%sea_ice_depth, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_hice, dum2d) - call netcdf_error(error, 'WRITING HICE RECORD' ) - - dum2d = reshape(sfcoutput%sea_ice_fract, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_fice, dum2d) - call netcdf_error(error, 'WRITING FICE RECORD' ) - - dum2d = reshape(sfcoutput%sea_ice_temp, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_tisfc, dum2d) - call netcdf_error(error, 'WRITING TISFC RECORD' ) - - dum2d = tprcp - error = nf90_put_var( ncid, id_tprcp, dum2d) - call netcdf_error(error, 'WRITING TPRCP RECORD' ) - - dum2d = srflag - error = nf90_put_var( ncid, id_srflag, dum2d) - call netcdf_error(error, 'WRITING SRFLAG RECORD' ) - - dum2d = reshape(sfcoutput%snow_depth, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_snwdph, dum2d) - call netcdf_error(error, 'WRITING SNWDPH RECORD' ) - - dum2d = reshape(sfcoutput%greenfrc_min, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_shdmin, dum2d) - call netcdf_error(error, 'WRITING SHDMIN RECORD' ) - - dum2d = reshape(sfcoutput%greenfrc_max, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_shdmax, dum2d) - call netcdf_error(error, 'WRITING SHDMAX RECORD' ) - - dum2d = reshape(float(sfcoutput%slope_type), (/lonb,latb/) ) - error = nf90_put_var( ncid, id_slope, dum2d) - call netcdf_error(error, 'WRITING SLOPE RECORD' ) - - dum2d = reshape(sfcoutput%mxsnow_alb, (/lonb,latb/) ) - error = nf90_put_var( ncid, id_snoalb, dum2d) - call netcdf_error(error, 'WRITING SNOALB RECORD' ) - - deallocate (dum2d) - - allocate(dum3d(lonb,latb,lsoil)) - - dum3d = reshape(sfcoutput%soil_temp, (/lonb,latb,lsoil/) ) - error = nf90_put_var( ncid, id_stc, dum3d) - call netcdf_error(error, 'WRITING STC RECORD' ) - - dum3d = reshape(sfcoutput%soilm_tot, (/lonb,latb,lsoil/) ) - error = nf90_put_var( ncid, id_smc, dum3d) - call netcdf_error(error, 'WRITING SMC RECORD' ) - - dum3d = reshape(sfcoutput%soilm_liq, (/lonb,latb,lsoil/) ) - error = nf90_put_var( ncid, id_slc, dum3d) - call netcdf_error(error, 'WRITING SLC RECORD' ) - - deallocate (dum3d) - - if (write_nsst) then - - allocate(dum2d(lonb,latb)) - - dum2d = reshape(nsst_output(:,17), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_tref, dum2d) - call netcdf_error(error, 'WRITING TREF RECORD' ) - - dum2d = reshape(nsst_output(:,10), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_z_c, dum2d) - call netcdf_error(error, 'WRITING Z_C RECORD' ) - - dum2d = reshape(nsst_output(:,11), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_c_0, dum2d) - call netcdf_error(error, 'WRITING C_0 RECORD' ) - - dum2d = reshape(nsst_output(:,12), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_c_d, dum2d) - call netcdf_error(error, 'WRITING C_D RECORD' ) - - dum2d = reshape(nsst_output(:,13), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_w_0, dum2d) - call netcdf_error(error, 'WRITING W_0 RECORD' ) - - dum2d = reshape(nsst_output(:,14), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_w_d, dum2d) - call netcdf_error(error, 'WRITING W_D RECORD' ) - - dum2d = reshape(nsst_output(:,1), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xt, dum2d) - call netcdf_error(error, 'WRITING XT RECORD' ) - - dum2d = reshape(nsst_output(:,2), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xs, dum2d) - call netcdf_error(error, 'WRITING XS RECORD' ) - - dum2d = reshape(nsst_output(:,3), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xu, dum2d) - call netcdf_error(error, 'WRITING XU RECORD' ) - - dum2d = reshape(nsst_output(:,4), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xv, dum2d) - call netcdf_error(error, 'WRITING XV RECORD' ) - - dum2d = reshape(nsst_output(:,5), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xz, dum2d) - call netcdf_error(error, 'WRITING XZ RECORD' ) - - dum2d = reshape(nsst_output(:,6), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_zm, dum2d) - call netcdf_error(error, 'WRITING ZM RECORD' ) - - dum2d = reshape(nsst_output(:,7), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xtts, dum2d) - call netcdf_error(error, 'WRITING XTTS RECORD' ) - - dum2d = reshape(nsst_output(:,8), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_xzts, dum2d) - call netcdf_error(error, 'WRITING XZTS RECORD' ) - - dum2d = reshape(nsst_output(:,15), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_d_conv, dum2d) - call netcdf_error(error, 'WRITING D_CONV RECORD' ) - - dum2d = reshape(nsst_output(:,16), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_ifd, dum2d) - call netcdf_error(error, 'WRITING IFD RECORD' ) - - dum2d = reshape(nsst_output(:,9), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_dt_cool, dum2d) - call netcdf_error(error, 'WRITING DT_COOL RECORD' ) - - dum2d = reshape(nsst_output(:,18), (/lonb,latb/) ) - error = nf90_put_var(ncid, id_qrain, dum2d) - call netcdf_error(error, 'WRITING QRAIN RECORD' ) - - deallocate(dum2d) - - endif - - error = nf90_close(ncid) - - end subroutine write_fv3_sfc_data_netcdf - - SUBROUTINE READ_FV3_LATLON_NETCDF(TILE_NUM, IMO, JMO, GEOLON, GEOLAT) - - use netcdf - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: TILE_NUM, IMO, JMO - - REAL, INTENT(OUT) :: GEOLON(IMO,JMO), GEOLAT(IMO,JMO) - - CHARACTER(LEN=256) :: TILEFILE - - INTEGER :: ERROR, ID_DIM, NCID, NX, NY - INTEGER :: ID_VAR - - REAL, ALLOCATABLE :: TMPVAR(:,:) - - WRITE(TILEFILE, "(A,I1)") "chgres.fv3.grd.t", TILE_NUM - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERROR(ERROR, 'OPENING FILE: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_DIMID(NCID, 'nx', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NX) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX' ) - - ERROR=NF90_INQ_DIMID(NCID, 'ny', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NY) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY' ) - - IF ((NX/2) /= IMO .OR. (NY/2) /= JMO) THEN - PRINT*,'FATAL ERROR: DIMENSIONS IN GRID FILE WRONG.' - CALL ERREXIT(160) - ENDIF - - ALLOCATE(TMPVAR(NX,NY)) - - ERROR=NF90_INQ_VARID(NCID, 'x', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, TMPVAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X RECORD' ) - - GEOLON(1:IMO,1:JMO) = TMPVAR(2:NX:2,2:NY:2) - - ERROR=NF90_INQ_VARID(NCID, 'y', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, TMPVAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y RECORD' ) - - GEOLAT(1:IMO,1:JMO) = TMPVAR(2:NX:2,2:NY:2) - - DEALLOCATE(TMPVAR) - - ERROR = NF90_CLOSE(NCID) - - END SUBROUTINE READ_FV3_LATLON_NETCDF - - SUBROUTINE READ_FV3_GRID_DIMS_NETCDF(TILE_NUM,IMO,JMO) - - use netcdf - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: TILE_NUM - INTEGER, INTENT(OUT) :: IMO, JMO - - CHARACTER(LEN=256) :: TILEFILE - - INTEGER :: ERROR, NCID, ID_DIM - - IF (TILE_NUM < 10) THEN - WRITE(TILEFILE, "(A,I1)") "chgres.fv3.orog.t", TILE_NUM - ELSE - WRITE(TILEFILE, "(A,I2)") "chgres.fv3.orog.t", TILE_NUM - ENDIF - - PRINT*,'WILL READ GRID DIMENSIONS FROM: ', TRIM(TILEFILE) - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERROR(ERROR, 'OPENING: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_DIMID(NCID, 'lon', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'READING LON ID' ) - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=IMO) - CALL NETCDF_ERROR(ERROR, 'READING LON VALUE' ) - - PRINT*,'I-DIRECTION GRID DIM: ',IMO - - ERROR=NF90_INQ_DIMID(NCID, 'lat', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'READING LAT ID' ) - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=JMO) - CALL NETCDF_ERROR(ERROR, 'READING LAT VALUE' ) - - PRINT*,'J-DIRECTION GRID DIM: ',JMO - - ERROR = NF90_CLOSE(NCID) - - END SUBROUTINE READ_FV3_GRID_DIMS_NETCDF - - SUBROUTINE READ_FV3_GRID_DATA_NETCDF(FIELD,TILE_NUM,IMO,JMO,SFCDATA) - - use netcdf - - IMPLICIT NONE - - CHARACTER(LEN=*) :: FIELD - - INTEGER, INTENT(IN) :: IMO, JMO, TILE_NUM - - REAL, INTENT(OUT) :: SFCDATA(IMO,JMO) - - CHARACTER(LEN=256) :: TILEFILE - - INTEGER :: ERROR, NCID, LAT, LON, ID_DIM - INTEGER :: ID_VAR - - IF (TILE_NUM < 10) THEN - WRITE(TILEFILE, "(A,I1)") "chgres.fv3.orog.t", TILE_NUM - ELSE - WRITE(TILEFILE, "(A,I2)") "chgres.fv3.orog.t", TILE_NUM - ENDIF - - PRINT*,'WILL READ ',TRIM(FIELD), ' FROM: ', TRIM(TILEFILE) - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERROR(ERROR, 'OPENING: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_DIMID(NCID, 'lon', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'READING LON ID' ) - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=LON) - CALL NETCDF_ERROR(ERROR, 'READING LON VALUE' ) - - PRINT*,'LON IS ',LON - IF(LON/=IMO) THEN - PRINT*,'FATAL ERROR: I-DIMENSIONS DO NOT MATCH ',LON,IMO - CALL ERREXIT(101) - ENDIF - - ERROR=NF90_INQ_DIMID(NCID, 'lat', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'READING LAT ID' ) - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=LAT) - CALL NETCDF_ERROR(ERROR, 'READING LAT VALUE' ) - - PRINT*,'LAT IS ',LAT - IF(LAT/=JMO) THEN - PRINT*,'FATAL ERROR: J-DIMENSIONS DO NOT MATCH ',LAT,JMO - CALL ERREXIT(102) - ENDIF - - ERROR=NF90_INQ_VARID(NCID, FIELD, ID_VAR) - CALL NETCDF_ERROR(ERROR, 'READING FIELD ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, SFCDATA) - CALL NETCDF_ERROR(ERROR, 'READING FIELD' ) - - ERROR = NF90_CLOSE(NCID) - - END SUBROUTINE READ_FV3_GRID_DATA_NETCDF - - SUBROUTINE WRITE_FV3_ATMS_BNDY_NETCDF(ZS,PS,T,W,U,V,Q,VCOORD,LONB,LATB,& - LEVSO,NTRACM,NVCOORD,HALO,INPTYP, & - MODELNAME) - -!--------------------------------------------------------------------------- -! -! Output data along the four halo boundaries. The naming convention is -! based on point (1,1) being in the lower left corner of the grid: -! -! --------------- TOP --------------- -! | | -! | | -! LEFT | | RIGHT -! | | -! |PT(1,1) | -! ------------- BOTTOM -------------- -! -!--------------------------------------------------------------------------- - - use netcdf - - IMPLICIT NONE - - CHARACTER(LEN=8), INTENT(IN) :: MODELNAME - - INTEGER, INTENT(IN) :: LONB, LATB, LEVSO, NTRACM - INTEGER, INTENT(IN) :: NVCOORD, HALO, INPTYP - - REAL, INTENT(IN) :: PS(LONB,LATB), ZS(LONB,LATB) - REAL, INTENT(IN) :: T(LONB,LATB,LEVSO), W(LONB,LATB,LEVSO) - REAL, INTENT(IN) :: U(LONB,LATB,LEVSO), V(LONB,LATB,LEVSO) - REAL, INTENT(IN) :: Q(LONB,LATB,LEVSO,NTRACM) - REAL, INTENT(IN) :: VCOORD(LEVSO+1,NVCOORD) - - CHARACTER(LEN=256) :: OUTFILE, TILEFILE - - INTEGER :: I, II, J, JJ, IHALO, JHALO, K - INTEGER :: HALO_P1, IM, JM, JM2, ID_VAR - INTEGER :: ID_I_BOTTOM, ID_J_BOTTOM - INTEGER :: ID_I_TOP, ID_J_TOP - INTEGER :: ID_I_RIGHT, ID_J_RIGHT - INTEGER :: ID_I_LEFT, ID_J_LEFT - INTEGER :: ID_I_W_BOTTOM, ID_J_W_BOTTOM - INTEGER :: ID_I_W_TOP, ID_J_W_TOP - INTEGER :: ID_I_W_RIGHT, ID_J_W_RIGHT - INTEGER :: ID_I_W_LEFT, ID_J_W_LEFT - INTEGER :: ID_I_S_BOTTOM, ID_J_S_BOTTOM - INTEGER :: ID_I_S_TOP, ID_J_S_TOP - INTEGER :: ID_I_S_RIGHT, ID_J_S_RIGHT - INTEGER :: ID_I_S_LEFT, ID_J_S_LEFT - INTEGER :: ID_PS_TOP, ID_PS_BOTTOM - INTEGER :: ID_PS_RIGHT, ID_PS_LEFT - INTEGER :: ID_T_TOP, ID_T_BOTTOM - INTEGER :: ID_T_RIGHT, ID_T_LEFT - INTEGER :: ID_SPHUM_TOP, ID_SPHUM_BOTTOM - INTEGER :: ID_SPHUM_RIGHT, ID_SPHUM_LEFT - INTEGER :: ID_CLWMR_TOP, ID_CLWMR_BOTTOM - INTEGER :: ID_CLWMR_RIGHT, ID_CLWMR_LEFT - INTEGER :: ID_O3MR_TOP, ID_O3MR_BOTTOM - INTEGER :: ID_O3MR_RIGHT, ID_O3MR_LEFT - INTEGER :: ID_RWMR_TOP, ID_RWMR_BOTTOM - INTEGER :: ID_RWMR_RIGHT, ID_RWMR_LEFT - INTEGER :: ID_ICMR_TOP, ID_ICMR_BOTTOM - INTEGER :: ID_ICMR_RIGHT, ID_ICMR_LEFT - INTEGER :: ID_SNMR_TOP, ID_SNMR_BOTTOM - INTEGER :: ID_SNMR_RIGHT, ID_SNMR_LEFT - INTEGER :: ID_GRLE_TOP, ID_GRLE_BOTTOM - INTEGER :: ID_GRLE_RIGHT, ID_GRLE_LEFT - INTEGER :: ID_W_TOP, ID_W_BOTTOM - INTEGER :: ID_W_RIGHT, ID_W_LEFT - INTEGER :: ID_ZH_TOP, ID_ZH_BOTTOM - INTEGER :: ID_ZH_RIGHT, ID_ZH_LEFT - INTEGER :: ID_U_S_TOP, ID_U_S_BOTTOM - INTEGER :: ID_U_S_RIGHT, ID_U_S_LEFT - INTEGER :: ID_U_W_TOP, ID_U_W_BOTTOM - INTEGER :: ID_U_W_RIGHT, ID_U_W_LEFT - INTEGER :: ID_V_S_TOP, ID_V_S_BOTTOM - INTEGER :: ID_V_S_RIGHT, ID_V_S_LEFT - INTEGER :: ID_V_W_TOP, ID_V_W_BOTTOM - INTEGER :: ID_V_W_RIGHT, ID_V_W_LEFT - INTEGER :: ERROR, ID_DIM, NX, NY, NCID, NCID2 - INTEGER :: DIM_HALO, DIM_HALOP, DIM_LON, DIM_LAT - INTEGER :: DIM_LATM, DIM_LONP - INTEGER :: DIM_LEV, DIM_LEVP - INTEGER :: ISTART, IEND, JSTART, JEND - INTEGER :: LEVSO_P1 - INTEGER :: INITAL=0, FSIZE=65536 - INTEGER :: HEADER_BUFFER_VAL = 16384 - INTEGER, ALLOCATABLE :: IDUM(:) - - REAL, ALLOCATABLE :: GEOLAT(:,:), GEOLON(:,:) - REAL, ALLOCATABLE :: GEOLAT_HALO(:,:), GEOLON_HALO(:,:) - REAL, ALLOCATABLE :: HALO_2D(:,:), HALO_3D(:,:,:), HALO_3D2(:,:,:) - REAL, ALLOCATABLE :: AK(:), BK(:), ZH(:,:,:) - - REAL(KIND=4), ALLOCATABLE :: HALO_2D_4BYTE(:,:) - REAL(KIND=4), ALLOCATABLE :: HALO_3D_4BYTE(:,:,:) - - print*,'' - print*,'- COMPUTE AND OUTPUT LATERAL BOUNDARY DATA.' - - HALO_P1 = HALO + 1 - - LEVSO_P1 = LEVSO + 1 - - ALLOCATE(AK(LEVSO_P1)) - ALLOCATE(BK(LEVSO_P1)) - ALLOCATE(ZH(LONB,LATB,LEVSO_P1)) - - AK = VCOORD(:,1) - BK = VCOORD(:,2) - - CALL COMPUTE_ZH(LONB,LATB,LEVSO,AK,BK,PS,ZS,T,Q,ZH) - - DEALLOCATE(AK, BK) - -!---------------------------------------------------------------------------------- -! Read FV3 grid file. This routine only works for a regional domain -! and assumes that domain is tile number 7. -!---------------------------------------------------------------------------------- - - TILEFILE="chgres.fv3.grd.t7" - - PRINT*, "READ FV3 GRID INFO FROM: "//TRIM(TILEFILE) - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERROR(ERROR, 'OPENING FILE: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_DIMID(NCID, 'nx', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NX) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX' ) - - ERROR=NF90_INQ_DIMID(NCID, 'ny', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NY) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY' ) - - IF (MOD(NX,2) /= 0) THEN - PRINT*,'FATAL ERROR: NX IS NOT EVEN' - CALL ERREXIT(130) - ENDIF - - IF (MOD(NY,2) /= 0) THEN - PRINT*,'FATAL ERROR: NY IS NOT EVEN' - CALL ERREXIT(131) - ENDIF - - IM = NX/2 - JM = NY/2 - - ALLOCATE(GEOLON(NX+1,NY+1)) - ALLOCATE(GEOLAT(NX+1,NY+1)) - - ERROR=NF90_INQ_VARID(NCID, 'x', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, GEOLON) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X RECORD' ) - - ERROR=NF90_INQ_VARID(NCID, 'y', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, GEOLAT) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y RECORD' ) - - ERROR = NF90_CLOSE(NCID2) - -!---------------------------------------------------------------------------------- -! Create output file header. -!---------------------------------------------------------------------------------- - - WRITE(OUTFILE, '(A, I1, A)') 'gfs_bndy.tile', 7, '.nc' - ERROR = NF90_CREATE(OUTFILE, IOR(NF90_NETCDF4,NF90_CLASSIC_MODEL), & - NCID2, INITIALSIZE=INITAL, CHUNKSIZE=FSIZE) - CALL NETCDF_ERROR(ERROR, 'CREATING FILE: '//TRIM(OUTFILE) ) - - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'FV3GFS GAUSSIAN NEMSIO FILE') - ELSEIF (INPTYP == 1) THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'GFS NEMSIO FILE') - ELSEIF (INPTYP == 2) THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'GFS SIGIO FILE') - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING GLOBAL SOURCE ATTRIBUTE') - - ERROR = NF90_DEF_DIM(NCID2, 'lon', IM, DIM_LON) - CALL NETCDF_ERROR(ERROR, 'DEFINING LON DIMENSION') - - JM2 = JM - (2*HALO) - ERROR = NF90_DEF_DIM(NCID2, 'lat', JM2, DIM_LAT) - CALL NETCDF_ERROR(ERROR, 'DEFINING LAT DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'lonp', (IM+1), DIM_LONP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LONP DIMENSION') - - JM2 = (JM + 1) - (2*HALO_P1) - ERROR = NF90_DEF_DIM(NCID2, 'latm', JM2, DIM_LATM) - CALL NETCDF_ERROR(ERROR, 'DEFINING LATM DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'halo', HALO, DIM_HALO) - CALL NETCDF_ERROR(ERROR, 'DEFINING HALO DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'halop', HALO_P1, DIM_HALOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING HALOP DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'lev', LEVSO, DIM_LEV) - CALL NETCDF_ERROR(ERROR, 'DEFINING LEV DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'levp', LEVSO_P1, DIM_LEVP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LEVP DIMENSION') - - ERROR = NF90_DEF_VAR(NCID2, 'i_bottom', NF90_INT, & - (/DIM_LON/), ID_I_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_I_BOTTOM, "long_name", "i-indices bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_bottom', NF90_INT, & - (/DIM_HALO/), ID_J_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_J_BOTTOM, "long_name", "j-indices bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_top', NF90_INT, & - (/DIM_LON/), ID_I_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_I_TOP, "long_name", "i-indices top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_top', NF90_INT, & - (/DIM_HALO/), ID_J_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_J_TOP, "long_name", "j-indices top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_right', NF90_INT, & - (/DIM_HALO/), ID_I_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_RIGHT, "long_name", "i-indices right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_right', NF90_INT, & - (/DIM_LAT/), ID_J_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_RIGHT, "long_name", "j-indices right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_left', NF90_INT, & - (/DIM_HALO/), ID_I_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_LEFT, "long_name", "i-indices left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_left', NF90_INT, & - (/DIM_LAT/), ID_J_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_LEFT, "long_name", "j-indices left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'ps_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO/), ID_PS_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_BOTTOM, "long_name", "surface pressure bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_BOTTOM, "units", "Pa") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ps_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO/), ID_PS_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_TOP, "long_name", "surface pressure top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_TOP, "units", "Pa") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ps_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT/), ID_PS_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_RIGHT, "long_name", "surface pressure right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_RIGHT, "units", "Pa") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ps_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT/), ID_PS_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_LEFT, "long_name", "surface pressure left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_PS_LEFT, "units", "Pa") - CALL NETCDF_ERROR(ERROR, 'DEFINING PS_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'w_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_W_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING W_BOTTOM') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_BOTTOM, "long_name", "vertical velocity bottom bndy") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_BOTTOM, "long_name", "omega bottom bndy") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_BOTTOM ATTRIBUTE') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_BOTTOM, "units", "m/s") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_BOTTOM, "units", "Pa/s") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'w_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_W_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING W_TOP') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_TOP, "long_name", "vertical velocity top bndy") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_TOP, "long_name", "omega top bndy") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_TOP ATTRIBUTE') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_TOP, "units", "m/s") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_TOP, "units", "Pa/s") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'w_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_W_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING W_RIGHT') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_RIGHT, "long_name", "vertical velocity right bndy") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_RIGHT, "long_name", "omega right bndy") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_RIGHT ATTRIBUTE') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_RIGHT, "units", "m/s") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_RIGHT, "units", "Pa/s") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'w_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_W_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING W_LEFT') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_LEFT, "long_name", "vertical velocity left bndy") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_LEFT, "long_name", "omega left bndy") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_LEFT ATTRIBUTE') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W_LEFT, "units", "m/s") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W_LEFT, "units", "Pa/s") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'zh_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEVP/), ID_ZH_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_BOTTOM, "long_name", "height bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_BOTTOM, "units", "m") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'zh_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEVP/), ID_ZH_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_TOP, "long_name", "height top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_TOP, "units", "m") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'zh_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEVP/), ID_ZH_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_RIGHT, "long_name", "height right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_RIGHT, "units", "m") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'zh_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEVP/), ID_ZH_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_LEFT, "long_name", "height left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH_LEFT, "units", "m") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 't_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_T_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING T_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_T_BOTTOM, "long_name", "temperature bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_T_BOTTOM, "units", "kelvin") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 't_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_T_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING T_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_T_TOP, "long_name", "temperature top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_T_TOP, "units", "kelvin") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 't_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_T_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING T_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_T_RIGHT, "long_name", "temperature right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_T_RIGHT, "units", "kelvin") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 't_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_T_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING T_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_T_LEFT, "long_name", "temperature left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_T_LEFT, "units", "kelvin") - CALL NETCDF_ERROR(ERROR, 'DEFINING T_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'sphum_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_SPHUM_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_BOTTOM, "long_name", "specific humidity bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'sphum_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_SPHUM_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_TOP, "long_name", "specific humidity top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'sphum_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_SPHUM_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_RIGHT, "long_name", "specific humidity right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'sphum_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_SPHUM_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_LEFT, "long_name", "specific humidity left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'o3mr_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_O3MR_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_BOTTOM, "long_name", "ozone bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'o3mr_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_O3MR_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_TOP, "long_name", "ozone top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'o3mr_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_O3MR_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_RIGHT, "long_name", "ozone right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'o3mr_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_O3MR_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_LEFT, "long_name", "ozone left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'liq_wat_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_CLWMR_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING LIQ_WAT_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_BOTTOM, "long_name", "cloud liq water mixing ratio bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'liq_wat_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_CLWMR_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LIQ_WAT_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_TOP, "long_name", "cloud liq water mixing ratio top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'liq_wat_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_CLWMR_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING LIQ_WAT_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_RIGHT, "long_name", "cloud liq water mixing ratio right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'liq_wat_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_CLWMR_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING LIQ_WAT_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_LEFT, "long_name", "cloud liq water mixing ratio left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR_LEFT UNITS') - - IF (NTRACM > 3) THEN - - ERROR = NF90_DEF_VAR(NCID2, 'rainwat_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_RWMR_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_BOTTOM, "long_name", "rain water mixing ratio bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'rainwat_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_RWMR_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_TOP, "long_name", "rain water mixing ratio top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'rainwat_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_RWMR_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_RIGHT, "long_name", "rain water mixing ratio right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'rainwat_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_RWMR_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_LEFT, "long_name", "rain water mixing ratio left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ice_wat_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_ICMR_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_BOTTOM, "long_name", "ice water mixing ratio bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ice_wat_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_ICMR_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_TOP, "long_name", "ice water mixing ratio top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ice_wat_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_ICMR_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_RIGHT, "long_name", "ice water mixing ratio right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ice_wat_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_ICMR_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_LEFT, "long_name", "ice water mixing ratio left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'snowwat_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_SNMR_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_BOTTOM, "long_name", "snow water mixing ratio bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'snowwat_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_SNMR_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_TOP, "long_name", "snow water mixing ratio top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'snowwat_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_SNMR_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_RIGHT, "long_name", "snow water mixing ratio right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'snowwat_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_SNMR_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_LEFT, "long_name", "snow water mixing ratio left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'graupel_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_GRLE_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_BOTTOM, "long_name", "graupel mixing ratio bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_BOTTOM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'graupel_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALO, DIM_LEV/), ID_GRLE_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_TOP, "long_name", "graupel mixing ratio top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_TOP, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'graupel_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_GRLE_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_RIGHT, "long_name", "graupel mixing ratio right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_RIGHT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'graupel_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LAT, DIM_LEV/), ID_GRLE_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_LEFT, "long_name", "graupel mixing ratio left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE_LEFT, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE_LEFT UNITS') - - ENDIF - - ERROR = NF90_DEF_VAR(NCID2, 'i_w_bottom', NF90_INT, & - (/DIM_LONP/), ID_I_W_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_I_W_BOTTOM, "long_name", "i-indices west edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_w_bottom', NF90_INT, & - (/DIM_HALO/), ID_J_W_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_J_W_BOTTOM, "long_name", "j-indices west edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_w_top', NF90_INT, & - (/DIM_LONP/), ID_I_W_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_I_W_TOP, "long_name", "i-indices west edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_w_top', NF90_INT, & - (/DIM_HALO/), ID_J_W_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_J_W_TOP, "long_name", "j-indices west edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_w_right', NF90_INT, & - (/DIM_HALOP/), ID_I_W_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_W_RIGHT, "long_name", "i-indices west edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_w_right', NF90_INT, & - (/DIM_LAT/), ID_J_W_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_W_RIGHT, "long_name", "j-indices west edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_w_left', NF90_INT, & - (/DIM_HALOP/), ID_I_W_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_W_LEFT, "long_name", "i-indices west edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_W_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_w_left', NF90_INT, & - (/DIM_LAT/), ID_J_W_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_W_LEFT, "long_name", "j-indices west edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_W_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'u_w_bottom', NF90_FLOAT, & - (/DIM_LONP, DIM_HALO, DIM_LEV/), ID_U_W_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_BOTTOM, "long_name", "u-component wind west edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_BOTTOM, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_w_top', NF90_FLOAT, & - (/DIM_LONP, DIM_HALO, DIM_LEV/), ID_U_W_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_TOP, "long_name", "u-component wind west edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_TOP, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_w_right', NF90_FLOAT, & - (/DIM_HALOP, DIM_LAT, DIM_LEV/), ID_U_W_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_RIGHT, "long_name", "u-component wind west edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_RIGHT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_w_left', NF90_FLOAT, & - (/DIM_HALOP, DIM_LAT, DIM_LEV/), ID_U_W_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_LEFT, "long_name", "u-component wind west edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W_LEFT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_w_bottom', NF90_FLOAT, & - (/DIM_LONP, DIM_HALO, DIM_LEV/), ID_V_W_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_BOTTOM, "long_name", "v-component wind west edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_BOTTOM, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_w_top', NF90_FLOAT, & - (/DIM_LONP, DIM_HALO, DIM_LEV/), ID_V_W_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_TOP, "long_name", "v-component wind west edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_TOP, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_w_right', NF90_FLOAT, & - (/DIM_HALOP, DIM_LAT, DIM_LEV/), ID_V_W_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_RIGHT, "long_name", "v-component wind west edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_RIGHT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_w_left', NF90_FLOAT, & - (/DIM_HALOP, DIM_LAT, DIM_LEV/), ID_V_W_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_LEFT, "long_name", "v-component wind west edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W_LEFT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'i_s_bottom', NF90_INT, & - (/DIM_LON/), ID_I_S_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_I_S_BOTTOM, "long_name", "i-indices south edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_s_bottom', NF90_INT, & - (/DIM_HALOP/), ID_J_S_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_J_S_BOTTOM, "long_name", "j-indices south edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_BOTTOM ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_s_top', NF90_INT, & - (/DIM_LON/), ID_I_S_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_I_S_TOP, "long_name", "i-indices south edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_s_top', NF90_INT, & - (/DIM_HALOP/), ID_J_S_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_J_S_TOP, "long_name", "j-indices south edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_TOP ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_s_right', NF90_INT, & - (/DIM_HALO/), ID_I_S_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_S_RIGHT, "long_name", "i-indices south edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_s_right', NF90_INT, & - (/DIM_LATM/), ID_J_S_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_S_RIGHT, "long_name", "j-indices south edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_RIGHT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'i_s_left', NF90_INT, & - (/DIM_HALO/), ID_I_S_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_I_S_LEFT, "long_name", "i-indices south edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING I_S_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'j_s_left', NF90_INT, & - (/DIM_LATM/), ID_J_S_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_J_S_LEFT, "long_name", "j-indices south edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING J_S_LEFT ATTRIBUTE') - - ERROR = NF90_DEF_VAR(NCID2, 'u_s_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALOP, DIM_LEV/), ID_U_S_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_BOTTOM, "long_name", "u-component wind south edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_BOTTOM, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_s_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALOP, DIM_LEV/), ID_U_S_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_TOP, "long_name", "u-component wind south edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_TOP, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_s_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LATM, DIM_LEV/), ID_U_S_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_RIGHT, "long_name", "u-component wind south edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_RIGHT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_s_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LATM, DIM_LEV/), ID_U_S_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_LEFT, "long_name", "u-component wind south edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S_LEFT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S_LEFT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_s_bottom', NF90_FLOAT, & - (/DIM_LON, DIM_HALOP, DIM_LEV/), ID_V_S_BOTTOM) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_BOTTOM') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_BOTTOM, "long_name", "v-component wind south edge bottom bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_BOTTOM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_BOTTOM, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_BOTTOM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_s_top', NF90_FLOAT, & - (/DIM_LON, DIM_HALOP, DIM_LEV/), ID_V_S_TOP) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_TOP') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_TOP, "long_name", "v-component wind south edge top bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_TOP ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_TOP, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_TOP UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_s_right', NF90_FLOAT, & - (/DIM_HALO, DIM_LATM, DIM_LEV/), ID_V_S_RIGHT) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_RIGHT') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_RIGHT, "long_name", "v-component wind south edge right bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_RIGHT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_RIGHT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_RIGHT UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_s_left', NF90_FLOAT, & - (/DIM_HALO, DIM_LATM, DIM_LEV/), ID_V_S_LEFT) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_LEFT') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_LEFT, "long_name", "v-component wind south edge left bndy") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_LEFT ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S_LEFT, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S_LEFT UNITS') - - ERROR = NF90_ENDDEF(NCID2, HEADER_BUFFER_VAL, 4, 0, 4) - CALL NETCDF_ERROR(ERROR, 'DEFINING END OF HEADER') - -!---------------------------------------------------------------------------------- -! "Bottom" boundary. -!---------------------------------------------------------------------------------- - - ISTART = 1 - IEND = IM - JSTART = 1 - JEND = HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_2D(ISTART:IEND,JSTART:JEND)) - ALLOCATE(HALO_2D_4BYTE(ISTART:IEND,JSTART:JEND)) - - CALL GL2ANY(0, 1, PS, LONB, LATB, HALO_2D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - HALO_2D_4BYTE = REAL(HALO_2D,4) - - ERROR = NF90_PUT_VAR(NCID2, ID_PS_BOTTOM, HALO_2D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING PS_BOTTOM') - - DEALLOCATE(HALO_2D, HALO_2D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANY(0, LEVSO, Q(:,:,:,1), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SPHUM_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SPHUM_BOTTOM') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,2), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_O3MR_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING O3MR_BOTTOM') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,3), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_CLWMR_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING LIQ_WAT_BOTTOM') - - IF (NTRACM > 3) THEN - - CALL GL2ANY(0, LEVSO, Q(:,:,:,4), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_RWMR_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING RWMR_BOTTOM') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,5), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ICMR_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ICMR_BOTTOM') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,6), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SNMR_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SNMR_BOTTOM') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,7), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_GRLE_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING GRLE_BOTTOM') - - ENDIF - - CALL GL2ANY(0, LEVSO, T, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_T_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING T_BOTTOM') - - CALL GL2ANY(0, LEVSO, W, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_W_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING W_BOTTOM') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - - CALL GL2ANY(0, LEVSO_P1, ZH, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO_P1 - HALO_3D_4BYTE(:,:,LEVSO_P1-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ZH_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ZH_BOTTOM') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = IM+1 - JSTART = 1 - JEND = HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_W_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_W_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_W_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_W_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = (2*I)-1 - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_W_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_W_BOTTOM') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_W_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_W_BOTTOM') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = IM - JSTART = 1 - JEND = HALO + 1 - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_S_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_S_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_S_BOTTOM, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_S_BOTTOM') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_S_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_S_BOTTOM') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_S_BOTTOM, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_S_BOTTOM') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - -!---------------------------------------------------------------------------------- -! "Top" boundary. -!---------------------------------------------------------------------------------- - - ISTART = 1 - IEND = IM - JSTART = JM - HALO + 1 - JEND = JM - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_TOP') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_TOP') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_2D(ISTART:IEND,JSTART:JEND)) - ALLOCATE(HALO_2D_4BYTE(ISTART:IEND,JSTART:JEND)) - - CALL GL2ANY(0, 1, PS, LONB, LATB, HALO_2D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - HALO_2D_4BYTE = REAL(HALO_2D,4) - - ERROR = NF90_PUT_VAR(NCID2, ID_PS_TOP, HALO_2D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING PS_TOP') - - DEALLOCATE(HALO_2D, HALO_2D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANY(0, LEVSO, Q(:,:,:,1), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SPHUM_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SPHUM_TOP') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,2), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_O3MR_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING O3MR_TOP') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,3), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_CLWMR_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING CLWMR_TOP') - - IF (NTRACM > 3) THEN - - CALL GL2ANY(0, LEVSO, Q(:,:,:,4), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_RWMR_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING RWMR_TOP') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,5), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ICMR_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ICMR_TOP') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,6), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SNMR_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SNMR_TOP') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,7), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_GRLE_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING GRLE_TOP') - - ENDIF - - CALL GL2ANY(0, LEVSO, T, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_T_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING T_TOP') - - CALL GL2ANY(0, LEVSO, W, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_W_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING W_TOP') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - - CALL GL2ANY(0, LEVSO_P1, ZH, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO_P1 - HALO_3D_4BYTE(:,:,LEVSO_P1-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ZH_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ZH_TOP') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = IM+1 - JSTART = JM - HALO + 1 - JEND = JM - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_W_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_W_TOP') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_W_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_W_TOP') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = (2*I)-1 - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_W_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_W_TOP') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_W_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_W_TOP') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = IM - JSTART = JM - HALO + 1 - JEND = JM + 1 - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_S_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_S_TOP') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_S_TOP, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_S_TOP') - - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_S_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_S_TOP') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_S_TOP, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_S_TOP') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - -!---------------------------------------------------------------------------------- -! "Left" boundary. -!---------------------------------------------------------------------------------- - - ISTART = 1 - IEND = HALO - JSTART = HALO + 1 - JEND = JM - HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_2D(ISTART:IEND,JSTART:JEND)) - ALLOCATE(HALO_2D_4BYTE(ISTART:IEND,JSTART:JEND)) - - CALL GL2ANY(0, 1, PS, LONB, LATB, HALO_2D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - HALO_2D_4BYTE = REAL(HALO_2D,4) - - ERROR = NF90_PUT_VAR(NCID2, ID_PS_LEFT, HALO_2D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING PS_LEFT') - - DEALLOCATE(HALO_2D, HALO_2D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANY(0, LEVSO, Q(:,:,:,1), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SPHUM_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SPHUM_LEFT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,2), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_O3MR_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING O3MR_LEFT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,3), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_CLWMR_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING CLWMR_LEFT') - - IF (NTRACM > 3) THEN - - CALL GL2ANY(0, LEVSO, Q(:,:,:,4), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_RWMR_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING RWMR_LEFT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,5), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ICMR_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ICMR_LEFT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,6), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SNMR_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SNMR_LEFT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,7), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_GRLE_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING GRLE_LEFT') - - ENDIF - - CALL GL2ANY(0, LEVSO, T, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_T_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING T_LEFT') - - CALL GL2ANY(0, LEVSO, W, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_W_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING W_LEFT') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - - CALL GL2ANY(0, LEVSO_P1, ZH, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO_P1 - HALO_3D_4BYTE(:,:,LEVSO_P1-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ZH_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ZH_LEFT') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = HALO + 1 - JSTART = HALO + 1 - JEND = JM - HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_W_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_W_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_W_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_W_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = (2*I)-1 - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_W_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_W_LEFT') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_W_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_W_LEFT') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = 1 - IEND = HALO - JSTART = HALO_P1 + 1 - JEND = JM + 1 - HALO_P1 - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_S_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_S_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_S_LEFT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_S_LEFT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_S_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_S_LEFT') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_S_LEFT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_S_LEFT') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - -!---------------------------------------------------------------------------------- -! "Right" boundary. -!---------------------------------------------------------------------------------- - - ISTART = IM - HALO + 1 - IEND = IM - JSTART = HALO + 1 - JEND = JM - HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_2D(ISTART:IEND,JSTART:JEND)) - ALLOCATE(HALO_2D_4BYTE(ISTART:IEND,JSTART:JEND)) - - CALL GL2ANY(0, 1, PS, LONB, LATB, HALO_2D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - HALO_2D_4BYTE = REAL(HALO_2D,4) - - ERROR = NF90_PUT_VAR(NCID2, ID_PS_RIGHT, HALO_2D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING PS_RIGHT') - - DEALLOCATE(HALO_2D, HALO_2D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANY(0, LEVSO, Q(:,:,:,1), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SPHUM_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SPHUM_RIGHT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,2), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_O3MR_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING O3MR_RIGHT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,3), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_CLWMR_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING CLWMR_RIGHT') - - IF (NTRACM > 3) THEN - - CALL GL2ANY(0, LEVSO, Q(:,:,:,4), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_RWMR_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING RWMR_RIGHT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,5), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ICMR_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ICMR_RIGHT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,6), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SNMR_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SNMR_RIGHT') - - CALL GL2ANY(0, LEVSO, Q(:,:,:,7), LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_GRLE_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING GRLE_RIGHT') - - ENDIF - - CALL GL2ANY(0, LEVSO, T, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_T_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING T_RIGHT') - - CALL GL2ANY(0, LEVSO, W, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_W_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING W_RIGHT') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - - CALL GL2ANY(0, LEVSO_P1, ZH, LONB, LATB, HALO_3D, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - DO K = 1, LEVSO_P1 - HALO_3D_4BYTE(:,:,LEVSO_P1-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ZH_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ZH_RIGHT') - - DEALLOCATE(HALO_3D, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = IM - HALO + 1 - IEND = IM + 1 - JSTART = HALO + 1 - JEND = JM - HALO - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_W_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_W_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_W_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_W_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = (2*I)-1 - JJ = 2*J - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_W_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_W_RIGHT') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_W_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_W_RIGHT') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - - ISTART = IM - HALO + 1 - IEND = IM - JSTART = HALO_P1 + 1 - JEND = JM + 1 - HALO_P1 - - IHALO = IEND - ISTART + 1 - JHALO = JEND - JSTART + 1 - - ALLOCATE(IDUM(ISTART:IEND)) - DO I = ISTART, IEND - IDUM(I) = I - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_I_S_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING I_S_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(IDUM(JSTART:JEND)) - DO J = JSTART, JEND - IDUM(J) = J - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_J_S_RIGHT, IDUM) - CALL NETCDF_ERROR(ERROR, 'WRITING J_S_RIGHT') - DEALLOCATE(IDUM) - - ALLOCATE(GEOLAT_HALO(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_HALO(ISTART:IEND,JSTART:JEND)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLON_HALO(I,J) = GEOLON(II,JJ) - GEOLAT_HALO(I,J) = GEOLAT(II,JJ) - ENDDO - ENDDO - - ALLOCATE(HALO_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(HALO_3D2(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0, LEVSO, U, V, LONB, LATB, HALO_3D, HALO_3D2, IHALO, JHALO, GEOLON_HALO, GEOLAT_HALO) - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_S_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_S_RIGHT') - - DO K = 1, LEVSO - HALO_3D_4BYTE(:,:,LEVSO-K+1) = REAL(HALO_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_S_RIGHT, HALO_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_S_RIGHT') - - DEALLOCATE(HALO_3D, HALO_3D2, HALO_3D_4BYTE) - DEALLOCATE(GEOLAT_HALO, GEOLON_HALO) - -!---------------------------------------------------------------------------------- -! Cleanup and close file. -!---------------------------------------------------------------------------------- - - DEALLOCATE(GEOLAT) - DEALLOCATE(GEOLON) - - ERROR = NF90_CLOSE(NCID2) - - END SUBROUTINE WRITE_FV3_ATMS_BNDY_NETCDF - - SUBROUTINE WRITE_FV3_ATMS_NETCDF(ZS,PS,T,W,U,V,Q,VCOORD,LONB,LATB,& - LEVSO,NTRACM,NVCOORD,NTILES,HALO,& - INPTYP,MODELNAME) - - use netcdf - - IMPLICIT NONE - - CHARACTER(LEN=8), INTENT(IN) :: MODELNAME - - INTEGER, INTENT(IN) :: NTILES, LONB, LATB, LEVSO, NTRACM - INTEGER, INTENT(IN) :: NVCOORD, HALO, INPTYP - - REAL, INTENT(IN) :: PS(LONB,LATB), ZS(LONB,LATB) - REAL, INTENT(IN) :: T(LONB,LATB,LEVSO), W(LONB,LATB,LEVSO) - REAL, INTENT(IN) :: U(LONB,LATB,LEVSO), V(LONB,LATB,LEVSO) - REAL, INTENT(IN) :: Q(LONB,LATB,LEVSO,NTRACM) - REAL, INTENT(IN) :: VCOORD(LEVSO+1,NVCOORD) - - CHARACTER(LEN=256) :: TILEFILE, OUTFILE - - INTEGER :: ID_DIM, ID_VAR, IM, JM - INTEGER :: ERROR, N, NCID, NCID2, NX, NY - INTEGER :: INITAL=0, FSIZE=65536 - INTEGER :: HEADER_BUFFER_VAL = 16384 - INTEGER :: DIM_LON, DIM_LAT, DIM_LONP, DIM_LATP - INTEGER :: DIM_LEV, DIM_LEVP, DIM_TRACER - INTEGER :: ID_LON, ID_LAT, ID_PS, ID_T - INTEGER :: ID_W, ID_ZH, ID_SPHUM, ID_O3MR - INTEGER :: ID_CLWMR, ID_U_W, ID_V_W - INTEGER :: ID_RWMR, ID_ICMR, ID_SNMR, ID_GRLE - INTEGER :: ID_U_S, ID_V_S, K, LEVSO_P1 - INTEGER :: I, J, II, JJ - INTEGER :: ISTART, IEND, JSTART, JEND, IM_OUT, JM_OUT - INTEGER :: START_TILE, END_TILE - - REAL, ALLOCATABLE :: CUBE_2D(:,:), CUBE_3D(:,:,:), CUBE_3D2(:,:,:) - REAL, ALLOCATABLE :: AK(:), BK(:), ZH(:,:,:) - REAL, ALLOCATABLE :: GEOLAT(:,:), GEOLAT_W(:,:), GEOLAT_S(:,:) - REAL, ALLOCATABLE :: GEOLON(:,:), GEOLON_W(:,:) - REAL, ALLOCATABLE :: GEOLON_S(:,:), TMPVAR(:,:) - - REAL(KIND=4), ALLOCATABLE :: CUBE_2D_4BYTE(:,:) - REAL(KIND=4), ALLOCATABLE :: CUBE_3D_4BYTE(:,:,:) - - LEVSO_P1 = LEVSO + 1 - - CALL WRITE_FV3_ATMS_HEADER_NETCDF(LEVSO_P1, NTRACM, NVCOORD, VCOORD) - - ALLOCATE(AK(LEVSO_P1)) - ALLOCATE(BK(LEVSO_P1)) - ALLOCATE(ZH(LONB,LATB,(LEVSO_P1))) - - AK = VCOORD(:,1) - BK = VCOORD(:,2) - - CALL COMPUTE_ZH(LONB,LATB,LEVSO,AK,BK,PS,ZS,T,Q,ZH) - - DEALLOCATE(AK, BK) - - PRINT*,'' - - IF (HALO == 0) THEN ! NOT A REGIONAL GRID - START_TILE = 1 - END_TILE = NTILES - ELSE ! A REGIONAL GRID. ASSUME IT IS TILE 7. - START_TILE = 7 - END_TILE = 7 - ENDIF - - TILE_LOOP : DO N = START_TILE, END_TILE - - PRINT*,'WRITE FV3 ATMOSPHERIC DATA FOR TILE ',N - - IF (N < 10) THEN - WRITE(TILEFILE, "(A,I1)") "chgres.fv3.grd.t", N - ELSE - WRITE(TILEFILE, "(A,I2)") "chgres.fv3.grd.t", N - ENDIF - - ERROR=NF90_OPEN(TRIM(TILEFILE),NF90_NOWRITE,NCID) - CALL NETCDF_ERROR(ERROR, 'OPENING FILE: '//TRIM(TILEFILE) ) - - ERROR=NF90_INQ_DIMID(NCID, 'nx', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NX) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NX' ) - - ERROR=NF90_INQ_DIMID(NCID, 'ny', ID_DIM) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY ID' ) - - ERROR=NF90_INQUIRE_DIMENSION(NCID,ID_DIM,LEN=NY) - CALL NETCDF_ERROR(ERROR, 'ERROR READING NY' ) - - IF (MOD(NX,2) /= 0) THEN - PRINT*,'FATAL ERROR: NX IS NOT EVEN' - CALL ERREXIT(103) - ENDIF - - IF (MOD(NY,2) /= 0) THEN - PRINT*,'FATAL ERROR: NY IS NOT EVEN' - CALL ERREXIT(104) - ENDIF - - IM = NX/2 - JM = NY/2 - - IF (HALO > 0) THEN - ISTART = 1 + HALO - IEND = IM - HALO - JSTART = 1+ HALO - JEND = JM - HALO - PRINT*,'' - PRINT*,"WILL NOT PROCESS HALO REGION." - PRINT*,"HALO IS ", HALO, " ROWS/COLUMNS" - PRINT*,"WILL PROCESS I= ", ISTART, " TO ", IEND - PRINT*,"WILL PROCESS J= ", JSTART, " TO ", JEND - PRINT*,'' - ELSE - ISTART = 1 - IEND = IM - JSTART = 1 - JEND = JM - ENDIF - - IM_OUT = IEND - ISTART + 1 - JM_OUT = JEND - JSTART +1 - - PRINT*, "READ FV3 GRID INFO FROM: "//TRIM(TILEFILE) - - ALLOCATE(TMPVAR(NX+1,NY+1)) - ALLOCATE(GEOLON(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLON_W(ISTART:IEND+1,JSTART:JEND)) - ALLOCATE(GEOLON_S(ISTART:IEND,JSTART:JEND+1)) - - ERROR=NF90_INQ_VARID(NCID, 'x', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, TMPVAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING X RECORD' ) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLON(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - DO J = JSTART, JEND - DO I = ISTART, IEND+1 - II = (2*I) - 1 - JJ = 2*J - GEOLON_W(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - DO J = JSTART, JEND+1 - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLON_S(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - ERROR=NF90_INQ_VARID(NCID, 'y', ID_VAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y ID' ) - ERROR=NF90_GET_VAR(NCID, ID_VAR, TMPVAR) - CALL NETCDF_ERROR(ERROR, 'ERROR READING Y RECORD' ) - - ERROR = NF90_CLOSE(NCID) - - ALLOCATE(GEOLAT(ISTART:IEND,JSTART:JEND)) - ALLOCATE(GEOLAT_W(ISTART:IEND+1,JSTART:JEND)) - ALLOCATE(GEOLAT_S(ISTART:IEND,JSTART:JEND+1)) - - DO J = JSTART, JEND - DO I = ISTART, IEND - II = 2*I - JJ = 2*J - GEOLAT(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - DO J = JSTART, JEND - DO I = ISTART, IEND+1 - II = (2*I) - 1 - JJ = 2*J - GEOLAT_W(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - DO J = JSTART, JEND+1 - DO I = ISTART, IEND - II = 2*I - JJ = (2*J) - 1 - GEOLAT_S(I,J) = TMPVAR(II,JJ) - ENDDO - ENDDO - - DEALLOCATE(TMPVAR) - - IF (N < 10) THEN - WRITE(OUTFILE, "(A,I1,A)") 'gfs_data.tile', N, '.nc' - ELSE - WRITE(OUTFILE, "(A,I2,A)") 'gfs_data.tile', N, '.nc' - ENDIF - - ERROR = NF90_CREATE(OUTFILE, IOR(NF90_NETCDF4,NF90_CLASSIC_MODEL), & - NCID2, INITIALSIZE=INITAL, CHUNKSIZE=FSIZE) - CALL NETCDF_ERROR(ERROR, 'CREATING FILE: '//TRIM(OUTFILE) ) - - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'FV3GFS GAUSSIAN NEMSIO FILE') - ELSEIF (INPTYP == 1) THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'GFS NEMSIO FILE') - ELSEIF (INPTYP == 2) THEN - ERROR = NF90_PUT_ATT(NCID2, NF90_GLOBAL, 'source', 'GFS SIGIO FILE') - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING GLOBAL SOURCE ATTRIBUTE') - - ERROR = NF90_DEF_DIM(NCID2, 'lon', IM_OUT, DIM_LON) - CALL NETCDF_ERROR(ERROR, 'DEFINING LON DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'lat', JM_OUT, DIM_LAT) - CALL NETCDF_ERROR(ERROR, 'DEFINING LAT DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'lonp', (IM_OUT+1), DIM_LONP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LONP DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'latp', (JM_OUT+1), DIM_LATP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LATP DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'lev', LEVSO, DIM_LEV) - CALL NETCDF_ERROR(ERROR, 'DEFINING LEV DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'levp', LEVSO_P1, DIM_LEVP) - CALL NETCDF_ERROR(ERROR, 'DEFINING LEVP DIMENSION') - - ERROR = NF90_DEF_DIM(NCID2, 'ntracer', NTRACM, DIM_TRACER) - CALL NETCDF_ERROR(ERROR, 'DEFINING NTRACER DIMENSION') - - ERROR = NF90_DEF_VAR(NCID2, 'lon', NF90_FLOAT, DIM_LON, ID_LON) - CALL NETCDF_ERROR(ERROR, 'DEFINING LON VARIABLE') - - ERROR = NF90_PUT_ATT(NCID2, ID_LON, "cartesian_axis", "X") - CALL NETCDF_ERROR(ERROR, 'DEFINING X-AXIS') - - ERROR = NF90_DEF_VAR(NCID2, 'lat', NF90_FLOAT, DIM_LAT, ID_LAT) - CALL NETCDF_ERROR(ERROR, 'DEFINING LAT VARIABLE') - - ERROR = NF90_PUT_ATT(NCID2, ID_LAT, "cartesian_axis", "Y") - CALL NETCDF_ERROR(ERROR, 'DEFINING Y-AXIS') - - ERROR = NF90_DEF_VAR(NCID2, 'ps', NF90_FLOAT, & - (/DIM_LON, DIM_LAT/), ID_PS) - CALL NETCDF_ERROR(ERROR, 'DEFINING PS') - ERROR = NF90_PUT_ATT(NCID2, ID_PS, "long_name", "surface pressure") - CALL NETCDF_ERROR(ERROR, 'DEFINING PRESSURE ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_PS, "units", "Pa") - CALL NETCDF_ERROR(ERROR, 'DEFINING PRESSURE UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'w', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_W) - CALL NETCDF_ERROR(ERROR, 'DEFINING W') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W, "long_name", "vertical velocity") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W, "long_name", "omega") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W ATTRIBUTE') - IF (TRIM(MODELNAME) == "FV3GFS") THEN - ERROR = NF90_PUT_ATT(NCID2, ID_W, "units", "m/s") - ELSE - ERROR = NF90_PUT_ATT(NCID2, ID_W, "units", "Pa/s") - ENDIF - CALL NETCDF_ERROR(ERROR, 'DEFINING W UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'zh', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEVP/), ID_ZH) - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH, "long_name", "height") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ZH, "units", "m") - CALL NETCDF_ERROR(ERROR, 'DEFINING ZH UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 't', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_T) - CALL NETCDF_ERROR(ERROR, 'DEFINING t') - ERROR = NF90_PUT_ATT(NCID2, ID_T, "long_name", "temperature") - CALL NETCDF_ERROR(ERROR, 'DEFINING T ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_T, "units", "kelvin") - CALL NETCDF_ERROR(ERROR, 'DEFINING T UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'sphum', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_SPHUM) - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM, "long_name", "specific humidity") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SPHUM, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SPHUM UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'o3mr', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_O3MR) - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR, "long_name", "ozone") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_O3MR, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING O3MR UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'liq_wat', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_CLWMR) - CALL NETCDF_ERROR(ERROR, 'DEFINING LIQ_WAT') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR, "long_name", "cloud liquid water mixing ratio") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_CLWMR, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING CLWMR UNITS') - - IF (NTRACM > 3) THEN - - ERROR = NF90_DEF_VAR(NCID2, 'rainwat', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_RWMR) - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR, "long_name", "rain water mixing ratio") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_RWMR, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING RWMR UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'ice_wat', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_ICMR) - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR, "long_name", "ice water mixing ratio") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_ICMR, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING ICMR UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'snowwat', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_SNMR) - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR, "long_name", "snow water mixing ratio") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_SNMR, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING SNMR UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'graupel', NF90_FLOAT, & - (/DIM_LON, DIM_LAT, DIM_LEV/), ID_GRLE) - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE, "long_name", "graupel mixing ratio") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_GRLE, "units", "kg/kg") - CALL NETCDF_ERROR(ERROR, 'DEFINING GRLE UNITS') - - ENDIF - - ERROR = NF90_DEF_VAR(NCID2, 'u_w', NF90_FLOAT, & - (/DIM_LONP, DIM_LAT, DIM_LEV/), ID_U_W) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W, "long_name", "u-component wind on d grid") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_W, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_W UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_w', NF90_FLOAT, & - (/DIM_LONP, DIM_LAT, DIM_LEV/), ID_V_W) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W, "long_name", "v-component wind on c grid") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_W, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_W UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'u_s', NF90_FLOAT, & - (/DIM_LON, DIM_LATP, DIM_LEV/), ID_U_S) - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S, "long_name", "u-component wind on c grid") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_U_S, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING U_S UNITS') - - ERROR = NF90_DEF_VAR(NCID2, 'v_s', NF90_FLOAT, & - (/DIM_LON, DIM_LATP, DIM_LEV/), ID_V_S) - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S, "long_name", "v-component wind on d grid") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S ATTRIBUTE') - ERROR = NF90_PUT_ATT(NCID2, ID_V_S, "units", "m/s") - CALL NETCDF_ERROR(ERROR, 'DEFINING V_S UNITS') - - ERROR = NF90_ENDDEF(NCID2, HEADER_BUFFER_VAL, 4, 0, 4) - CALL NETCDF_ERROR(ERROR, 'DEFINING END OF HEADER') - -!------------------------------------------------------------------ -! Write out data. fv3 convention: lowest model level is levso. -! top model layer is 1. this is opposite the gfs convention. -!------------------------------------------------------------------ - - ALLOCATE(CUBE_2D(ISTART:IEND,JSTART:JEND), CUBE_2D_4BYTE(ISTART:IEND,JSTART:JEND)) - - CUBE_2D_4BYTE = REAL(GEOLON,4) - ERROR = NF90_PUT_VAR(NCID2, ID_LON, CUBE_2D_4BYTE(:,JSTART)) - CALL NETCDF_ERROR(ERROR, 'WRITING LON') - - CUBE_2D_4BYTE = REAL(GEOLAT,4) - ERROR = NF90_PUT_VAR(NCID2, ID_LAT, CUBE_2D_4BYTE(ISTART,:)) - CALL NETCDF_ERROR(ERROR, 'WRITING LAT') - - CALL GL2ANY(0,1,PS,LONB,LATB,CUBE_2D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - CUBE_2D_4BYTE = REAL(CUBE_2D,4) - - ERROR = NF90_PUT_VAR(NCID2, ID_PS, CUBE_2D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING PS') - - DEALLOCATE(CUBE_2D_4BYTE, CUBE_2D) - - ALLOCATE(CUBE_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - ALLOCATE(CUBE_3D(ISTART:IEND,JSTART:JEND,LEVSO_P1)) - - CALL GL2ANY(0,LEVSO_P1,ZH,LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO_P1 - CUBE_3D_4BYTE(:,:,LEVSO_P1-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ZH, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ZH') - - DEALLOCATE(CUBE_3D, CUBE_3D_4BYTE) - - ALLOCATE(CUBE_3D_4BYTE(ISTART:IEND,JSTART:JEND,LEVSO)) - ALLOCATE(CUBE_3D(ISTART:IEND,JSTART:JEND,LEVSO)) - - CALL GL2ANY(0,LEVSO,W,LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_W, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING W') - - CALL GL2ANY(0,LEVSO,T,LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON,GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_T, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING T') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,1),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SPHUM, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SPHUM') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,2),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_O3MR, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING O3MR') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,3),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_CLWMR, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING CLWMR') - - IF (NTRACM > 3) THEN - - CALL GL2ANY(0,LEVSO,Q(:,:,:,4),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_RWMR, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING RWMR') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,5),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_ICMR, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING ICMR') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,6),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_SNMR, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING SNMR') - - CALL GL2ANY(0,LEVSO,Q(:,:,:,7),LONB,LATB,CUBE_3D,IM_OUT,JM_OUT,GEOLON, GEOLAT) - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_GRLE, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING GRLE') - - ENDIF - - DEALLOCATE (CUBE_3D, CUBE_3D_4BYTE) - - ALLOCATE(CUBE_3D_4BYTE(ISTART:IEND+1,JSTART:JEND,LEVSO)) - ALLOCATE(CUBE_3D(ISTART:IEND+1,JSTART:JEND,LEVSO)) - ALLOCATE(CUBE_3D2(ISTART:IEND+1,JSTART:JEND,LEVSO)) - - CALL GL2ANYV(0,LEVSO,U,V,LONB,LATB,CUBE_3D,CUBE_3D2,(IM_OUT+1),JM_OUT,GEOLON_W, GEOLAT_W) - - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_W, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_W') - - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_W, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_W') - - DEALLOCATE (CUBE_3D, CUBE_3D2, CUBE_3D_4BYTE) - - ALLOCATE(CUBE_3D_4BYTE(ISTART:IEND,JSTART:JEND+1,LEVSO)) - ALLOCATE(CUBE_3D(ISTART:IEND,JSTART:JEND+1,LEVSO)) - ALLOCATE(CUBE_3D2(ISTART:IEND,JSTART:JEND+1,LEVSO)) - - CALL GL2ANYV(0,LEVSO,U,V,LONB,LATB,CUBE_3D,CUBE_3D2,IM_OUT,(JM_OUT+1),GEOLON_S, GEOLAT_S) - - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_U_S, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING U_S') - - DO K = 1, LEVSO - CUBE_3D_4BYTE(:,:,LEVSO-K+1) = REAL(CUBE_3D2(:,:,K),4) - ENDDO - - ERROR = NF90_PUT_VAR(NCID2, ID_V_S, CUBE_3D_4BYTE) - CALL NETCDF_ERROR(ERROR, 'WRITING V_S') - - ERROR = NF90_CLOSE(NCID2) - - DEALLOCATE(CUBE_3D, CUBE_3D2, CUBE_3D_4BYTE) - DEALLOCATE(GEOLON, GEOLON_W, GEOLON_S) - DEALLOCATE(GEOLAT, GEOLAT_W, GEOLAT_S) - - ENDDO TILE_LOOP - - DEALLOCATE(ZH) - - END SUBROUTINE WRITE_FV3_ATMS_NETCDF - - SUBROUTINE READ_GFS_NSST_DATA_NSTIO(IMI,JMI,NUM_NSST_FIELDS, & - NSST_INPUT, MASK_INPUT, & - NSST_YEAR, NSST_MON, & - NSST_DAY, NSST_HOUR, & - NSST_FHOUR) - - USE NSTIO_MODULE - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IMI, JMI, NUM_NSST_FIELDS - INTEGER, INTENT(OUT) :: NSST_YEAR, NSST_MON - INTEGER, INTENT(OUT) :: NSST_DAY, NSST_HOUR - - REAL, INTENT(OUT) :: NSST_FHOUR - REAL, INTENT(OUT) :: MASK_INPUT(IMI,JMI) - REAL, INTENT(OUT) :: NSST_INPUT(IMI,JMI,NUM_NSST_FIELDS) - - INTEGER(NSTIO_INTKIND) :: NSSTI, IRET - - TYPE(NSTIO_HEAD) :: NSST_IN_HEAD - TYPE(NSTIO_DATA) :: NSST_IN_DATA - - PRINT*,'- READ NSST FILE chgres.inp.nst.' -! OPEN NSST FILES - NSSTI=31 - CALL NSTIO_SROPEN(NSSTI,'chgres.inp.nst',IRET) - IF(IRET/=0)THEN - PRINT*,'FATAL ERROR OPENING chgres.inp.nst ', IRET - CALL ERREXIT(105) - ENDIF - CALL NSTIO_SRHEAD(NSSTI,NSST_IN_HEAD,IRET) - IF(IRET/=0)THEN - PRINT*,'FATAL ERROR READING chgres.inp.nst ', IRET - CALL ERREXIT(106) - ENDIF - CALL NSTIO_ALDATA(NSST_IN_HEAD,NSST_IN_DATA,IRET) - CALL NSTIO_SRDATA(NSSTI,NSST_IN_HEAD,NSST_IN_DATA,IRET) - IF(IRET/=0)THEN - PRINT*,'FATAL ERROR READING chgres.inp.nst ', IRET - CALL ERREXIT(107) - ENDIF - NSST_YEAR=NSST_IN_HEAD%IDATE(4) - NSST_MON=NSST_IN_HEAD%IDATE(2) - NSST_DAY=NSST_IN_HEAD%IDATE(3) - NSST_HOUR=NSST_IN_HEAD%IDATE(1) - NSST_FHOUR=NSST_IN_HEAD%FHOUR - NSST_INPUT(:,:,1)=NSST_IN_DATA%XT - NSST_INPUT(:,:,2)=NSST_IN_DATA%XS - NSST_INPUT(:,:,3)=NSST_IN_DATA%XU - NSST_INPUT(:,:,4)=NSST_IN_DATA%XV - NSST_INPUT(:,:,5)=NSST_IN_DATA%XZ - NSST_INPUT(:,:,6)=NSST_IN_DATA%ZM - NSST_INPUT(:,:,7)=NSST_IN_DATA%XTTS - NSST_INPUT(:,:,8)=NSST_IN_DATA%XZTS - NSST_INPUT(:,:,9)=NSST_IN_DATA%DT_COOL - NSST_INPUT(:,:,10)=NSST_IN_DATA%Z_C - NSST_INPUT(:,:,11)=NSST_IN_DATA%C_0 - NSST_INPUT(:,:,12)=NSST_IN_DATA%C_D - NSST_INPUT(:,:,13)=NSST_IN_DATA%W_0 - NSST_INPUT(:,:,14)=NSST_IN_DATA%W_D - NSST_INPUT(:,:,15)=NSST_IN_DATA%D_CONV - NSST_INPUT(:,:,16)=NSST_IN_DATA%IFD - NSST_INPUT(:,:,17)=NSST_IN_DATA%TREF - NSST_INPUT(:,:,18)=NSST_IN_DATA%QRAIN - MASK_INPUT=NSST_IN_DATA%SLMSK - CALL NSTIO_AXDATA(NSST_IN_DATA,IRET) - CALL NSTIO_SRCLOSE(NSSTI,IRET) - - END SUBROUTINE READ_GFS_NSST_DATA_NSTIO - - SUBROUTINE READ_FV3GFS_NSST_DATA_NEMSIO (MASK_INPUT,NSST_INPUT,IMI,JMI, & - NUM_NSST_FIELDS,NSST_YEAR,NSST_MON,NSST_DAY, & - NSST_HOUR,NSST_FHOUR) - -!----------------------------------------------------------------------- -! Subroutine: read nsst data from a fv3gfs nemsio file -! -! Author: George Gayno/EMC -! -! Abstract: Reads an fv3gfs nsst file in nemsio format. Places data -! in the "nsst_input" array in the order expected by routine -! nsst_chgres. -! -! Input files: -! "chgres.inp.sfc" - input nsst nemsio file. note: fv3gfs sfc -! and nsst fields are in the same file. -! -! Output files: none -! -! History: -! 2018-05-31 Gayno - Initial version -! -! Condition codes: all non-zero codes are fatal -! 109 - bad open of nst file "chgres.inp.sfc" -! 110 - bad read of "chgres.inp.sfc" header -! 112 - wrong number of nsst records -! 113 - bad read of landmask record. -! 114 - bad read of an nst file record. -!----------------------------------------------------------------------- - - use nemsio_module - - implicit none - - integer, parameter :: nrec=18 - - character(len=3) :: levtyp - character(len=8) :: recname(nrec) - - integer, intent(in) :: imi, jmi, num_nsst_fields - integer, intent(out) :: nsst_year, nsst_mon - integer, intent(out) :: nsst_day, nsst_hour - - real, intent(out) :: mask_input(imi,jmi) - real, intent(out) :: nsst_input(imi,jmi,num_nsst_fields) - real, intent(out) :: nsst_fhour - - integer(nemsio_intkind) :: iret, lev, nframe - integer(nemsio_intkind) :: idate(7), nfhour - - integer :: j - - real(nemsio_realkind),allocatable :: dummy(:) - - type(nemsio_gfile) :: gfile - - data recname /"xt ", "xs ", "xu ", & - "xv ", "xz ", "zm ", & - "xtts ", "xzts ", "dtcool ", & - "zc ", "c0 ", "cd ", & - "w0 ", "wd ", "dconv ", & - "ifd ", "tref ", "qrain " / - - print*,"- READ INPUT NSST DATA IN NEMSIO FORMAT" - - if (nrec /= num_nsst_fields) then - print*,"- FATAL ERROR: bad number of nsst records." - call errexit(112) - endif - -! note: fv3gfs surface and nsst fields are in a single file. - - call nemsio_open(gfile, "chgres.inp.sfc", "read", iret=iret) - if (iret /= 0) then - print*,"- FATAL ERROR: bad open of chgres.inp.sfc." - print*,"- IRET IS ", iret - call errexit(109) - endif - - print*,"- READ FILE HEADER" - call nemsio_getfilehead(gfile,iret=iret, & - idate=idate,nfhour=nfhour) - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of chgres.inp.sfc header." - print*,"- IRET IS ", iret - call errexit(110) - endif - - nsst_year=idate(1) - nsst_mon=idate(2) - nsst_day=idate(3) - nsst_hour=idate(4) - nsst_fhour=float(nfhour) - - levtyp='sfc' - lev=1 - nframe=0 - - allocate(dummy(imi*jmi)) - -!----------------------------------------------------------------------- -! Read land mask into its own variable -!----------------------------------------------------------------------- - - call nemsio_readrecv(gfile,"land",levtyp,lev, & - dummy,nframe,iret) - - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of landmask record." - print*,"- IRET IS ", iret - call errexit(113) - endif - - mask_input = reshape (dummy, (/imi,jmi/)) - -!----------------------------------------------------------------------- -! Read remaining records into nsst_input data structure. -! Note: fv3gfs files do not contain 'ifd' or 'zm' records. Set -! to default values per recommendation of nsst developer. -!----------------------------------------------------------------------- - - print*,"- READ DATA RECORDS" - - do j = 1, nrec - if (trim(recname(j)) == 'zm') then - nsst_input(:,:,j) = 0.0 - cycle - endif - if (trim(recname(j)) == 'ifd') then - nsst_input(:,:,j) = 1.0 - cycle - endif - call nemsio_readrecv(gfile,recname(j),levtyp,lev, & - dummy,nframe,iret) - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of chgres.inp.sfc." - print*,"- IRET IS ", iret - call errexit(114) - endif - nsst_input(:,:,j) = reshape (dummy, (/imi,jmi/)) - enddo - - deallocate(dummy) - - call nemsio_close(gfile,iret=iret) - - END SUBROUTINE READ_FV3GFS_NSST_DATA_NEMSIO - - SUBROUTINE READ_GFS_NSST_DATA_NEMSIO (MASK_INPUT,NSST_INPUT,IMI,JMI, & - NUM_NSST_FIELDS,NSST_YEAR,NSST_MON,NSST_DAY, & - NSST_HOUR,NSST_FHOUR) - -!----------------------------------------------------------------------- -! Subroutine: read nsst data from a gfs nemsio file -! -! Author: George Gayno/EMC -! -! Abstract: Reads an nsst file in nemsio format. Places data -! in the "nsst_input" array as expected by routine -! nsst_chgres. -! -! Input files: -! "chgres.inp.nst" - input nsst nemsio file -! -! Output files: none -! -! History: -! 2016-04-05 Gayno - Initial version -! -! Condition codes: all non-zero codes are fatal -! 109 - bad open of nst file "chgres.inp.nst" -! 110 - bad read of "chgres.inp.nst" header -! 111 - the program assumes that the resolution of the -! nst grid matches the input surface grid. if -! they are not the same, stop procoessing. -! 112 - the nst file does not have the 19 required records. -! 113 - bad read of landmask record. -! 114 - bad read of an nst file record. -!----------------------------------------------------------------------- - - use nemsio_module - - implicit none - - character(len=3) :: levtyp - character(len=8) :: recname(19) - - integer, intent(in) :: imi, jmi, num_nsst_fields - integer, intent(out) :: nsst_year, nsst_mon - integer, intent(out) :: nsst_day, nsst_hour - - real, intent(out) :: mask_input(imi,jmi) - real, intent(out) :: nsst_input(imi,jmi,num_nsst_fields) - real, intent(out) :: nsst_fhour - - integer(nemsio_intkind) :: iret, nrec, dimx, dimy, lev, nframe - integer(nemsio_intkind) :: idate(7), nfhour - - integer :: j - - real(nemsio_realkind),allocatable :: dummy(:) - - type(nemsio_gfile) :: gfile - - data recname /"land ", "xt ", "xs ", & - "xu ", "xv ", "xz ", & - "zm ", "xtts ", "xzts ", & - "dtcool ", "zc ", "c0 ", & - "cd ", "w0 ", "wd ", & - "dconv ", "ifd ", "tref ", & - "qrain " / - - print*,"- READ INPUT NSST DATA IN NEMSIO FORMAT" - - call nemsio_open(gfile, "chgres.inp.nst", "read", iret=iret) - if (iret /= 0) then - print*,"- FATAL ERROR: bad open of chgres.inp.nst." - print*,"- IRET IS ", iret - call errexit(109) - endif - - print*,"- READ FILE HEADER" - call nemsio_getfilehead(gfile,iret=iret,nrec=nrec,dimx=dimx, & - dimy=dimy,idate=idate,nfhour=nfhour) - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of chgres.inp.nst header." - print*,"- IRET IS ", iret - call errexit(110) - endif - - if (dimx /= imi .or. dimy /= jmi) then - print*,"- FATAL ERROR: nst and sfc file resolution" - print*,"- must be the same." - call errexit(111) - endif - - if (nrec /= 19) then - print*,"- FATAL ERROR: nst file has wrong number of records." - call errexit(112) - endif - - nsst_year=idate(1) - nsst_mon=idate(2) - nsst_day=idate(3) - nsst_hour=idate(4) - nsst_fhour=float(nfhour) - - levtyp='sfc' - lev=1 - nframe=0 - - allocate(dummy(imi*jmi)) - -!----------------------------------------------------------------------- -! Read land mask. Note: older file versions use 'slmsk' -! as the header id. -!----------------------------------------------------------------------- - - call nemsio_readrecv(gfile,recname(1),levtyp,lev, & - dummy,nframe,iret) - if (iret /= 0) then - call nemsio_readrecv(gfile,"slmsk",levtyp,lev, & - dummy,nframe,iret) - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of landmask record." - print*,"- IRET IS ", iret - call errexit(113) - endif - endif - mask_input = reshape (dummy, (/imi,jmi/)) - - print*,"- READ DATA RECORDS" - do j = 2, nrec - call nemsio_readrecv(gfile,recname(j),levtyp,lev, & - dummy,nframe,iret) - if (iret /= 0) then - print*,"- FATAL ERROR: bad read of chgres.inp.nst." - print*,"- IRET IS ", iret - call errexit(114) - endif - nsst_input(:,:,j-1) = reshape (dummy, (/imi,jmi/)) - enddo - - deallocate(dummy) - - call nemsio_close(gfile,iret=iret) - - END SUBROUTINE READ_GFS_NSST_DATA_NEMSIO - - SUBROUTINE READ_GFS_SFC_HEADER_NEMSIO (IMI,JMI,IVSI,LSOILI, & - FCSTHOUR,IDATE4O,KGDS_INPUT) - - USE NEMSIO_MODULE - - IMPLICIT NONE - - INTEGER, INTENT(OUT) :: IMI,JMI,IVSI,LSOILI,IDATE4O(4) - INTEGER, INTENT(OUT) :: KGDS_INPUT(200) - - REAL, INTENT(OUT) :: FCSTHOUR - - CHARACTER(LEN=8) :: FILETYPE - - INTEGER(NEMSIO_INTKIND) :: DIMX, DIMY, IRET, VERSION - INTEGER(NEMSIO_INTKIND) :: NSOIL, IDATE(7), NFHOUR - - TYPE(NEMSIO_GFILE) :: GFILEISFC - - CALL NEMSIO_OPEN(GFILEISFC,'chgres.inp.sfc','read',IRET=IRET) - IF (IRET /= 0) THEN - PRINT*,"FATAL ERROR OPENING chgres.inp.sfc" - PRINT*,"IRET IS: ",IRET - CALL ERREXIT(119) - ENDIF - - CALL NEMSIO_GETFILEHEAD(GFILEISFC,GTYPE=FILETYPE,IRET=IRET, & - VERSION=VERSION, DIMX=DIMX, DIMY=DIMY, NSOIL=NSOIL, & - IDATE=IDATE, NFHOUR=NFHOUR) - IF (IRET /= 0) THEN - PRINT*,"FATAL ERROR READING chgres.inp.sfc FILE HEADER." - PRINT*,"IRET IS: ",IRET - CALL ERREXIT(120) - ENDIF - -! check bad status - - CALL NEMSIO_CLOSE(GFILEISFC,IRET=IRET) - - IMI = DIMX - JMI = DIMY - LSOILI = NSOIL - IVSI = VERSION - FCSTHOUR = FLOAT(NFHOUR) - IDATE4O(1) = IDATE(4) ! HOUR - IDATE4O(2) = IDATE(2) ! MONTH - IDATE4O(3) = IDATE(3) ! DAY - IDATE4O(4) = IDATE(1) ! YEAR - - 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 - - END SUBROUTINE READ_GFS_SFC_HEADER_NEMSIO - - SUBROUTINE READ_GFS_SFC_HEADER_SFCIO (NSFCI,IMI,JMI,IVSI,LSOILI, & - FCSTHOUR,IDATE4O,KGDS_INPUT) - - USE SFCIO_MODULE - - INTEGER, INTENT(IN) :: NSFCI - INTEGER, INTENT(OUT) :: IMI,JMI,IVSI,LSOILI,IDATE4O(4) - INTEGER, INTENT(OUT) :: KGDS_INPUT(200) - INTEGER :: IRET - - REAL, INTENT(OUT) :: FCSTHOUR - - TYPE(SFCIO_HEAD) :: SFCHEADI - - CALL SFCIO_SROPEN(NSFCI,'chgres.inp.sfc',IRET) - IF (IRET /= 0) THEN - PRINT*,"FATAL ERROR OPENING chgres.inp.sfc" - PRINT*,"IRET IS: ", IRET - CALL ERREXIT(121) - ENDIF - - CALL SFCIO_SRHEAD(NSFCI,SFCHEADI,IRET) - IF (IRET /= 0) THEN - PRINT*,"FATAL ERROR READING chgres.inp.sfc HEADER" - PRINT*,"IRET IS: ", IRET - CALL ERREXIT(122) - ENDIF - - CALL SFCIO_SCLOSE(NSFCI,IRET) - - IMI = SFCHEADI%LONB - JMI = SFCHEADI%LATB - IVSI = SFCHEADI%IVS - LSOILI = SFCHEADI%LSOIL - FCSTHOUR = SFCHEADI%FHOUR - IDATE4O = SFCHEADI%IDATE - - 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 - - END SUBROUTINE READ_GFS_SFC_HEADER_SFCIO - - SUBROUTINE READ_FV3GFS_SFC_DATA_NEMSIO (IMI, JMI, LSOILI, SFCINPUT, & - F10MI, T2MI, Q2MI, & - UUSTARI, FFMMI, FFHHI, SRFLAGI, & - TPRCPI) - - USE NEMSIO_MODULE - USE SURFACE_CHGRES - - INTEGER, INTENT(IN) :: IMI, JMI, LSOILI - - REAL, INTENT(OUT) :: F10MI(IMI,JMI), T2MI(IMI,JMI) - REAL, INTENT(OUT) :: Q2MI(IMI,JMI), UUSTARI(IMI,JMI) - REAL, INTENT(OUT) :: FFMMI(IMI,JMI), FFHHI(IMI,JMI) - REAL, INTENT(OUT) :: SRFLAGI(IMI,JMI), TPRCPI(IMI,JMI) - - TYPE(SFC2D) :: SFCINPUT - TYPE(NEMSIO_GFILE) :: GFILEISFC - - INTEGER(NEMSIO_INTKIND) :: IRET - - REAL(NEMSIO_REALKIND) :: TMP(IMI*JMI) - - CALL NEMSIO_OPEN(GFILEISFC,'chgres.inp.sfc','read',IRET=IRET) - IF(IRET /= 0)THEN - PRINT*,"FATAL ERROR OPENING chgres.inp.sfc" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(244) - ENDIF - - SRFLAGI = 0.0 ! NOT IN FILE. SET TO ZERO. - - CALL NEMSIO_READRECV(GFILEISFC, 'ffhh', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - FFHHI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'ffmm', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - FFMMI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'f10m', '10 m above gnd', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - F10MI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', '2 m above gnd', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - T2MI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'spfh', '2 m above gnd', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - Q2MI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'fricv', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - UUSTARI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tprcp', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - TPRCPI = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'alnsf', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%ALNSF = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'alnwf', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%ALNWF = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'alvsf', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%ALVSF = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'cnwat', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%CANOPY_MC = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'veg', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%GREENFRC = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'facsf', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%FACSF = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'facwf', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%FACWF = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SKIN_TEMP = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'land', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%LSMASK = RESHAPE(TMP, (/IMI,JMI/) ) - - DO J = 1, JMI - DO I = 1, IMI - SFCINPUT%SEA_ICE_FLAG(I,J) = 0 - IF(NINT(SFCINPUT%LSMASK(I,J))==2) THEN - SFCINPUT%LSMASK(I,J)=0. - SFCINPUT%SEA_ICE_FLAG(I,J) = 1 - ENDIF - ENDDO - ENDDO - - CALL NEMSIO_READRECV(GFILEISFC, 'sfcr', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%Z0 = RESHAPE(TMP, (/IMI,JMI/) ) - SFCINPUT%Z0 = SFCINPUT%Z0 * 100.0 ! convert to cm - - CALL NEMSIO_READRECV(GFILEISFC, 'orog', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%OROG = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'vtype', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%VEG_TYPE = NINT(RESHAPE(TMP, (/IMI,JMI/) )) - - CALL NEMSIO_READRECV(GFILEISFC, 'sotyp', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOIL_TYPE = NINT(RESHAPE(TMP, (/IMI,JMI/) )) - - CALL NEMSIO_READRECV(GFILEISFC, 'weasd', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SNOW_LIQ_EQUIV = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'icec', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SEA_ICE_FRACT = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'icetk', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SEA_ICE_DEPTH = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'snoalb', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%MXSNOW_ALB = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'snod', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SNOW_DEPTH = RESHAPE(TMP, (/IMI,JMI/) ) - SFCINPUT%SNOW_DEPTH = SFCINPUT%SNOW_DEPTH * 1000.0 ! convert to mm - - CALL NEMSIO_READRECV(GFILEISFC, 'sltyp', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SLOPE_TYPE = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'shdmin', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%GREENFRC_MIN = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'shdmax', 'sfc', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%GREENFRC_MAX = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soilw', '0-10 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_TOT(:,:,1) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soilw', '10-40 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_TOT(:,:,2) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soilw', '40-100 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_TOT(:,:,3) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soilw', '100-200 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_TOT(:,:,4) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soill', '0-10 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_LIQ(:,:,1) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soill', '10-40 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_LIQ(:,:,2) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soill', '40-100 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_LIQ(:,:,3) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'soill', '100-200 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOILM_LIQ(:,:,4) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', '0-10 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOIL_TEMP(:,:,1) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', '10-40 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOIL_TEMP(:,:,2) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', '40-100 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOIL_TEMP(:,:,3) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_READRECV(GFILEISFC, 'tmp', '100-200 cm down', 1, TMP, IRET=IRET) - IF (IRET /= 0) GOTO 99 - SFCINPUT%SOIL_TEMP(:,:,4) = RESHAPE(TMP, (/IMI,JMI/) ) - - CALL NEMSIO_CLOSE(GFILEISFC, IRET=IRET) - - RETURN - - 99 CONTINUE - PRINT*,"FATAL ERROR READING DATA FROM chgres.inp.sfc" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(245) - - END SUBROUTINE READ_FV3GFS_SFC_DATA_NEMSIO - - SUBROUTINE READ_GFS_SFC_DATA_NEMSIO (IMI, JMI, LSOILI, IVSI, SFCINPUT, & - F10MI, T2MI, Q2MI, & - UUSTARI, FFMMI, FFHHI, SRFLAGI, & - TPRCPI) - - USE NEMSIO_MODULE - USE NEMSIO_GFS - USE SURFACE_CHGRES - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: IMI, JMI, LSOILI, IVSI - - REAL, INTENT(OUT) :: F10MI(IMI,JMI), T2MI(IMI,JMI) - REAL, INTENT(OUT) :: Q2MI(IMI,JMI), UUSTARI(IMI,JMI) - REAL, INTENT(OUT) :: FFMMI(IMI,JMI), FFHHI(IMI,JMI) - REAL, INTENT(OUT) :: SRFLAGI(IMI,JMI), TPRCPI(IMI,JMI) - - INTEGER(NEMSIO_INTKIND) :: IRET - INTEGER :: I, J, L - - TYPE(SFC2D) :: SFCINPUT - TYPE(NEMSIO_GFILE) :: GFILEISFC - TYPE(NEMSIO_DBTA) :: GFSDATAI - - CALL NEMSIO_OPEN(GFILEISFC,'chgres.inp.sfc','read',IRET=IRET) - IF(IRET /= 0)THEN - PRINT*,"FATAL ERROR OPENING chgres.inp.sfc" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(144) - ENDIF - - CALL NEMSIO_GFS_ALSFC(IMI, JMI, LSOILI, GFSDATAI) - - CALL NEMSIO_GFS_RDSFC(GFILEISFC,GFSDATAI,IRET) - IF(IRET /= 0)THEN - PRINT*,"FATAL ERROR READING DATA FROM chgres.inp.sfc" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(145) - ENDIF - - CALL NEMSIO_CLOSE(GFILEISFC, IRET=IRET) - -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, JMI - DO I = 1, IMI - - SFCINPUT%ALNSF(I,J) = GFSDATAI%ALNSF(I,J) - SFCINPUT%ALNWF(I,J) = GFSDATAI%ALNWF(I,J) - SFCINPUT%ALVSF(I,J) = GFSDATAI%ALVSF(I,J) - SFCINPUT%ALVWF(I,J) = GFSDATAI%ALVWF(I,J) - SFCINPUT%CANOPY_MC(I,J) = GFSDATAI%CANOPY(I,J) - SFCINPUT%GREENFRC(I,J) = GFSDATAI%VFRAC(I,J) - SFCINPUT%FACSF(I,J) = GFSDATAI%FACSF(I,J) - SFCINPUT%FACWF(I,J) = GFSDATAI%FACWF(I,J) - SFCINPUT%SKIN_TEMP(I,J) = GFSDATAI%TSEA(I,J) - SFCINPUT%LSMASK(I,J) = GFSDATAI%SLMSK(I,J) - SFCINPUT%SEA_ICE_FLAG(I,J) = 0 - IF(NINT(SFCINPUT%LSMASK(I,J))==2) THEN - SFCINPUT%LSMASK(I,J)=0. - SFCINPUT%SEA_ICE_FLAG(I,J) = 1 - ENDIF - SFCINPUT%Z0(I,J) = GFSDATAI%ZORL(I,J) - SFCINPUT%OROG(I,J) = GFSDATAI%OROG(I,J) - SFCINPUT%VEG_TYPE(I,J) = NINT(GFSDATAI%VTYPE(I,J)) - SFCINPUT%SOIL_TYPE(I,J) = NINT(GFSDATAI%STYPE(I,J)) - SFCINPUT%SNOW_LIQ_EQUIV(I,J) = GFSDATAI%SHELEG(I,J) - - ENDDO - ENDDO -!$OMP END PARALLEL DO - - DO L = 1, LSOILI -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, JMI - DO I = 1, IMI - SFCINPUT%SOILM_TOT(I,J,L) = GFSDATAI%SMC(I,J,L) - SFCINPUT%SOIL_TEMP(I,J,L) = GFSDATAI%STC(I,J,L) - ENDDO - ENDDO -!$OMP END PARALLEL DO - ENDDO - - SRFLAGI = 0.0 - TPRCPI = 0.0 - - IF (IVSI >= 200501) THEN -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, JMI - DO I = 1, IMI - SFCINPUT%SEA_ICE_FRACT(I,J) = GFSDATAI%FICE(I,J) - SFCINPUT%SEA_ICE_DEPTH(I,J) = GFSDATAI%HICE(I,J) - SFCINPUT%MXSNOW_ALB(I,J) = GFSDATAI%SNOALB(I,J) - SFCINPUT%SNOW_DEPTH(I,J) = GFSDATAI%SNWDPH(I,J) - SFCINPUT%SLOPE_TYPE(I,J) = NINT(GFSDATAI%SLOPE(I,J)) - SFCINPUT%GREENFRC_MAX(I,J) = GFSDATAI%SHDMAX(I,J) - SFCINPUT%GREENFRC_MIN(I,J) = GFSDATAI%SHDMIN(I,J) - SRFLAGI(I,J) = GFSDATAI%SRFLAG(I,J) - TPRCPI(I,J) = GFSDATAI%TPRCP(I,J) - ENDDO - ENDDO -!$OMP END PARALLEL DO - - DO L=1,LSOILI -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, JMI - DO I = 1, IMI - SFCINPUT%SOILM_LIQ(I,J,L) = GFSDATAI%SLC(I,J,L) - ENDDO - ENDDO - ENDDO - - END IF ! IVS >= 200501 - -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, JMI - DO I = 1, IMI - F10MI(I,J) = GFSDATAI%F10M(I,J) - T2MI(I,J) = GFSDATAI%T2M(I,J) - Q2MI(I,J) = GFSDATAI%Q2M(I,J) - UUSTARI(I,J) = GFSDATAI%UUSTAR(I,J) - FFMMI(I,J) = GFSDATAI%FFMM(I,J) - FFHHI(I,J) = GFSDATAI%FFHH(I,J) - ENDDO - ENDDO -!$OMP END PARALLEL DO - - END SUBROUTINE READ_GFS_SFC_DATA_NEMSIO - - SUBROUTINE READ_GFS_SFC_DATA_SFCIO (NSFCI, IMI, JMI, SFCINPUT, & - F10MI, T2MI, Q2MI, & - UUSTARI, FFMMI, FFHHI, SRFLAGI, & - TPRCPI) - - USE SFCIO_MODULE - USE SURFACE_CHGRES - - IMPLICIT NONE - - INTEGER, INTENT(IN) :: NSFCI, IMI, JMI - INTEGER :: I,J,L, IRET - - REAL, INTENT(OUT) :: F10MI(IMI,JMI), T2MI(IMI,JMI) - REAL, INTENT(OUT) :: Q2MI(IMI,JMI), UUSTARI(IMI,JMI) - REAL, INTENT(OUT) :: FFMMI(IMI,JMI), FFHHI(IMI,JMI) - REAL, INTENT(OUT) :: SRFLAGI(IMI,JMI), TPRCPI(IMI,JMI) - - TYPE(SFC2D) :: SFCINPUT - TYPE(SFCIO_HEAD) :: SFCHEADI - TYPE(SFCIO_DBTA) :: SFCDATAI - - CALL SFCIO_SROPEN(NSFCI,'chgres.inp.sfc',IRET) - IF(IRET /=0) THEN - PRINT*,"FATAL ERROR OPENING chgres.inp.sfc" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(155) - ENDIF - - CALL SFCIO_SRHEAD(NSFCI,SFCHEADI,IRET) - IF(IRET /=0) THEN - PRINT*,"FATAL ERROR READING chgres.inp.sfc HEADER" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(156) - ENDIF - - CALL SFCIO_ALDBTA(SFCHEADI,SFCDATAI,IRET) - IF(IRET.NE.0) THEN - PRINT*,"FATAL ERROR ALLOCATING SFC DATA STRUCTURE" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(158) - ENDIF - - CALL SFCIO_SRDBTA(NSFCI,SFCHEADI,SFCDATAI,IRET) - IF(IRET /=0) THEN - PRINT*,"FATAL ERROR READING chgres.inp.sfc DATA" - PRINT*,"IRET IS ", IRET - CALL ERREXIT(157) - ENDIF - - CALL SFCIO_SCLOSE(NSFCI,IRET) - -!$OMP PARALLEL DO PRIVATE(I,J) - - DO J = 1, SFCHEADI%LATB - DO I = 1, SFCHEADI%LONB - - SFCINPUT%ALNSF(I,J) = SFCDATAI%ALNSF(I,J) - SFCINPUT%ALNWF(I,J) = SFCDATAI%ALNWF(I,J) - SFCINPUT%ALVSF(I,J) = SFCDATAI%ALVSF(I,J) - SFCINPUT%ALVWF(I,J) = SFCDATAI%ALVWF(I,J) - SFCINPUT%CANOPY_MC(I,J) = SFCDATAI%CANOPY(I,J) - SFCINPUT%GREENFRC(I,J) = SFCDATAI%VFRAC(I,J) - SFCINPUT%FACSF(I,J) = SFCDATAI%FACSF(I,J) - SFCINPUT%FACWF(I,J) = SFCDATAI%FACWF(I,J) - SFCINPUT%SKIN_TEMP(I,J) = SFCDATAI%TSEA(I,J) - SFCINPUT%LSMASK(I,J) = SFCDATAI%SLMSK(I,J) - SFCINPUT%SEA_ICE_FLAG(I,J) = 0 - IF(NINT(SFCINPUT%LSMASK(I,J))==2) THEN - SFCINPUT%LSMASK(I,J)=0. - SFCINPUT%SEA_ICE_FLAG(I,J) = 1 - ENDIF - SFCINPUT%Z0(I,J) = SFCDATAI%ZORL(I,J) - SFCINPUT%OROG(I,J) = SFCDATAI%OROG(I,J) - SFCINPUT%VEG_TYPE(I,J) = NINT(SFCDATAI%VTYPE(I,J)) - SFCINPUT%SOIL_TYPE(I,J) = NINT(SFCDATAI%STYPE(I,J)) - SFCINPUT%SNOW_LIQ_EQUIV(I,J) = SFCDATAI%SHELEG(I,J) - - ENDDO - ENDDO - -!$OMP END PARALLEL DO - - DO L = 1, SFCHEADI%LSOIL -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, SFCHEADI%LATB - DO I = 1, SFCHEADI%LONB - SFCINPUT%SOILM_TOT(I,J,L) = SFCDATAI%SMC(I,J,L) - SFCINPUT%SOIL_TEMP(I,J,L) = SFCDATAI%STC(I,J,L) - ENDDO - ENDDO -!$OMP END PARALLEL DO - ENDDO - - SRFLAGI = 0.0 - TPRCPI = 0.0 - - IF (SFCHEADI%IVS >= 200501) THEN -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, SFCHEADI%LATB - DO I = 1, SFCHEADI%LONB - SFCINPUT%SEA_ICE_FRACT(I,J) = SFCDATAI%FICE(I,J) - SFCINPUT%SEA_ICE_DEPTH(I,J) = SFCDATAI%HICE(I,J) - SFCINPUT%MXSNOW_ALB(I,J) = SFCDATAI%SNOALB(I,J) - SFCINPUT%SNOW_DEPTH(I,J) = SFCDATAI%SNWDPH(I,J) - SFCINPUT%SLOPE_TYPE(I,J) = NINT(SFCDATAI%SLOPE(I,J)) - SFCINPUT%GREENFRC_MAX(I,J) = SFCDATAI%SHDMAX(I,J) - SFCINPUT%GREENFRC_MIN(I,J) = SFCDATAI%SHDMIN(I,J) - SRFLAGI(I,J) = SFCDATAI%SRFLAG(I,J) - TPRCPI(I,J) = SFCDATAI%TPRCP(I,J) - ENDDO - ENDDO -!$OMP END PARALLEL DO - - DO L=1,SFCHEADI%LSOIL -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, SFCHEADI%LATB - DO I = 1, SFCHEADI%LONB - SFCINPUT%SOILM_LIQ(I,J,L) = SFCDATAI%SLC(I,J,L) - ENDDO - ENDDO - ENDDO - - END IF ! IVS >= 200501 - -!$OMP PARALLEL DO PRIVATE(I,J) - DO J = 1, SFCHEADI%LATB - DO I = 1, SFCHEADI%LONB - F10MI(I,J) = SFCDATAI%F10M(I,J) - T2MI(I,J) = SFCDATAI%T2M(I,J) - Q2MI(I,J) = SFCDATAI%Q2M(I,J) - UUSTARI(I,J) = SFCDATAI%UUSTAR(I,J) - FFMMI(I,J) = SFCDATAI%FFMM(I,J) - FFHHI(I,J) = SFCDATAI%FFHH(I,J) - ENDDO - ENDDO -!$OMP END PARALLEL DO - - CALL SFCIO_AXDBTA(SFCDATAI,IRET) - - END SUBROUTINE READ_GFS_SFC_DATA_SFCIO diff --git a/sorc/global_chgres.fd/sfcsub.F b/sorc/global_chgres.fd/sfcsub.F deleted file mode 100644 index 86d638eae..000000000 --- a/sorc/global_chgres.fd/sfcsub.F +++ /dev/null @@ -1,8651 +0,0 @@ -!> @file - module sfccyc_module - implicit none - save -! -! grib code for each parameter - used in subroutines sfccycle and setrmsk. -! - integer kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla, - & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg, - & kpdvet,kpdsot - &, kpdvmn,kpdvmx,kpdslp,kpdabs - &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) - parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, -! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, - 1 kpdais=91, kpdtg3=11, kpdplr=224, - 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, - 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, -!cbosu max snow albedo uses a grib id number of 159, not 255. - & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, - & kpdvet=225, kpdsot=224,kpdabs_1=159, - & kpdsnd=66 ) -! - integer, parameter :: kpdalb_0(4)=(/212,215,213,216/) - integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) - integer, parameter :: kpdalf(2)=(/214,217/) -! - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata - integer :: veg_type_landice - integer :: soil_type_landice -! - end module sfccyc_module - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc - &, iy,im,id,ih,fh - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl - &, sihfcs,sicfcs,sitfcs - &, swdfcs,slcfcs - &, vmnfcs,vmxfcs,slpfcs,absfcs - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs - &, vegfcs,vetfcs,sotfcs,alffcs - &, cvfcs,cvbfcs,cvtfcs,me,nlunit - &, sz_nml,input_nml_file - &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) -! - use machine , only : kind_io8,kind_io4 - use sfccyc_module - implicit none - character(len=*), intent(in) :: tile_num_ch - integer,intent(in) :: i_index(len), j_index(len) - logical use_ufo, nst_anl - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, - & orolmx,orolmn,oroomx,oroomn,orosmx, - & orosmn,oroimx,oroimn,orojmx,orojmn, - & alblmx,alblmn,albomx,albomn,albsmx, - & albsmn,albimx,albimn,albjmx,albjmn, - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, - & snolmx,snolmn,snoomx,snoomn,snosmx, - & snosmn,snoimx,snoimn,snojmx,snojmn, - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, - & plrlmx,plrlmn,plromx,plromn,plrsmx, - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, - & stclmx,stclmn,stcomx,stcomn,stcsmx, - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, - & smclmx,smclmn,smcomx,smcomn,smcsmx, - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, - & veglmx,veglmn,vegomx,vegomn,vegsmx, - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, - & alslmx,alslmn,alsomx,alsomn,alssmx, - & alssmn,alsimx,alsimn,alsjmx,alsjmn, - & epstsf,epsalb,epssno,epswet,epszor, - & epsplr,epsoro,epssmc,epsscv,eptsfc, - & epstg3,epsais,epsacn,epsveg,epsvet, - & epssot,epsalf,qctsfs,qcsnos,qctsfi, - & aislim,snwmin,snwmax,cplrl,cplrs, - & cvegl,czors,csnol,csnos,czorl,csots, - & csotl,cvwgs,cvetl,cvets,calfs, - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, - & calbl,calfl,calbs,ctsfs,grboro, - & grbmsk,ctsfl,deltf,caisl,caiss, - & fsalfl,fsalfs,flalfs,falbl,ftsfl, - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, - & deltsfc,critp2,critp3,blnmsk,critp1, - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 - &, fsihl,fsihs,fsicl,fsics, - & csihl,csihs,csicl,csics,epssih,epssic - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, - & epsslp,epsabs - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, - & siclmx,siclmn,sicomx,sicomn,sicsmx, - & sicsmn,sicimx,sicimn,sicjmx,sicjmn - &, glacir_hice - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, - & slplmx,slplmn,slpomx,slpomn,slpsmx, - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, - & abslmx,abslmn,absomx,absomn,abssmx, - & abssmn,absimx,absimn,absjmx,absjmn - &, sihnew - - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, - & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, - & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, - & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb - &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, - & monfcs, monmer, mondif, landice - character(len=*), intent(in) :: input_nml_file(sz_nml) - - integer num_parthds -! -! this is a limited point version of surface program. -! -! this program runs in two different modes: -! -! 1. analysis mode (fh=0.) -! -! this program merges climatology, analysis and forecast guess to create -! new surface fields. if analysis file is given, the program -! uses it if date of the analysis matches with iy,im,id,ih (see note -! below). -! -! 2. forecast mode (fh.gt.0.) -! -! this program interpolates climatology to the date corresponding to the -! forecast hour. if surface analysis file is given, for the corresponding -! dates, the program will use it. -! -! note: -! -! if the date of the analysis does not match given iy,im,id,ih, (and fh), -! the program searches an old analysis by going back 6 hours, then 12 hours, -! then one day upto nrepmx days (parameter statement in the subrotine fixrd. -! now defined as 8). this allows the user to provide non-daily analysis to -! be used. if matching field is not found, the forecast guess will be used. -! -! use of a combined earlier surface analyses and current analysis is -! not allowed (as was done in the old version for snow analysis in which -! old snow analysis is used in combination with initial guess), except -! for sea surface temperature. for sst anolmaly interpolation, you need to -! set lanom=.true. and must provide sst analysis at initial time. -! -! if you want to do complex merging of past and present surface field analysis, -! you need to create a separate file that contains daily surface field. -! -! for a dead start, do not supply fnbgsi or set fnbgsi=' ' -! -! lugb is the unit number used in this subprogram -! len ... number of points on which sfccyc operates -! lsoil .. number of soil layers (2 as of april, 1994) -! iy,im,id,ih .. year, month, day, and hour of initial state. -! fh .. forecast hour -! rla, rlo -- latitude and longitudes of the len points -! sig1t .. sigma level 1 temperature for dead start. should be on gaussian -! grid. if not dead start, no need for dimension but set to zero -! as in the example below. -! -! variable naming conventions: -! -! oro .. orography -! alb .. albedo -! wet .. soil wetness as defined for bucket model -! sno .. snow depth -! zor .. surface roughness length -! vet .. vegetation type -! plr .. plant evaporation resistance -! tsf .. surface skin temperature. sea surface temp. over ocean. -! tg3 .. deep soil temperature (at 500cm) -! stc .. soil temperature (lsoil layrs) -! smc .. soil moisture (lsoil layrs) -! scv .. snow cover (not snow depth) -! ais .. sea ice mask (0 or 1) -! acn .. sea ice concentration (fraction) -! gla .. glacier (permanent snow) mask (0 or 1) -! mxi .. maximum sea ice extent (0 or 1) -! msk .. land ocean mask (0=ocean 1=land) -! cnp .. canopy water content -! cv .. convective cloud cover -! cvb .. convective cloud base -! cvt .. convective cloud top -! sli .. land/sea/sea-ice mask. (1/0/2 respectively) -! veg .. vegetation cover -! sot .. soil type -!cwu [+2l] add sih & sic -! sih .. sea ice thickness -! sic .. sea ice concentration -!clu [+6l] add swd,slc,vmn,vmx,slp,abs -! swd .. actual snow depth -! slc .. liquid soil moisture (lsoil layers) -! vmn .. vegetation cover minimum -! vmx .. vegetation cover maximum -! slp .. slope type -! abs .. maximum snow albedo - -! -! definition of land/sea mask. sllnd for land and slsea for sea. -! definition of sea/ice mask. aicice for ice, aicsea for sea. -! tgice=max ice temperature -! rlapse=lapse rate for sst correction due to surface angulation -! - parameter(sllnd =1.0,slsea =0.0) - parameter(aicice=1.0,aicsea=0.0) - parameter(tgice=271.2) - parameter(rlapse=0.65e-2) -! -! max/min of fields for check and replace. -! -! ???lmx .. max over bare land -! ???lmn .. min over bare land -! ???omx .. max over open ocean -! ???omn .. min over open ocean -! ???smx .. max over snow surface (land and sea-ice) -! ???smn .. min over snow surface (land and sea-ice) -! ???imx .. max over bare sea ice -! ???imn .. min over bare sea ice -! ???jmx .. max over snow covered sea ice -! ???jmn .. min over snow covered sea ice -! - parameter(orolmx=8000.,orolmn=-1000.,oroomx=3000.,oroomn=-1000., - & orosmx=8000.,orosmn=-1000.,oroimx=3000.,oroimn=-1000., - & orojmx=3000.,orojmn=-1000.) -! parameter(alblmx=0.80,alblmn=0.06,albomx=0.06,albomn=0.06, -! & albsmx=0.80,albsmn=0.06,albimx=0.80,albimn=0.80, -! & albjmx=0.80,albjmn=0.80) -!cwu [-3l/+9l] change min/max for alb; add min/max for sih & sic -! parameter(alblmx=0.80,alblmn=0.01,albomx=0.01,albomn=0.01, -! & albsmx=0.80,albsmn=0.01,albimx=0.01,albimn=0.01, -! & albjmx=0.01,albjmn=0.01) -! note: the range values for bare land and snow covered land -! (alblmx, alblmn, albsmx, albsmn) are set below -! based on whether the old or new radiation is selected - parameter(albomx=0.06,albomn=0.06, - & albimx=0.80,albimn=0.06, - & albjmx=0.80,albjmn=0.06) - parameter(sihlmx=0.0,sihlmn=0.0,sihomx=5.0,sihomn=0.0, - & sihsmx=5.0,sihsmn=0.0,sihimx=5.0,sihimn=0.10, - & sihjmx=5.0,sihjmn=0.10,glacir_hice=3.0) -!cwu change sicimn & sicjmn Jan 2015 -! parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, -! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.50, -! & sicjmx=1.0,sicjmn=0.50) -! -! parameter(sihlmx=0.0,sihlmn=0.0,sihomx=8.0,sihomn=0.0, -! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, -! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) - parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, - & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, - & sicjmx=1.0,sicjmn=0.15) - - parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, - & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, - & wetjmx=0.15,wetjmn=0.15) - parameter(snolmx=0.0,snolmn=0.0,snoomx=0.0,snoomn=0.0, - & snosmx=55000.,snosmn=0.001,snoimx=0.,snoimn=0.0, - & snojmx=10000.,snojmn=0.01) - parameter(zorlmx=300.,zorlmn=1.0,zoromx=1.0,zoromn=1.e-05, - & zorsmx=300.,zorsmn=1.0,zorimx=1.0,zorimn=1.0, - & zorjmx=1.0,zorjmn=1.0) - parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, - & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, - & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx (for noah lsm) - parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, - & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, - & tsfjmx=273.16,tsfjmn=173.0) -! parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.21, -!* & tsfsmx=273.16,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, -! & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, - parameter(tg3lmx=310.,tg3lmn=200.0,tg3omx=310.0,tg3omn=200.0, - & tg3smx=310.,tg3smn=200.0,tg3imx=310.0,tg3imn=200.0, - & tg3jmx=310.,tg3jmn=200.0) - parameter(stclmx=353.,stclmn=173.0,stcomx=313.0,stcomn=200.0, - & stcsmx=310.,stcsmn=200.0,stcimx=310.0,stcimn=200.0, - & stcjmx=310.,stcjmn=200.0) -!landice mods force a flag value of soil moisture of 1.0 -! at non-land points - parameter(smclmx=0.55,smclmn=0.0,smcomx=1.0,smcomn=1.0, - & smcsmx=0.55,smcsmn=0.0,smcimx=1.0,smcimn=1.0, - & smcjmx=1.0,smcjmn=1.0) - parameter(scvlmx=0.0,scvlmn=0.0,scvomx=0.0,scvomn=0.0, - & scvsmx=1.0,scvsmn=1.0,scvimx=0.0,scvimn=0.0, - & scvjmx=1.0,scvjmn=1.0) - parameter(veglmx=1.0,veglmn=0.0,vegomx=0.0,vegomn=0.0, - & vegsmx=1.0,vegsmn=0.0,vegimx=0.0,vegimn=0.0, - & vegjmx=0.0,vegjmn=0.0) - parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, - & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, - & vmnjmx=0.0,vmnjmn=0.0) - parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, - & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, - & vmxjmx=0.0,vmxjmn=0.0) - parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, - & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., - & slpjmx=0.,slpjmn=0.) -! note: the range values for bare land and snow covered land -! (alblmx, alblmn, albsmx, albsmn) are set below -! based on whether the old or new radiation is selected - parameter(absomx=0.0,absomn=0.0, - & absimx=0.0,absimn=0.0, - & absjmx=0.0,absjmn=0.0) -! vegetation type - parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, - & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., - & vetjmx=0.,vetjmn=0.) -! soil type - parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0, - & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0., - & sotjmx=0.,sotjmn=0.) -! fraction of vegetation for strongly and weakly zeneith angle dependent -! albedo - parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0, - & alssmx=1.0,alssmn=0.0,alsimx=0.0,alsimn=0.0, - & alsjmx=0.0,alsjmn=0.0) -! -! criteria used for monitoring -! - parameter(epstsf=0.01,epsalb=0.001,epssno=0.01, - & epswet=0.01,epszor=0.0000001,epsplr=1.,epsoro=0., - & epssmc=0.0001,epsscv=0.,eptsfc=0.01,epstg3=0.01, - & epsais=0.,epsacn=0.01,epsveg=0.01, - & epssih=0.001,epssic=0.001, - & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01, - & epsvet=.01,epssot=.01,epsalf=.001) -! -! quality control of analysis snow and sea ice -! -! qctsfs .. surface temperature above which no snow allowed -! qcsnos .. snow depth above which snow must exist -! qctsfi .. sst above which sea-ice is not allowed -! -!clu relax qctsfs (for noah lsm) -!* parameter(qctsfs=283.16,qcsnos=100.,qctsfi=280.16) -!* parameter(qctsfs=288.16,qcsnos=100.,qctsfi=280.16) - parameter(qctsfs=293.16,qcsnos=100.,qctsfi=280.16) -! -!cwu [-2l] -!* ice concentration for ice limit (55 percent) -! -!* parameter(aislim=0.55) -! -! parameters to obtain snow depth from snow cover and temperature -! -! parameter(snwmin=25.,snwmax=100.) - parameter(snwmin=5.0,snwmax=100.) - real (kind=kind_io8), parameter :: ten=10.0, one=1.0 -! -! coeeficients of blending forecast and interpolated clim -! (or analyzed) fields over sea or land(l) (not for clouds) -! 1.0 = use of forecast -! 0.0 = replace with interpolated analysis -! -! these values are set for analysis mode. -! -! variables land sea -! --------------------------------------------------------- -! surface temperature forecast analysis -! surface temperature forecast forecast (over sea ice) -! albedo analysis analysis -! sea-ice analysis analysis -! snow analysis forecast (over sea ice) -! roughness analysis forecast -! plant resistance analysis analysis -! soil wetness (layer) weighted average analysis -! soil temperature forecast analysis -! canopy waver content forecast forecast -! convective cloud cover forecast forecast -! convective cloud bottm forecast forecast -! convective cloud top forecast forecast -! vegetation cover analysis analysis -! vegetation type analysis analysis -! soil type analysis analysis -! sea-ice thickness forecast forecast -! sea-ice concentration analysis analysis -! vegetation cover min analysis analysis -! vegetation cover max analysis analysis -! max snow albedo analysis analysis -! slope type analysis analysis -! liquid soil wetness analysis-weighted analysis -! actual snow depth analysis-weighted analysis -! -! note: if analysis file is not given, then time interpolated climatology -! is used. if analyiss file is given, it will be used as far as the -! date and time matches. if they do not match, it uses forecast. -! -! critical percentage value for aborting bad points when lgchek=.true. -! - logical lgchek - data lgchek/.true./ - data critp1,critp2,critp3/80.,80.,25./ -! -! integer kpdalb(4), kpdalf(2) -! data kpdalb/212,215,213,216/, kpdalf/214,217/ -! save kpdalb, kpdalf -! -! mask orography and variance on gaussian grid -! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) - &, orogd(len) - real (kind=kind_io8) rla(len), rlo(len) -! -! permanent/extremes -! - character*500 fnglac,fnmxic - real (kind=kind_io8), allocatable :: glacir(:),amxice(:),tsfcl0(:) -! -! tsfcl0 is the climatological tsf at fh=0 -! -! climatology surface fields (last character 'c' or 'clm' indicate climatology) -! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), - & zorclm(len), albclm(len,4), aisclm(len), - & tg3clm(len), acnclm(len), cnpclm(len), - & cvclm (len), cvbclm(len), cvtclm(len), - & scvclm(len), tsfcl2(len), vegclm(len), - & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), - & smcclm(len,lsoil), stcclm(len,lsoil) - &, sihclm(len), sicclm(len) - &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) -! -! analyzed surface fields (last character 'a' or 'anl' indicate analysis) -! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota - &, fnvmna,fnvmxa,fnslpa,fnabsa -! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), cnpanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & scvanl(len), tsfan2(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), - & smcanl(len,lsoil), stcanl(len,lsoil) - &, sihanl(len), sicanl(len) - &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) -! - real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. -! -! predicted surface fields (last characters 'fcs' indicates forecast) -! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & tg3fcs(len), acnfcs(len), cnpfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2), - & smcfcs(len,lsoil), stcfcs(len,lsoil) - &, sihfcs(len), sicfcs(len), sitfcs(len) - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) - &, swdfcs(len), slcfcs(len,lsoil) -! -! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched -! in this program). -! - real (kind=kind_io8) f10m (len) - real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) - real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) - -!clu [+1l] add swratio (soil moisture liquid-to-total ratio) - real (kind=kind_io8) swratio(len,lsoil) -!clu [+1l] add fixratio (option to adjust slc from smc) - logical fixratio(lsoil) -! - integer icsmcl(25), icsmcs(25), icstcl(25), icstcs(25) -! - real (kind=kind_io8) csmcl(25), csmcs(25) - real (kind=kind_io8) cstcl(25), cstcs(25) -! - real (kind=kind_io8) slmskh(mdata) - character*500 fnmskh - integer kpd7, kpd9 -! - logical icefl1(len), icefl2(len) -! -! input and output surface fields (bges) file names -! -! -! sigma level 1 temperature for dead start -! - real (kind=kind_io8) sig1t(len) -! - character*32 label -! -! = 1 ==> forecast is used -! = 0 ==> analysis (or climatology) is used -! -! output file ... primary surface file for radiation and forecast -! -! rec. 1 label -! rec. 2 date record -! rec. 3 tsf -! rec. 4 soilm(two layers) ----> 4 layers -! rec. 5 snow -! rec. 6 soilt(two layers) ----> 4 layers -! rec. 7 tg3 -! rec. 8 zor -! rec. 9 cv -! rec. 10 cvb -! rec. 11 cvt -! rec. 12 albedo (four types) -! rec. 13 slimsk -! rec. 14 vegetation cover -! rec. 14 plantr -----> skip this record -! rec. 15 f10m -----> canopy -! rec. 16 canopy water content (cnpanl) -----> f10m -! rec. 17 vegetation type -! rec. 18 soil type -! rec. 19 zeneith angle dependent vegetation fraction (two types) -! rec. 20 uustar -! rec. 21 ffmm -! rec. 22 ffhh -!cwu add sih & sic -! rec. 23 sih(one category only) -! rec. 24 sic -!clu [+8l] add prcp, flag, swd, slc, vmn, vmx, slp, abs -! rec. 25 tprcp -! rec. 26 srflag -! rec. 27 swd -! rec. 28 slc (4 layers) -! rec. 29 vmn -! rec. 30 vmx -! rec. 31 slp -! rec. 32 abs - -! -! debug only -! ldebug=.true. creates bges files for climatology and analysis -! lqcbgs=.true. quality controls input bges file before merging (should have been -! qced in the forecast program) -! - logical ldebug,lqcbgs - logical lprnt -! -! debug only -! - character*500 fndclm,fndanl -! - logical lanom - -! - namelist/namsfc/fnglac,fnmxic, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc,fnalbc2, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota, - & fnvmna,fnvmxa,fnslpa,fnabsa, - & fnmskh, - & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, - & fndclm,fndanl, - & lanom, - & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, - & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs, - & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, - & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, - & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, - & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs, - & fsihl,fsicl,fsihs,fsics,aislim,sihnew, - & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss, - & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, - & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, - & icstcl,icstcs,icalfl,icalfs, - & gausm, deads, qcmsk, znlst, - & monclm, monanl, monfcs, monmer, mondif, igrdbg, - & blnmsk, bltmsk, landice -! - data gausm/.true./, deads/.false./, blnmsk/0.0/, bltmsk/90.0/ - &, qcmsk/.false./, znlst/.false./, igrdbg/-1/ - &, monclm/.false./, monanl/.false./, monfcs/.false./ - &, monmer/.false./, mondif/.false./, landice/.true./ -! -! defaults file names -! - data fnmskh/'global_slmask.t126.grb'/ - data fnalbc/'global_albedo4.1x1.grb'/ - data fnalbc2/'global_albedo4.1x1.grb'/ - data fntsfc/'global_sstclim.2x2.grb'/ - data fnsotc/'global_soiltype.1x1.grb'/ - data fnvegc/'global_vegfrac.1x1.grb'/ - data fnvetc/'global_vegtype.1x1.grb'/ - data fnglac/'global_glacier.2x2.grb'/ - data fnmxic/'global_maxice.2x2.grb'/ - data fnsnoc/'global_snoclim.1.875.grb'/ - data fnzorc/'global_zorclim.1x1.grb'/ - data fnaisc/'global_iceclim.2x2.grb'/ - data fntg3c/'global_tg3clim.2.6x1.5.grb'/ - data fnsmcc/'global_soilmcpc.1x1.grb'/ -!clu [+4l] add fn()c for vmn, vmx, abs, slp - data fnvmnc/'global_shdmin.0.144x0.144.grb'/ - data fnvmxc/'global_shdmax.0.144x0.144.grb'/ - data fnslpc/'global_slope.1x1.grb'/ - data fnabsc/'global_snoalb.1x1.grb'/ -! - data fnwetc/' '/ - data fnplrc/' '/ - data fnstcc/' '/ - data fnscvc/' '/ - data fnacnc/' '/ -! - data fntsfa/' '/ - data fnweta/' '/ - data fnsnoa/' '/ - data fnzora/' '/ - data fnalba/' '/ - data fnaisa/' '/ - data fnplra/' '/ - data fntg3a/' '/ - data fnsmca/' '/ - data fnstca/' '/ - data fnscva/' '/ - data fnacna/' '/ - data fnvega/' '/ - data fnveta/' '/ - data fnsota/' '/ -!clu [+4l] add fn()a for vmn, vmx, abs, slp - data fnvmna/' '/ - data fnvmxa/' '/ - data fnslpa/' '/ - data fnabsa/' '/ -! - data ldebug/.false./, lqcbgs/.true./ - data fndclm/' '/ - data fndanl/' '/ - data lanom/.false./ -! -! default relaxation time in hours to analysis or climatology - data ftsfl/99999.0/, ftsfs/0.0/ - data falbl/0.0/, falbs/0.0/ - data falfl/0.0/, falfs/0.0/ - data faisl/0.0/, faiss/0.0/ - data fsnol/0.0/, fsnos/99999.0/ - data fzorl/0.0/, fzors/99999.0/ - data fplrl/0.0/, fplrs/0.0/ - data fvetl/0.0/, fvets/99999.0/ - data fsotl/0.0/, fsots/99999.0/ - data fvegl/0.0/, fvegs/99999.0/ -!cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim - data fsihl/99999.0/, fsihs/99999.0/ -! data fsicl/99999.0/, fsics/99999.0/ - data fsicl/0.0/, fsics/0.0/ -! default ice concentration limit (50%), new ice thickness (20cm) -!cwu change ice concentration limit (15%) Jan 2015 -! data aislim/0.50/, sihnew/0.2/ - data aislim/0.15/, sihnew/0.2/ -!clu [+4l] add f()l and f()s for vmn, vmx, abs, slp - data fvmnl/0.0/, fvmns/99999.0/ - data fvmxl/0.0/, fvmxs/99999.0/ - data fslpl/0.0/, fslps/99999.0/ - data fabsl/0.0/, fabss/99999.0/ -! default relaxation time in hours to climatology if analysis missing - data fctsfl/99999.0/, fctsfs/99999.0/ - data fcalbl/99999.0/, fcalbs/99999.0/ - data fcsnol/99999.0/, fcsnos/99999.0/ - data fczorl/99999.0/, fczors/99999.0/ - data fcplrl/99999.0/, fcplrs/99999.0/ -! default flag to apply climatological annual cycle - data ictsfl/0/, ictsfs/1/ - data icalbl/1/, icalbs/1/ - data icalfl/1/, icalfs/1/ - data icsnol/0/, icsnos/0/ - data iczorl/1/, iczors/0/ - data icplrl/1/, icplrs/0/ -! - data ccnp/1.0/ - data ccv/1.0/, ccvb/1.0/, ccvt/1.0/ -! - data ifp/0/ -! - save ifp,fnglac,fnmxic, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnvetc,fnveta, - & fnsotc,fnsota, -!clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs - & fnvmnc,fnvmxc,fnabsc,fnslpc, - & fnvmna,fnvmxa,fnabsa,fnslpa, - & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, - & fndclm,fndanl, - & lanom, - & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, - & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs, - & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, - & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, - & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, - & fcstcl,fcstcs,fcalfl,fcalfs, -!cwu [+1l] add f()l and f()s for sih, sic and aislim, sihnew - & fsihl,fsihs,fsicl,fsics,aislim,sihnew, -!clu [+2l] add f()l and f()s for vmn, vmx, slp, abs - & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss, - & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, - & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, - & icstcl,icstcs,icalfl,icalfs, - & gausm, deads, qcmsk, - & monclm, monanl, monfcs, monmer, mondif, igrdbg, - & grboro, grbmsk, -! - & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs, - & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl, - & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots, - & csmcl -!cwu [+1l] add c()l and c()s for sih, sic - &, csihl, csihs, csicl, csics -!clu [+2l] add c()l and c()s for vmn, vmx, slp, abs - &, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps, - & cabsl, cabss - &, imsk, jmsk, slmskh, blnmsk, bltmsk - &, glacir, amxice, tsfcl0 - &, caisl, caiss, cvegs -! - lprnt = .false. - iprnt = 1 -! do i=1,len -! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) -! *,' rlo=',rlo(i) -! tem1 = abs(rla(i) - 48.75) -! tem2 = abs(rlo(i) - (-68.50)) -! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then -! lprnt = .true. -! iprnt = i -! print *,' lprnt=',lprnt,' iprnt=',iprnt -! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) -! endif -! enddo - if (ialb == 1) then - kpdabs = kpdabs_1 - kpdalb = kpdalb_1 - alblmx = .99 - albsmx = .99 - alblmn = .01 - albsmn = .01 - abslmx = 1.0 - abssmx = 1.0 - abssmn = .01 - abslmn = .01 - else - kpdabs = kpdabs_0 - kpdalb = kpdalb_0 - alblmx = .80 - albsmx = .80 - alblmn = .06 - albsmn = .06 - abslmx = .80 - abssmx = .80 - abslmn = .01 - abssmn = .01 - endif - if(ifp.eq.0) then - ifp = 1 - do k=1,lsoil - fsmcl(k) = 99999. - fsmcs(k) = 0. - fstcl(k) = 99999. - fstcs(k) = 0. - enddo -#ifdef INTERNAL_FILE_NML - read(input_nml_file, nml=namsfc) -#else -! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb - rewind(nlunit) - read (nlunit,namsfc) -#endif -! write(6,namsfc) -! - if (me .eq. 0) then - print *,'ftsfl,falbl,faisl,fsnol,fzorl=', - & ftsfl,falbl,faisl,fsnol,fzorl - print *,'fsmcl=',fsmcl(1:lsoil) - print *,'fstcl=',fstcl(1:lsoil) - print *,'ftsfs,falbs,faiss,fsnos,fzors=', - & ftsfs,falbs,faiss,fsnos,fzors - print *,'fsmcs=',fsmcs(1:lsoil) - print *,'fstcs=',fstcs(1:lsoil) - print *,' aislim=',aislim,' sihnew=',sihnew - print *,' isot=', isot,' ivegsrc=',ivegsrc - endif - - if (ivegsrc == 2) then ! sib - veg_type_landice=13 - else - veg_type_landice=15 - endif - if (isot == 0) then - soil_type_landice=9 - else - soil_type_landice=16 - endif -! - deltf = deltsfc / 24.0 -! - ctsfl=0. !... tsfc over land - if(ftsfl.ge.99999.) ctsfl=1. - if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) -! - ctsfs=0. !... tsfc over sea - if(ftsfs.ge.99999.) ctsfs=1. - if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) -! - do k=1,lsoil - csmcl(k)=0. !... soilm over land - if(fsmcl(k).ge.99999.) csmcl(k)=1. - if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) - & csmcl(k)=exp(-deltf/fsmcl(k)) - csmcs(k)=0. !... soilm over sea - if(fsmcs(k).ge.99999.) csmcs(k)=1. - if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) - & csmcs(k)=exp(-deltf/fsmcs(k)) - enddo -! - calbl=0. !... albedo over land - if(falbl.ge.99999.) calbl=1. - if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) -! - calfl=0. !... fraction field for albedo over land - if(falfl.ge.99999.) calfl=1. - if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) -! - calbs=0. !... albedo over sea - if(falbs.ge.99999.) calbs=1. - if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) -! - calfs=0. !... fraction field for albedo over sea - if(falfs.ge.99999.) calfs=1. - if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) -! - caisl=0. !... sea ice over land - if(faisl.ge.99999.) caisl=1. - if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. -! - caiss=0. !... sea ice over sea - if(faiss.ge.99999.) caiss=1. - if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. -! - csnol=0. !... snow over land - if(fsnol.ge.99999.) csnol=1. - if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) -! using the same way to bending snow as narr when fsnol is the negative value -! the magnitude of fsnol is the thread to determine the lower and upper bound -! of final swe - if(fsnol.lt.0.)csnol=fsnol -! - csnos=0. !... snow over sea - if(fsnos.ge.99999.) csnos=1. - if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) -! - czorl=0. !... roughness length over land - if(fzorl.ge.99999.) czorl=1. - if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) -! - czors=0. !... roughness length over sea - if(fzors.ge.99999.) czors=1. - if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) -! -! cplrl=0. !... plant resistance over land -! if(fplrl.ge.99999.) cplrl=1. -! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) -! -! cplrs=0. !... plant resistance over sea -! if(fplrs.ge.99999.) cplrs=1. -! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) -! - do k=1,lsoil - cstcl(k)=0. !... soilt over land - if(fstcl(k).ge.99999.) cstcl(k)=1. - if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) - & cstcl(k)=exp(-deltf/fstcl(k)) - cstcs(k)=0. !... soilt over sea - if(fstcs(k).ge.99999.) cstcs(k)=1. - if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) - & cstcs(k)=exp(-deltf/fstcs(k)) - enddo -! - cvegl=0. !... vegetation fraction over land - if(fvegl.ge.99999.) cvegl=1. - if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) -! - cvegs=0. !... vegetation fraction over sea - if(fvegs.ge.99999.) cvegs=1. - if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) -! - cvetl=0. !... vegetation type over land - if(fvetl.ge.99999.) cvetl=1. - if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) -! - cvets=0. !... vegetation type over sea - if(fvets.ge.99999.) cvets=1. - if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) -! - csotl=0. !... soil type over land - if(fsotl.ge.99999.) csotl=1. - if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) -! - csots=0. !... soil type over sea - if(fsots.ge.99999.) csots=1. - if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) - -!cwu [+16l]--------------------------------------------------------------- -! - csihl=0. !... sea ice thickness over land - if(fsihl.ge.99999.) csihl=1. - if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) -! - csihs=0. !... sea ice thickness over sea - if(fsihs.ge.99999.) csihs=1. - if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) -! - csicl=0. !... sea ice concentration over land - if(fsicl.ge.99999.) csicl=1. - if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) -! - csics=0. !... sea ice concentration over sea - if(fsics.ge.99999.) csics=1. - if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) - -!clu [+32l]--------------------------------------------------------------- -! - cvmnl=0. !... min veg cover over land - if(fvmnl.ge.99999.) cvmnl=1. - if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) -! - cvmns=0. !... min veg cover over sea - if(fvmns.ge.99999.) cvmns=1. - if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) -! - cvmxl=0. !... max veg cover over land - if(fvmxl.ge.99999.) cvmxl=1. - if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) -! - cvmxs=0. !... max veg cover over sea - if(fvmxs.ge.99999.) cvmxs=1. - if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) -! - cslpl=0. !... slope type over land - if(fslpl.ge.99999.) cslpl=1. - if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) -! - cslps=0. !... slope type over sea - if(fslps.ge.99999.) cslps=1. - if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) -! - cabsl=0. !... snow albedo over land - if(fabsl.ge.99999.) cabsl=1. - if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) -! - cabss=0. !... snow albedo over sea - if(fabss.ge.99999.) cabss=1. - if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) -!clu ---------------------------------------------------------------------- -! -! read a high resolution mask field for use in grib interpolation -! - call hmskrd(lugb,imsk,jmsk,fnmskh, - & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) -! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) -! - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil - write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh - &, ' sig1t(1)=',sig1t(1) - &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk - write(6,*) ' ' - endif -! -! reading permanent/extreme features (glacier points and maximum ice extent) -! - allocate (tsfcl0(len)) - allocate (glacir(len)) - allocate (amxice(len)) -! -! read glacier -! - kpd9 = -1 - kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, - & glacir,len,iret - &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk - &, rla, rlo, me) -! znnt=1. -! call nntprt(glacir,len,znnt) -! -! read maximum ice extent -! - kpd7 = -1 - call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, - & amxice,len,iret - &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk - &, rla, rlo, me) -! znnt=1. -! call nntprt(amxice,len,znnt) -! - crit=0.5 - call rof01(glacir,len,'ge',crit) - call rof01(amxice,len,'ge',crit) -! -! quality control max ice limit based on glacier points -! - call qcmxice(glacir,amxice,len,me) -! - endif ! first time loop finished -! - do i=1,len - sliclm(i) = 1. - snoclm(i) = 0. - icefl1(i) = .true. - enddo -! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) -! -! read climatology fields -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) 'climatology' - write(6,*) '==============' - endif -! - percrit=critp1 -! - call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me - &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) -! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) -! -! scale surface roughness and albedo to model required units -! - zsca=100. - call scale(zorclm,len,zsca) - zsca=0.01 - call scale(albclm,len,zsca) - call scale(albclm(1,2),len,zsca) - call scale(albclm(1,3),len,zsca) - call scale(albclm(1,4),len,zsca) - call scale(alfclm,len,zsca) - call scale(alfclm(1,2),len,zsca) -!clu [+4l] scale vmn, vmx, abs from percent to fraction - zsca=0.01 - call scale(vmnclm,len,zsca) - call scale(vmxclm,len,zsca) - call scale(absclm,len,zsca) - -! -! set albedo over ocean to albomx -! - call albocn(albclm,slmask,albomx,len) -! -! make sure vegetation type and soil type are non zero over land -! - call landtyp(vetclm,sotclm,slpclm,slmask,len) -! -!cwu [-1l/+1l] -!* ice concentration or ice mask (only ice mask used in the model now) -! ice concentration and ice mask (both are used in the model now) -! - if(fnaisc(1:8).ne.' ') then -!cwu [+5l/-1l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*aisclm(i) - sicclm(i) = aisclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 - call rof01(aisclm,len,'ge',crit) - elseif(fnacnc(1:8).ne.' ') then -!cwu [+4l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*acnclm(i) - sicclm(i) = acnclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - call rof01(acnclm,len,'ge',aislim) - do i=1,len - aisclm(i) = acnclm(i) - enddo - endif -! -! quality control of sea ice mask -! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmask,aisclm,len,aicice,sliclm) -! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmask=',slmask(iprnt) -! -! write(6,*) 'sliclm' -! znnt=1. -! call nntprt(sliclm,len,znnt) -! -! quality control of snow -! - call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) -! - call setzro(snoclm,epssno,len) -! -! snow cover handling (we assume climatological snow depth is available) -! quality control of snow depth (note that snow should be corrected first -! because it influences tsf -! - kqcm=1 - call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! write(6,*) 'snoclm' -! znnt=1. -! call nntprt(snoclm,len,znnt) -! -! get snow cover from snow depth array -! - if(fnscvc(1:8).eq.' ') then - call getscv(snoclm,scvclm,len) - endif -! -! set tsfc over snow to tsfsmx if greater -! - call snosfc(snoclm,tsfclm,tsfsmx,len,me) -! call snosfc(snoclm,tsfcl2,tsfsmx,len) - -! -! quality control -! - do i=1,len - icefl2(i) = sicclm(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsf2 ',tsfcl2,sliclm,snoclm,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albc ',albclm(1,kk),sliclm,snoclm,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ') then - call qcmxmn('wetc ',wetclm,sliclm,snoclm,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorc ',zorclm,sliclm,snoclm,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ') then -! call qcmxmn('plntc ',plrclm,sliclm,snoclm,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3c ',tg3clm,sliclm,snoclm,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! get soil temp and moisture (after all the qcs are completed) -! - if(fnsmcc(1:8).eq.' ') then - call getsmc(wetclm,len,lsoil,smcclm,me) - endif - call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if(fnstcc(1:8).eq.' ') then - call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) - endif - call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetc ',vetclm,sliclm,snoclm,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotc ',sotclm,sliclm,snoclm,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] --------------------------------------------------------------- - call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l] --------------------------------------------------------------- - call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxc ',vmxclm,sliclm,snoclm,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpc ',slpclm,sliclm,snoclm,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absc ',absclm,sliclm,snoclm,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ---------------------------------------------------------------------- -! -! monitoring prints -! - if (monclm) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of time and space interpolated climatology' - print *,' ' -! call count(sliclm,snoclm,len) - print *,' ' - call monitr('tsfclm',tsfclm,sliclm,snoclm,len) - call monitr('albclm',albclm(1,1),sliclm,snoclm,len) - call monitr('albclm',albclm(1,2),sliclm,snoclm,len) - call monitr('albclm',albclm(1,3),sliclm,snoclm,len) - call monitr('albclm',albclm(1,4),sliclm,snoclm,len) - call monitr('aisclm',aisclm,sliclm,snoclm,len) - call monitr('snoclm',snoclm,sliclm,snoclm,len) - call monitr('scvclm',scvclm,sliclm,snoclm,len) - call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) - call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) - call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) - call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) -!clu [+4l] add smcclm(3:4) and stcclm(3:4) - if(lsoil.gt.2) then - call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) - call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) - call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) - call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) - endif - call monitr('tg3clm',tg3clm,sliclm,snoclm,len) - call monitr('zorclm',zorclm,sliclm,snoclm,len) -! if (gaus) then - call monitr('cvaclm',cvclm ,sliclm,snoclm,len) - call monitr('cvbclm',cvbclm,sliclm,snoclm,len) - call monitr('cvtclm',cvtclm,sliclm,snoclm,len) -! endif - call monitr('sliclm',sliclm,sliclm,snoclm,len) -! call monitr('plrclm',plrclm,sliclm,snoclm,len) - call monitr('orog ',orog ,sliclm,snoclm,len) - call monitr('vegclm',vegclm,sliclm,snoclm,len) - call monitr('vetclm',vetclm,sliclm,snoclm,len) - call monitr('sotclm',sotclm,sliclm,snoclm,len) -!cwu [+2l] add sih, sic - call monitr('sihclm',sihclm,sliclm,snoclm,len) - call monitr('sicclm',sicclm,sliclm,snoclm,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnclm',vmnclm,sliclm,snoclm,len) - call monitr('vmxclm',vmxclm,sliclm,snoclm,len) - call monitr('slpclm',slpclm,sliclm,snoclm,len) - call monitr('absclm',absclm,sliclm,snoclm,len) - endif - endif -! -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) ' analysis' - write(6,*) '==============' - endif -! -! fill in analysis array with climatology before reading analysis. -! - call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, - & sihclm,sicclm, - & vmnclm,vmxclm,slpclm,absclm, - & len,lsoil) -! -! reverse scaling to match with grib analysis input -! - zsca=0.01 - call scale(zoranl,len, zsca) - zsca=100. - call scale(albanl,len,zsca) - call scale(albanl(1,2),len,zsca) - call scale(albanl(1,3),len,zsca) - call scale(albanl(1,4),len,zsca) - call scale(alfanl,len,zsca) - call scale(alfanl(1,2),len,zsca) -!clu [+4l] reverse scale for vmn, vmx, abs - zsca=100. - call scale(vmnanl,len,zsca) - call scale(vmxanl,len,zsca) - call scale(absanl,len,zsca) -! - percrit=critp2 -! -! read analysis fields -! - call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, - & vmnanl,vmxanl,slpanl,absanl, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf - &, irtvmn,irtvmx,irtslp,irtabs, - & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk - &, me, lanom) -! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) -! -! scale zor and alb to match forecast model units -! - zsca=100. - call scale(zoranl,len, zsca) - zsca=0.01 - call scale(albanl,len,zsca) - call scale(albanl(1,2),len,zsca) - call scale(albanl(1,3),len,zsca) - call scale(albanl(1,4),len,zsca) - call scale(alfanl,len,zsca) - call scale(alfanl(1,2),len,zsca) -!clu [+4] scale vmn, vmx, abs from percent to fraction - zsca=0.01 - call scale(vmnanl,len,zsca) - call scale(vmxanl,len,zsca) - call scale(absanl,len,zsca) -! -! interpolate climatology but fixing initial anomaly -! - if(fh > 0.0 .and. fntsfa(1:8) /= ' ' .and. lanom) then - call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) - endif -! -! if the tsfanl is at sea level, then bring it to the surface using -! unfiltered orography (for lakes). if the analysis is at lake surface -! as in the nst model, then this call should be removed - moorthi 09/23/2011 -! - if (use_ufo .and. .not. nst_anl) then - ztsfc = 0.0 - call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) - endif -! -! ice concentration or ice mask (only ice mask used in the model now) -! - if(fnaisa(1:8).ne.' ') then -!cwu [+5l/-1l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*aisanl(i) - sicanl(i) = aisanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 - call rof01(aisanl,len,'ge',crit) - elseif(fnacna(1:8).ne.' ') then -!cwu [+17l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*acnanl(i) - sicanl(i) = acnanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim - do i=1,len - if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then - slianl(i)=2. -! print *,'cycle - new ice form: fice=',sicanl(i) - else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then - slianl(i)=0. -! print *,'cycle - ice free: fice=',sicanl(i) - else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i)=0. - endif - enddo -! znnt=10. -! call nntprt(acnanl,len,znnt) -! if(lprnt) print *,' acnanl=',acnanl(iprnt) -! do i=1,len -! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0 -! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim -! enddo -! if(lprnt) print *,' acnanl=',acnanl(iprnt) - call rof01(acnanl,len,'ge',aislim) - do i=1,len - aisanl(i)=acnanl(i) - enddo - endif -! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmask=',slmask(iprnt) -! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmask,aisanl,len,aicice,slianl) -! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmask=',slmask(iprnt) -! -! - do k=1,lsoil - do i=1,len - if (slianl(i) .eq. 0) then - smcanl(i,k) = smcomx - stcanl(i,k) = tsfanl(i) - endif - enddo - enddo - -! write(6,*) 'slianl' -! znnt=1. -! call nntprt(slianl,len,znnt) -!cwu [+8l]---------------------------------------------------------------------- - call qcmxmn('siha ',sihanl,slianl,snoanl,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! set albedo over ocean to albomx -! - call albocn(albanl,slmask,albomx,len) -! -! quality control of snow and sea-ice -! process snow depth or snow cover -! - if(fnsnoa(1:8).ne.' ') then - call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) - if (.not.landice) then - call snodpth2(glacir,snosmx,snoanl, len, me) - endif - kqcm=1 - call snosfc(snoanl,tsfanl,tsfsmx,len,me) - call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call getscv(snoanl,scvanl,len) - call qcmxmn('sncva ',scvanl,slianl,snoanl,icefl1, - & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, - & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, - & rla,rlo,len,kqcm,percrit,lgchek,me) - else - crit=0.5 - call rof01(scvanl,len,'ge',crit) - call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) - call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, - & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, - & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call snodpth(scvanl,slianl,tsfanl,snoclm, - & glacir,snwmax,snwmin,landice,len,snoanl,me) - call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) - call snosfc(snoanl,tsfanl,tsfsmx,len,me) - call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif -! - do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 - enddo - call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('alba ',albanl(1,kk),slianl,snoanl,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then - call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zora ',zoranl,slianl,snoanl,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) then -! call qcmxmn('plna ',plranl,slianl,snoanl,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3a ',tg3anl,slianl,snoanl,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! get soil temp and moisture -! - if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then - call getsmc(wetanl,len,lsoil,smcanl,me) - endif - call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if(fnstca(1:8).eq.' ') then - call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) - endif - call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('veta ',vetanl,slianl,snoanl,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sota ',sotanl,slianl,snoanl,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l]---------------------------------------------------------------------- - call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxa ',vmxanl,slianl,snoanl,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpa ',slpanl,slianl,snoanl,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absa ',absanl,slianl,snoanl,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ---------------------------------------------------------------------------- -! -! monitoring prints -! - if (monanl) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of time and space interpolated analysis' - print *,' ' -! call count(slianl,snoanl,len) - print *,' ' - call monitr('tsfanl',tsfanl,slianl,snoanl,len) - call monitr('albanl',albanl,slianl,snoanl,len) - call monitr('aisanl',aisanl,slianl,snoanl,len) - call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('scvanl',scvanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - endif - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) -! if (gaus) then - call monitr('cvaanl',cvanl ,slianl,snoanl,len) - call monitr('cvbanl',cvbanl,slianl,snoanl,len) - call monitr('cvtanl',cvtanl,slianl,snoanl,len) -! endif - call monitr('slianl',slianl,slianl,snoanl,len) -! call monitr('plranl',plranl,slianl,snoanl,len) - call monitr('orog ',orog ,slianl,snoanl,len) - call monitr('veganl',veganl,slianl,snoanl,len) - call monitr('vetanl',vetanl,slianl,snoanl,len) - call monitr('sotanl',sotanl,slianl,snoanl,len) -!cwu [+2l] add sih, sic - call monitr('sihanl',sihanl,slianl,snoanl,len) - call monitr('sicanl',sicanl,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnanl',vmnanl,slianl,snoanl,len) - call monitr('vmxanl',vmxanl,slianl,snoanl,len) - call monitr('slpanl',slpanl,slianl,snoanl,len) - call monitr('absanl',absanl,slianl,snoanl,len) - endif - - endif -! -! read in forecast fields if needed -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) ' fcst guess' - write(6,*) '==============' - endif -! - percrit=critp2 -! - if(deads) then -! -! fill in guess array with analysis if dead start. -! - percrit=critp3 - if (me .eq. 0) write(6,*) 'this run is dead start run' - call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs,vetfcs,sotfcs,alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl,vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & len,lsoil) - if(sig1t(1).ne.0.) then - call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, - & tsfimx) - do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - else - percrit=critp2 -! -! make reverse angulation correction to tsf -! make reverse orography correction to tg3 -! - if (use_ufo) then - orogd = orog - orog_uf -! -! The tiled version of the substrate temperature is properly -! adjusted to the terrain. Only invoke when using the old -! global tg3 grib file. -! - if ( index(fntg3c, "tileX.nc") == 0) then ! global file - ztsfc = 1.0 - call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) - endif - ztsfc = 0. - call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) - else - ztsfc = 0. - call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) - endif - -!clu [+12l] -------------------------------------------------------------- -! -! compute soil moisture liquid-to-total ratio over land -! - do j=1, lsoil - do i=1, len - if(smcfcs(i,j) .ne. 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo - enddo -!clu ----------------------------------------------------------------------- -! - if(lqcbgs .and. irtacn .eq. 0) then - call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmask,albomx,len) - do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albf ',albfcs(1,kk),slifcs,snofcs,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then - call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorf ',zorfcs,slifcs,snofcs,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) -! call qcmxmn('plnf ',plrfcs,slifcs,snofcs,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3f ',tg3fcs,slifcs,snofcs,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] --------------------------------------------------------------- - call qcmxmn('sihf ',sihfcs,slifcs,snofcs,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetf ',vetfcs,slifcs,snofcs,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotf ',sotfcs,slifcs,snofcs,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) - -!clu [+16l] --------------------------------------------------------------- - call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxf ',vmxfcs,slifcs,snofcs,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpf ',slpfcs,slifcs,snofcs,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absf ',absfcs,slifcs,snofcs,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ----------------------------------------------------------------------- - endif - endif -! - if (monfcs) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of guess' - print *,' ' -! call count(slifcs,snofcs,len) - print *,' ' - call monitr('tsffcs',tsffcs,slifcs,snofcs,len) - call monitr('albfcs',albfcs,slifcs,snofcs,len) - call monitr('aisfcs',aisfcs,slifcs,snofcs,len) - call monitr('snofcs',snofcs,slifcs,snofcs,len) - call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) - call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) - call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) - call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) -!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if(lsoil.gt.2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) - endif - call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) - call monitr('zorfcs',zorfcs,slifcs,snofcs,len) -! if (gaus) then - call monitr('cvafcs',cvfcs ,slifcs,snofcs,len) - call monitr('cvbfcs',cvbfcs,slifcs,snofcs,len) - call monitr('cvtfcs',cvtfcs,slifcs,snofcs,len) -! endif - call monitr('slifcs',slifcs,slifcs,snofcs,len) -! call monitr('plrfcs',plrfcs,slifcs,snofcs,len) - call monitr('orog ',orog ,slifcs,snofcs,len) - call monitr('vegfcs',vegfcs,slifcs,snofcs,len) - call monitr('vetfcs',vetfcs,slifcs,snofcs,len) - call monitr('sotfcs',sotfcs,slifcs,snofcs,len) -!cwu [+2l] add sih, sic - call monitr('sihfcs',sihfcs,slifcs,snofcs,len) - call monitr('sicfcs',sicfcs,slifcs,snofcs,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnfcs',vmnfcs,slifcs,snofcs,len) - call monitr('vmxfcs',vmxfcs,slifcs,snofcs,len) - call monitr('slpfcs',slpfcs,slifcs,snofcs,len) - call monitr('absfcs',absfcs,slifcs,snofcs,len) - endif - endif -! -!... update annual cycle in the sst guess.. -! -! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) -! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) - - if (fh-deltsfc > -0.001 ) then - do i=1,len - if(slianl(i) == 0.0) then - tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i)) - endif - enddo - endif -! -! quality control analysis using forecast guess -! - call qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi,len,lsoil, - & snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx,me) -! -! blend climatology and predicted fields -! - if(me .eq. 0) then - write(6,*) '==============' - write(6,*) ' merging' - write(6,*) '==============' - endif -! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) -! - percrit=critp3 -! -! merge analysis and forecast. note tg3, ais are not merged -! - call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, - & irtvet,irtsot,irtalf,landice,me) - - call setzro(snoanl,epssno,len) - -! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) -! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) - -! -! new ice/melted ice -! - call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew, aislim, sihanl & sicanl - & sihnew,aislim,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albomx,snoomx,zoromx,smcomx,smcimx, -!cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified -! & tsfomn,tsfimx,albimx,zorimx,tgice, - & tsfomn,tsfimx,albimn,zorimx,tgice, - & rla,rlo,me) - -! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) -! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) -! -! set tsfc to tsnow over snow -! - call snosfc(snoanl,tsfanl,tsfsmx,len,me) -! - do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 - enddo - kqcm=0 - call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsfm ',tsfanl,slianl,snoanl,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albm ',albanl(1,kk),slianl,snoanl,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then - call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorm ',zoranl,slianl,snoanl,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) -! & then -! call qcmxmn('plntm ',plranl,slianl,snoanl,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - kqcm=1 - call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetm ',vetanl,slianl,snoanl,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotm ',sotanl,slianl,snoanl,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] add sih, sic, - call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l] add vmn, vmx, slp, abs - call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxm ',vmxanl,slianl,snoanl,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpm ',slpanl,slianl,snoanl,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absm ',absanl,slianl,snoanl,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) - -! - if(me .eq. 0) then - write(6,*) '==============' - write(6,*) 'final results' - write(6,*) '==============' - endif -! -! foreward correction to tg3 and tsf at the last stage -! -! if(lprnt) print *,' tsfbc=',tsfanl(iprnt) - if (use_ufo) then -! -! The tiled version of the substrate temperature is properly -! adjusted to the terrain. Only invoke when using the old -! global tg3 grib file. -! - if ( index(fntg3c, "tileX.nc") == 0) then ! global file - ztsfc = 1. - call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) - endif - ztsfc = 0. - call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) - else - ztsfc = 0. - call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) - endif -! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) -! -! check the final merged product -! - if (monmer) then - if(me .eq. 0) then - print *,' ' - print *,'monitor of updated surface fields' - print *,' (includes angulation correction)' - print *,' ' -! call count(slianl,snoanl,len) - print *,' ' - call monitr('tsfanl',tsfanl,slianl,snoanl,len) - call monitr('albanl',albanl,slianl,snoanl,len) - call monitr('aisanl',aisanl,slianl,snoanl,len) - call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) - endif -! if (gaus) then - call monitr('cvaanl',cvanl ,slianl,snoanl,len) - call monitr('cvbanl',cvbanl,slianl,snoanl,len) - call monitr('cvtanl',cvtanl,slianl,snoanl,len) -! endif - call monitr('slianl',slianl,slianl,snoanl,len) -! call monitr('plranl',plranl,slianl,snoanl,len) - call monitr('orog ',orog ,slianl,snoanl,len) - call monitr('cnpanl',cnpanl,slianl,snoanl,len) - call monitr('veganl',veganl,slianl,snoanl,len) - call monitr('vetanl',vetanl,slianl,snoanl,len) - call monitr('sotanl',sotanl,slianl,snoanl,len) -!cwu [+2l] add sih, sic, - call monitr('sihanl',sihanl,slianl,snoanl,len) - call monitr('sicanl',sicanl,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnanl',vmnanl,slianl,snoanl,len) - call monitr('vmxanl',vmxanl,slianl,snoanl,len) - call monitr('slpanl',slpanl,slianl,snoanl,len) - call monitr('absanl',absanl,slianl,snoanl,len) - endif - endif -! - if (mondif) then - do i=1,len - tsffcs(i) = tsfanl(i) - tsffcs(i) - snofcs(i) = snoanl(i) - snofcs(i) - tg3fcs(i) = tg3anl(i) - tg3fcs(i) - zorfcs(i) = zoranl(i) - zorfcs(i) -! plrfcs(i) = plranl(i) - plrfcs(i) -! albfcs(i) = albanl(i) - albfcs(i) - slifcs(i) = slianl(i) - slifcs(i) - aisfcs(i) = aisanl(i) - aisfcs(i) - cnpfcs(i) = cnpanl(i) - cnpfcs(i) - vegfcs(i) = veganl(i) - vegfcs(i) - vetfcs(i) = vetanl(i) - vetfcs(i) - sotfcs(i) = sotanl(i) - sotfcs(i) -!clu [+2l] add sih, sic - sihfcs(i) = sihanl(i) - sihfcs(i) - sicfcs(i) = sicanl(i) - sicfcs(i) -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmnfcs(i) - vmxfcs(i) = vmxanl(i) - vmxfcs(i) - slpfcs(i) = slpanl(i) - slpfcs(i) - absfcs(i) = absanl(i) - absfcs(i) - enddo - do j = 1,lsoil - do i = 1,len - smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) - stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) - enddo - enddo - do j = 1,4 - do i = 1,len - albfcs(i,j) = albanl(i,j) - albfcs(i,j) - enddo - enddo -! -! monitoring prints -! - if(me .eq. 0) then - print *,' ' - print *,'monitor of difference' - print *,' (includes angulation correction)' - print *,' ' - call monitr('tsfdif',tsffcs,slianl,snoanl,len) - call monitr('albdif',albfcs,slianl,snoanl,len) - call monitr('albdif1',albfcs,slianl,snoanl,len) - call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) - call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) - call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) - call monitr('aisdif',aisfcs,slianl,snoanl,len) - call monitr('snodif',snofcs,slianl,snoanl,len) - call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) -!clu [+4l] add smcfcs(3:4) and stc(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) - endif - call monitr('tg3dif',tg3fcs,slianl,snoanl,len) - call monitr('zordif',zorfcs,slianl,snoanl,len) -! if (gaus) then - call monitr('cvadif',cvfcs ,slianl,snoanl,len) - call monitr('cvbdif',cvbfcs,slianl,snoanl,len) - call monitr('cvtdif',cvtfcs,slianl,snoanl,len) -! endif - call monitr('slidif',slifcs,slianl,snoanl,len) -! call monitr('plrdif',plrfcs,slianl,snoanl,len) - call monitr('cnpdif',cnpfcs,slianl,snoanl,len) - call monitr('vegdif',vegfcs,slianl,snoanl,len) - call monitr('vetdif',vetfcs,slianl,snoanl,len) - call monitr('sotdif',sotfcs,slianl,snoanl,len) -!cwu [+2l] add sih, sic - call monitr('sihdif',sihfcs,slianl,snoanl,len) - call monitr('sicdif',sicfcs,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmndif',vmnfcs,slianl,snoanl,len) - call monitr('vmxdif',vmxfcs,slianl,snoanl,len) - call monitr('slpdif',slpfcs,slianl,snoanl,len) - call monitr('absdif',absfcs,slianl,snoanl,len) - endif - endif -! -! - do i=1,len - tsffcs(i) = tsfanl(i) - snofcs(i) = snoanl(i) - tg3fcs(i) = tg3anl(i) - zorfcs(i) = zoranl(i) -! plrfcs(i) = plranl(i) -! albfcs(i) = albanl(i) - slifcs(i) = slianl(i) - aisfcs(i) = aisanl(i) - cvfcs(i) = cvanl(i) - cvbfcs(i) = cvbanl(i) - cvtfcs(i) = cvtanl(i) - cnpfcs(i) = cnpanl(i) - vegfcs(i) = veganl(i) - vetfcs(i) = vetanl(i) - sotfcs(i) = sotanl(i) -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmxfcs(i) = vmxanl(i) - slpfcs(i) = slpanl(i) - absfcs(i) = absanl(i) - enddo - do j = 1,lsoil - do i = 1,len - smcfcs(i,j) = smcanl(i,j) - if (slifcs(i) .gt. 0.0) then - stcfcs(i,j) = stcanl(i,j) - else - stcfcs(i,j) = tsffcs(i) - endif - enddo - enddo - do j = 1,4 - do i = 1,len - albfcs(i,j) = albanl(i,j) - enddo - enddo - do j = 1,2 - do i = 1,len - alffcs(i,j) = alfanl(i,j) - enddo - enddo - -!cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points - crit=aislim - do i=1,len - sihfcs(i) = sihanl(i) - sitfcs(i) = tsffcs(i) - if (slifcs(i).ge.2.) then - if (sicfcs(i).gt.crit) then - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) - else - tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice - sihfcs(i) = sihnew - endif - endif - sicfcs(i) = sicanl(i) - enddo - do i=1,len - if (slifcs(i).lt.1.5) then - sihfcs(i) = 0. - sicfcs(i) = 0. - sitfcs(i) = tsffcs(i) - else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then - print *,'warning: check, slifcs and sicfcs', - & slifcs(i),sicfcs(i) - endif - enddo - -! -! ensure the consistency between slc and smc -! - do k=1, lsoil - fixratio(k) = .false. - if (fsmcl(k).lt.99999.) fixratio(k) = .true. - enddo - - if(me .eq. 0) then - print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) - endif - - do k=1, lsoil - if(fixratio(k)) then - do i = 1, len - if(swratio(i,k) .eq. -999.) then - slcfcs(i,k) = smcfcs(i,k) - else - slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) - endif - if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. - enddo - endif - enddo -! set liquid soil moisture to a flag value of 1.0 - if (landice) then - do i = 1, len - if (slifcs(i) .eq. 1.0 .and. - & nint(vetfcs(i)) == veg_type_landice) then - do k=1, lsoil - slcfcs(i,k) = 1.0 - enddo - endif - enddo - end if -! -! ensure the consistency between snwdph and sheleg -! - if(fsnol .lt. 99999.) then - if(me .eq. 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) - enddo - endif - -! sea ice model only uses the liquid equivalent depth. -! so update the physical depth only for display purposes. -! use the same 3:1 ratio used by ice model. - - do i = 1, len - if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) - enddo - - do i = 1, len - if(slifcs(i).eq.1.) then - if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then - print *,'dbgx --scale snwdph from sheleg', - + i, swdfcs(i), snofcs(i) - swdfcs(i) = 10.* snofcs(i) - endif - endif - enddo -! landice mods - impose same minimum snow depth at -! landice as noah lsm. also ensure -! lower thermal boundary condition -! and skin t is no warmer than freezing -! after adjustment to terrain. - if (landice) then - do i = 1, len - if (slifcs(i) .eq. 1.0 .and. - & nint(vetfcs(i)) == veg_type_landice) then - snofcs(i) = max(snofcs(i),100.0) ! in mm - swdfcs(i) = max(swdfcs(i),1000.0) ! in mm - tg3fcs(i) = min(tg3fcs(i),273.15) - tsffcs(i) = min(tsffcs(i),273.15) - endif - enddo - end if -! -! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) - return - end subroutine sfccycle - subroutine count(slimsk,sno,ijmax) - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5 - integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij -! - real (kind=kind_io8) slimsk(1),sno(1) -! -! count number of points for the four surface conditions -! - l0 = 0 - l1 = 0 - l2 = 0 - l3 = 0 - l4 = 0 - do ij=1,ijmax - if(slimsk(ij).eq.0.) l1 = l1 + 1 - if(slimsk(ij).eq.1. .and. sno(ij).le.0.) l0 = l0 + 1 - if(slimsk(ij).eq.2. .and. sno(ij).le.0.) l2 = l2 + 1 - if(slimsk(ij).eq.1. .and. sno(ij).gt.0.) l3 = l3 + 1 - if(slimsk(ij).eq.2. .and. sno(ij).gt.0.) l4 = l4 + 1 - enddo - l5 = l0 + l3 - l6 = l2 + l4 - l7 = l1 + l6 - l8 = l1 + l5 + l6 - rl0 = float(l0) / float(l8)*100. - rl3 = float(l3) / float(l8)*100. - rl1 = float(l1) / float(l8)*100. - rl2 = float(l2) / float(l8)*100. - rl4 = float(l4) / float(l8)*100. - rl5 = float(l5) / float(l8)*100. - rl6 = float(l6) / float(l8)*100. - rl7 = float(l7) / float(l8)*100. - print *,'1) no. of not snow-covered land points ',l0,' ',rl0,' ' - print *,'2) no. of snow covered land points ',l3,' ',rl3,' ' - print *,'3) no. of open sea points ',l1,' ',rl1,' ' - print *,'4) no. of not snow-covered seaice points ',l2,' ',rl2,' ' - print *,'5) no. of snow covered sea ice points ',l4,' ',rl4,' ' - print *,' ' - print *,'6) no. of land points ',l5,' ',rl5,' ' - print *,'7) no. sea points (including sea ice) ',l7,' ',rl7,' ' - print *,' (no. of sea ice points) (',l6,')',' ',rl6,' ' - print *,' ' - print *,'9) no. of total grid points ',l8 -! print *,' ' -! print *,' ' - -! -! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) - return - end - subroutine monitr(lfld,fld,slimsk,sno,ijmax) - use machine , only : kind_io8,kind_io4 - implicit none - integer ij,n,ijmax -! - real (kind=kind_io8) fld(ijmax), slimsk(ijmax),sno(ijmax) -! - real (kind=kind_io8) rmax(5),rmin(5) - character(len=*) lfld -! -! find max/min -! - do n=1,5 - rmax(n) = -9.e20 - rmin(n) = 9.e20 - enddo -! - do ij=1,ijmax - if(slimsk(ij).eq.0.) then - rmax(1) = max(rmax(1), fld(ij)) - rmin(1) = min(rmin(1), fld(ij)) - elseif(slimsk(ij).eq.1.) then - if(sno(ij).le.0.) then - rmax(2) = max(rmax(2), fld(ij)) - rmin(2) = min(rmin(2), fld(ij)) - else - rmax(4) = max(rmax(4), fld(ij)) - rmin(4) = min(rmin(4), fld(ij)) - endif - else - if(sno(ij).le.0.) then - rmax(3) = max(rmax(3), fld(ij)) - rmin(3) = min(rmin(3), fld(ij)) - else - rmax(5) = max(rmax(5), fld(ij)) - rmin(5) = min(rmin(5), fld(ij)) - endif - endif - enddo -! - print 100,lfld - print 101,rmax(1),rmin(1) - print 102,rmax(2),rmin(2), rmax(4), rmin(4) - print 103,rmax(3),rmin(3), rmax(5), rmin(5) -! -! print 102,rmax(2),rmin(2) -! print 103,rmax(3),rmin(3) -! print 104,rmax(4),rmin(4) -! print 105,rmax(5),rmin(5) - 100 format('0 *** ',a8,' ***') - 101 format(' open sea ......... max=',e12.4,' min=',e12.4) - 102 format(' land nosnow/snow .. max=',e12.4,' min=',e12.4 - &, ' max=',e12.4,' min=',e12.4) - 103 format(' seaice nosnow/snow max=',e12.4,' min=',e12.4 - &, ' max=',e12.4,' min=',e12.4) -! -! 100 format('0',2x,'*** ',a8,' ***') -! 102 format(2x,' land without snow ..... max=',e12.4,' min=',e12.4) -! 103 format(2x,' seaice without snow ... max=',e12.4,' min=',e12.4) -! 104 format(2x,' land with snow ........ max=',e12.4,' min=',e12.4) -! 105 format(2x,' sea ice with snow ..... max=',e12.4,' min=',e12.4) -! - return - end - subroutine dayoyr(iyr,imo,idy,ldy) - implicit none - integer ldy,i,idy,iyr,imo -! -! this routine figures out the day of the year given imo and idy -! - integer month(13) - data month/0,31,28,31,30,31,30,31,31,30,31,30,31/ - if(mod(iyr,4).eq.0) month(3) = 29 - ldy = idy - do i = 1, imo - ldy = ldy + month(i) - enddo - return - end - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, - & kpds5,slmskh,gausm,blnmsk,bltmsk,me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata, xdata, ydata - implicit none - integer kpds5,me,i,imsk,jmsk,lugb -! - character*500 fnmskh -! - real (kind=kind_io8) slmskh(mdata) - logical gausm - real (kind=kind_io8) blnmsk,bltmsk -! - imsk = xdata - jmsk = ydata - - if (me .eq. 0) then - write(6,*)' imsk=',imsk,' jmsk=',jmsk,' xdata=',xdata,' ydata=' - &, ydata - endif - - call fixrdg(lugb,imsk,jmsk,fnmskh, - & kpds5,slmskh,gausm,blnmsk,bltmsk,me) - -! print *,'in sfc_sub, aft fixrdg,slmskh=',maxval(slmskh), -! & minval(slmskh),'mdata=',mdata,'imsk*jmsk=',imsk*jmsk - - do i=1,imsk*jmsk - slmskh(i) = nint(slmskh(i)) - enddo -! - return - end - subroutine fixrdg(lugb,idim,jdim,fngrib, - & kpds5,gdata,gaus,blno,blto,me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb, - & iret, me,kpds5,kdata,i,w3kindreal,w3kindint -! - character*(*) fngrib -! - real (kind=kind_io8) gdata(idim*jdim) - logical gaus - real (kind=kind_io8) blno,blto - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) -! - logical*1, allocatable :: lbms(:) -! - integer kpds(200),kgds(200) - integer jpds(200),jgds(200), kpds0(200) -! - allocate(data8(1:idim*jdim)) - allocate(lbms(1:mdata)) - kpds = 0 - kgds = 0 - jpds = 0 - jgds = 0 - kpds0 = 0 -! -! if(me .eq. 0) then -! write(6,*) ' ' -! write(6,*) '************************************************' -! endif -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb - lugi = 0 - lskip = -1 - n = 0 - jpds = -1 - jgds = -1 - jpds(5) = kpds5 - kpds = jpds -! - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) -! - if(me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif -! - kpds0=jpds - kpds0(4)=-1 - kpds0(18)=-1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if (iret == 99) write(6,*) ' field not found.' - call abort - endif -! - jpds = kpds0 - lskip = -1 - kdata=idim*jdim - call w3kind(w3kindreal,w3kindint) - if (w3kindreal == 8) then - call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - else if (w3kindreal == 4) then - allocate(data4(1:idim*jdim)) - call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - else - write(0,*)' Invalid w3kindreal --- aborting' - call abort - endif -! - if(jret == 0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - idim = kgds(2) - jdim = kgds(3) - gaus = kgds(1).eq.4 - blno = kgds(5)*1.d-3 - blto = kgds(4)*1.d-3 - gdata(1:idim*jdim) = data8(1:idim*jdim) - if (me == 0) write(6,*) 'idim,jdim=',idim,jdim - &, ' gaus=',gaus,' blno=',blno,' blto=',blto - else - if (me ==. 0) write(6,*) 'idim,jdim=',idim,jdim - &, ' gaus=',gaus,' blno=',blno,' blto=',blto - write(6,*) ' error in getgb : jret=',jret - write(6,*) ' kpds(13)=',kpds(13),' kpds(15)=',kpds(15) - call abort - endif -! - deallocate(data8) - deallocate(lbms) - return - end - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr - &, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer j,me,kgds11 - real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat -! -! get area of the grib record -! - integer kgds(22) - logical ijordr -! - if (me .eq. 0) then - write(6,*) ' kgds( 1-12)=',(kgds(j),j= 1,12) - write(6,*) ' kgds(13-22)=',(kgds(j),j=13,22) - endif -! - if(kgds(1).eq.0) then ! lat/lon grid -! - if (me .eq. 0) write(6,*) 'lat/lon grid' - dlat = float(kgds(10)) * 0.001 - dlon = float(kgds( 9)) * 0.001 - f0lon = float(kgds(5)) * 0.001 - f0lat = float(kgds(4)) * 0.001 - kgds11 = kgds(11) - if(kgds11.ge.128) then - wlon = f0lon - dlon*(kgds(2)-1) - elon = f0lon - if(dlon*kgds(2).gt.359.99) then - wlon =f0lon - dlon*kgds(2) - endif - dlon = -dlon - kgds11 = kgds11 - 128 - else - wlon = f0lon - elon = f0lon + dlon*(kgds(2)-1) - if(dlon*kgds(2).gt.359.99) then - elon = f0lon + dlon*kgds(2) - endif - endif - if(kgds11.ge.64) then - rnlat = f0lat + dlat*(kgds(3)-1) - rslat = f0lat - kgds11 = kgds11 - 64 - else - rnlat = f0lat - rslat = f0lat - dlat*(kgds(3)-1) - dlat = -dlat - endif - if(kgds11.ge.32) then - ijordr = .false. - else - ijordr = .true. - endif - - if(wlon.gt.180.) wlon = wlon - 360. - if(elon.gt.180.) elon = elon - 360. - wlon = nint(wlon*1000.) * 0.001 - elon = nint(elon*1000.) * 0.001 - rslat = nint(rslat*1000.) * 0.001 - rnlat = nint(rnlat*1000.) * 0.001 - return -! - elseif(kgds(1).eq.1) then ! mercator projection - write(6,*) 'mercator grid' - write(6,*) 'cannot process' - call abort -! - elseif(kgds(1).eq.2) then ! gnomonic projection - write(6,*) 'gnomonic grid' - write(6,*) 'error!! gnomonic projection not coded' - call abort -! - elseif(kgds(1).eq.3) then ! lambert conformal - write(6,*) 'lambert conformal' - write(6,*) 'cannot process' - call abort - elseif(kgds(1).eq.4) then ! gaussian grid -! - if (me .eq. 0) write(6,*) 'gaussian grid' - dlat = 99. - dlon = float(kgds( 9)) / 1000.0 - f0lon = float(kgds(5)) / 1000.0 - f0lat = 99. - kgds11 = kgds(11) - if(kgds11.ge.128) then - wlon = f0lon - elon = f0lon - if(dlon*kgds(2).gt.359.99) then - wlon = f0lon - dlon*kgds(2) - endif - dlon = -dlon - kgds11 = kgds11-128 - else - wlon = f0lon - elon = f0lon + dlon*(kgds(2)-1) - if(dlon*kgds(2).gt.359.99) then - elon = f0lon + dlon*kgds(2) - endif - endif - if(kgds11.ge.64) then - rnlat = 99. - rslat = 99. - kgds11 = kgds11 - 64 - else - rnlat = 99. - rslat = 99. - dlat = -99. - endif - if(kgds11.ge.32) then - ijordr = .false. - else - ijordr = .true. - endif - return -! - elseif(kgds(1).eq.5) then ! polar strereographic - write(6,*) 'polar stereographic grid' - write(6,*) 'cannot process' - call abort - return -! - elseif(kgds(1).eq.13) then ! oblique lambert conformal - write(6,*) 'oblique lambert conformal grid' - write(6,*) 'cannot process' - call abort -! - elseif(kgds(1).eq.50) then ! spherical coefficient - write(6,*) 'spherical coefficient' - write(6,*) 'cannot process' - call abort - return -! - elseif(kgds(1).eq.90) then ! space view perspective -! (orthographic grid) - write(6,*) 'space view perspective grid' - write(6,*) 'cannot process' - call abort - return -! - else ! unknown projection. abort. - write(6,*) 'error!! unknown map projection' - write(6,*) 'kgds(1)=',kgds(1) - print *,'error!! unknown map projection' - print *,'kgds(1)=',kgds(1) - call abort - endif -! - return - end - subroutine subst(data,imax,jmax,dlon,dlat,ijordr) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,ii,jj,jmax,imax,iret - real (kind=kind_io8) dlat,dlon -! - logical ijordr -! - real (kind=kind_io8) data(imax,jmax) - real (kind=kind_io8), allocatable :: work(:,:) -! - if(.not.ijordr.or. - & (ijordr.and.(dlat.gt.0..or.dlon.lt.0.))) then - allocate (work(imax,jmax)) - - if(.not.ijordr) then - do j=1,jmax - do i=1,imax - work(i,j) = data(j,i) - enddo - enddo - else - do j=1,jmax - do i=1,imax - work(i,j) = data(i,j) - enddo - enddo - endif - if (dlat > 0.0) then - if (dlon > 0.0) then - do j=1,jmax - jj = jmax - j + 1 - do i=1,imax - data(i,jj) = work(i,j) - enddo - enddo - else - do i=1,imax - data(imax-i+1,jj) = work(i,j) - enddo - endif - else - if (dlon > 0.0) then - do j=1,jmax - do i=1,imax - data(i,j) = work(i,j) - enddo - enddo - else - do j=1,jmax - do i=1,imax - data(imax-i+1,j) = work(i,j) - enddo - enddo - endif - endif - deallocate (work, stat=iret) - endif - return - end - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, - & gauout,len,lmask,rslmsk,slmask - &, outlat, outlon,me) - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, - & wi1j2,wi2j1,rlat,rlon,aphi, - & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, - & ii,i1,i2,kmami,it - integer nx,kxs,kxt - integer, allocatable, save :: imxnx(:) - integer, allocatable :: ifill(:) -! -! interpolation from lat/lon or gaussian grid to other lat/lon grid -! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), - & slmask(len) - real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) -! - real (kind=kind_io8) rinlat(jmxin), rinlon(imxin) - integer iindx1(len), iindx2(len) - integer jindx1(len), jindx2(len) - real (kind=kind_io8) ddx(len), ddy(len), wrk(len) -! - logical lmask -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, len_thread, i1_t, i2_t - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - if (.not. allocated(imxnx)) allocate (imxnx(num_threads)) - endif -! -! if (me == 0) print *,' num_threads =',num_threads,' me=',me -! -! if(me .eq. 0) then -! print *,'rlon=',rlon,' me=',me -! print *,'rlat=',rlat,' me=',me,' imxin=',imxin,' jmxin=',jmxin -! endif -! -! do j=1,jmxin -! if(rlat.gt.0.) then -! rinlat(j) = rlat - float(j-1)*dlain -! else -! rinlat(j) = rlat + float(j-1)*dlain -! endif -! enddo -! -! if (me .eq. 0) then -! print *,'rinlat=' -! print *,(rinlat(j),j=1,jmxin) -! print *,'rinlon=' -! print *,(rinlon(i),i=1,imxin) -! -! print *,'outlat=' -! print *,(outlat(j),j=1,len) -! print *,(outlon(j),j=1,len) -! endif -! -! do i=1,imxin -! rinlon(i) = rlon + float(i-1)*dloin -! enddo -! -! print *,'rinlon=' -! print *,(rinlon(i),i=1,imxin) -! - len_thread_m = (len+num_threads-1) / num_threads - - if (inttyp /=1) allocate (ifill(num_threads)) -! -!$omp parallel do default(none) -!$omp+private(i1_t,i2_t,len_thread,it,i,ii,i1,i2) -!$omp+private(j,j1,j2,jq,ix,jy,nx,kxs,kxt,kmami) -!$omp+private(alamd,denom,rnume,aphi,x,y,wsum,wsumiv,sum1,sum2) -!$omp+private(sum3,sum4,wi1j1,wi2j1,wi1j2,wi2j2,wei1,wei2,wei3,wei4) -!$omp+private(sumn,sums) -!$omp+shared(imxin,jmxin,ifill) -!$omp+shared(outlon,outlat,wrk,iindx1,rinlon,jindx1,rinlat,ddx,ddy) -!$omp+shared(rlon,rlat,regin,gauout,imxnx) -!$omp+private(tem) -!$omp+shared(num_threads,len_thread_m,len,lmask,iindx2,jindx2,rslmsk) -!$omp+shared(inttyp,me,slmask) -! - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) - len_thread = i2_t-i1_t+1 -! -! find i-index for interpolation -! - do i=i1_t, i2_t - alamd = outlon(i) - if (alamd .lt. rlon) alamd = alamd + 360.0 - if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 - wrk(i) = alamd - iindx1(i) = imxin - enddo - do i=i1_t,i2_t - do ii=1,imxin - if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii - enddo - enddo - do i=i1_t,i2_t - i1 = iindx1(i) - if (i1 .lt. 1) i1 = imxin - i2 = i1 + 1 - if (i2 .gt. imxin) i2 = 1 - iindx1(i) = i1 - iindx2(i) = i2 - denom = rinlon(i2) - rinlon(i1) - if(denom.lt.0.) denom = denom + 360. - rnume = wrk(i) - rinlon(i1) - if(rnume.lt.0.) rnume = rnume + 360. - ddx(i) = rnume / denom - enddo -! -! find j-index for interplation -! - if(rlat.gt.0.) then - do j=i1_t,i2_t - jindx1(j)=0 - enddo - do jx=1,jmxin - do j=i1_t,i2_t - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=i1_t,i2_t - jq = jindx1(j) - aphi=outlat(j) - if(jq.ge.1 .and. jq .lt. jmxin) then - j2=jq+1 - j1=jq - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 0) then - j2=1 - j1=1 - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - else - do j=i1_t,i2_t - jindx1(j) = jmxin+1 - enddo - do jx=jmxin,1,-1 - do j=i1_t,i2_t - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=i1_t,i2_t - jq = jindx1(j) - aphi=outlat(j) - if(jq.gt.1 .and. jq .le. jmxin) then - j2=jq - j1=jq-1 - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 1) then - j2=1 - j1=1 - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - endif -! -! if (me .eq. 0 .and. inttyp .eq. 1) then -! print *,'la2ga' -! print *,'iindx1' -! print *,(iindx1(n),n=1,len) -! print *,'iindx2' -! print *,(iindx2(n),n=1,len) -! print *,'jindx1' -! print *,(jindx1(n),n=1,len) -! print *,'jindx2' -! print *,(jindx2(n),n=1,len) -! print *,'ddy' -! print *,(ddy(n),n=1,len) -! print *,'ddx' -! print *,(ddx(n),n=1,len) -! endif -! - sum1 = 0. - sum2 = 0. - sum3 = 0. - sum4 = 0. - if (lmask) then - wei1 = 0. - wei2 = 0. - wei3 = 0. - wei4 = 0. - do i=1,imxin - sum1 = sum1 + regin(i,1) * rslmsk(i,1) - sum2 = sum2 + regin(i,jmxin) * rslmsk(i,jmxin) - wei1 = wei1 + rslmsk(i,1) - wei2 = wei2 + rslmsk(i,jmxin) -! - sum3 = sum3 + regin(i,1) * (1.0-rslmsk(i,1)) - sum4 = sum4 + regin(i,jmxin) * (1.0-rslmsk(i,jmxin)) - wei3 = wei3 + (1.0-rslmsk(i,1)) - wei4 = wei4 + (1.0-rslmsk(i,jmxin)) - enddo -! - if(wei1.gt.0.) then - sum1 = sum1 / wei1 - else - sum1 = 0. - endif - if(wei2.gt.0.) then - sum2 = sum2 / wei2 - else - sum2 = 0. - endif - if(wei3.gt.0.) then - sum3 = sum3 / wei3 - else - sum3 = 0. - endif - if(wei4.gt.0.) then - sum4 = sum4 / wei4 - else - sum4 = 0. - endif - else - do i=1,imxin - sum1 = sum1 + regin(i,1) - sum2 = sum2 + regin(i,jmxin) - enddo - sum1 = sum1 / imxin - sum2 = sum2 / imxin - sum3 = sum1 - sum4 = sum2 - endif -! -! print *,' sum1=',sum1,' sum2=',sum2 -! *,' sum3=',sum3,' sum4=',sum4 -! print *,' rslmsk=',(rslmsk(i,1),i=1,imxin) -! print *,' slmask=',(slmask(i),i=1,imxout) -! *,' j1=',jindx1(1),' j2=',jindx2(1) -! -! -! inttyp=1 take the closest point value -! - if(inttyp.eq.1) then - - do i=i1_t,i2_t - jy = jindx1(i) - if(ddy(i) .ge. 0.5) jy = jindx2(i) - ix = iindx1(i) - if(ddx(i) .ge. 0.5) ix = iindx2(i) -! -!cggg start -! - if (.not. lmask) then - - gauout(i) = regin(ix,jy) - - else - - if(slmask(i).eq.rslmsk(ix,jy)) then - - gauout(i) = regin(ix,jy) - - else - - i1 = ix - j1 = jy - -! spiral around until matching mask is found. - do nx=1,jmxin*imxin/2 - kxs=sqrt(4*nx-2.5) - kxt=nx-int(kxs**2/4+1) - select case(mod(kxs,4)) - case(1) - ix=i1-kxs/4+kxt - jx=j1-kxs/4 - case(2) - ix=i1+1+kxs/4 - jx=j1-kxs/4+kxt - case(3) - ix=i1+1+kxs/4-kxt - jx=j1+1+kxs/4 - case default - ix=i1-kxs/4 - jx=j1+kxs/4-kxt - end select - if(jx.lt.1) then - ix=ix+imxin/2 - jx=2-jx - elseif(jx.gt.jmxin) then - ix=ix+imxin/2 - jx=2*jmxin-jx - endif - ix=modulo(ix-1,imxin)+1 - if(slmask(i).eq.rslmsk(ix,jx)) then - gauout(i) = regin(ix,jx) - go to 81 - endif - enddo - -!cggg here, set the gauout value to be 0, and let's sarah's land -!cggg routine assign a default. - - if (num_threads == 1) then - print*,'no matching mask found ',i,i1,j1,ix,jx - print*,'set to default value.' - endif - gauout(i) = 0.0 - - - 81 continue - - end if - - end if - -!cggg end - - enddo -! kmami=1 -! if (me == 0 .and. num_threads == 1) -! & call maxmin(gauout(i1_t),len_thread,kmami) - else ! nearest neighbor interpolation - -! -! quasi-bilinear interpolation -! - ifill(it) = 0 - imxnx(it) = 0 - do i=i1_t,i2_t - y = ddy(i) - j1 = jindx1(i) - j2 = jindx2(i) - x = ddx(i) - i1 = iindx1(i) - i2 = iindx2(i) -! - wi1j1 = (1.-x) * (1.-y) - wi2j1 = x *( 1.-y) - wi1j2 = (1.-x) * y - wi2j2 = x * y -! - tem = 4.*slmask(i) - rslmsk(i1,j1) - rslmsk(i2,j1) - & - rslmsk(i1,j2) - rslmsk(i2,j2) - if(lmask .and. abs(tem) .gt. 0.01) then - if(slmask(i).eq.1.) then - wi1j1 = wi1j1 * rslmsk(i1,j1) - wi2j1 = wi2j1 * rslmsk(i2,j1) - wi1j2 = wi1j2 * rslmsk(i1,j2) - wi2j2 = wi2j2 * rslmsk(i2,j2) - else - wi1j1 = wi1j1 * (1.0-rslmsk(i1,j1)) - wi2j1 = wi2j1 * (1.0-rslmsk(i2,j1)) - wi1j2 = wi1j2 * (1.0-rslmsk(i1,j2)) - wi2j2 = wi2j2 * (1.0-rslmsk(i2,j2)) - endif - endif -! - wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 - wrk(i) = wsum - if(wsum.ne.0.) then - wsumiv = 1./wsum -! - if(j1.ne.j2) then - gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + - & wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) - & *wsumiv - else -! - if (rlat .gt. 0.0) then - if (slmask(i) .eq. 1.0) then - sumn = sum1 - sums = sum2 - else - sumn = sum3 - sums = sum4 - endif - if( j1 .eq. 1) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + - & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) - & * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ - & wi1j2*sums +wi2j2*sums ) - & * wsumiv - endif -! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn -! & ,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2 -! & ,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv - else - if (slmask(i) .eq. 1.0) then - sums = sum1 - sumn = sum2 - else - sums = sum3 - sumn = sum4 - endif - if( j1 .eq. 1) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ - & wi1j2*sums +wi2j2*sums ) - & * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + - & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) - & * wsumiv - endif - endif - endif ! if j1 .ne. j2 - endif - enddo - do i=i1_t,i2_t - j1 = jindx1(i) - j2 = jindx2(i) - i1 = iindx1(i) - i2 = iindx2(i) - if(wrk(i) .eq. 0.0) then - if(.not.lmask) then - if (num_threads == 1) - & write(6,*) ' la2ga called with lmask=.true. but bad', - & ' rslmsk or slmask given' - call abort - endif - ifill(it) = ifill(it) + 1 - if(ifill(it) <= 2 ) then - if (me == 0 .and. num_threads == 1) then - write(6,*) 'i1,i2,j1,j2=',i1,i2,j1,j2 - write(6,*) 'rslmsk=',rslmsk(i1,j1),rslmsk(i1,j2), - & rslmsk(i2,j1),rslmsk(i2,j2) -! write(6,*) 'i,j=',i,j,' slmask(i)=',slmask(i) - write(6,*) 'i=',i,' slmask(i)=',slmask(i) - &, ' outlon=',outlon(i),' outlat=',outlat(i) - endif - endif -! spiral around until matching mask is found. - do nx=1,jmxin*imxin/2 - kxs=sqrt(4*nx-2.5) - kxt=nx-int(kxs**2/4+1) - select case(mod(kxs,4)) - case(1) - ix=i1-kxs/4+kxt - jx=j1-kxs/4 - case(2) - ix=i1+1+kxs/4 - jx=j1-kxs/4+kxt - case(3) - ix=i1+1+kxs/4-kxt - jx=j1+1+kxs/4 - case default - ix=i1-kxs/4 - jx=j1+kxs/4-kxt - end select - if(jx.lt.1) then - ix=ix+imxin/2 - jx=2-jx - elseif(jx.gt.jmxin) then - ix=ix+imxin/2 - jx=2*jmxin-jx - endif - ix=modulo(ix-1,imxin)+1 - if(slmask(i).eq.rslmsk(ix,jx)) then - gauout(i) = regin(ix,jx) - imxnx(it) = max(imxnx(it),nx) - go to 71 - endif - enddo -! - if (num_threads == 1) then - write(6,*) ' error!!! no filling value found in la2ga' -! write(6,*) ' i ix jx slmask(i) rslmsk ', -! & i,ix,jx,slmask(i),rslmsk(ix,jx) - endif - call abort -! - 71 continue - endif -! - enddo - endif - enddo ! end of threaded loop ................... -!$omp end parallel do -! - if(inttyp /= 1)then - ifills = 0 - do it=1,num_threads - ifills = ifills + ifill(it) - enddo - - if(ifills.gt.1) then - if (me .eq. 0) then - write(6,*) ' unable to interpolate. filled with nearest', - & ' point value at ',ifills,' points' -! & ' point value at ',ifills,' points imxnx=',imxnx(:) - endif - endif - deallocate (ifill) - endif -! -! kmami = 1 -! if (me == 0) call maxmin(gauout,len,kmami) -! - return - end subroutine la2ga - subroutine maxmin(f,imax,kmax) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,iimin,iimax,kmax,imax,k - real (kind=kind_io8) fmin,fmax -! - real (kind=kind_io8) f(imax,kmax) -! - do k=1,kmax -! - fmax = f(1,k) - fmin = f(1,k) -! - do i=1,imax - if(fmax.le.f(i,k)) then - fmax = f(i,k) - iimax = i - endif - if(fmin.ge.f(i,k)) then - fmin = f(i,k) - iimin = i - endif - enddo -! -! write(6,100) k,fmax,iimax,fmin,iimin -! 100 format(2x,'level=',i2,' max=',e11.4,' at i=',i7, -! & ' min=',e11.4,' at i=',i7) -! - enddo -! - return - end - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, - & aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, - & aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, -!cwu [+1l] add ()clm for sih, sic - & sihclm,sicclm, -!clu [+1l] add ()clm for vmn, vmx, slp, abs - & vmnclm,vmxclm,slpclm,absclm, - & len,lsoil) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil -! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), - & snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),scvanl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), - & snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) -!cwu [+1l] add ()clm for sih, sic - &, sihclm(len),sicclm(len) -!clu [+1l] add ()clm for vmn, vmx, slp, abs - &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) -! - do i=1,len - tsfanl(i) = tsfclm(i) ! tsf at t - tsfan2(i) = tsfcl2(i) ! tsf at t-deltsfc - wetanl(i) = wetclm(i) ! soil wetness - snoanl(i) = snoclm(i) ! snow - scvanl(i) = scvclm(i) ! snow cover - aisanl(i) = aisclm(i) ! seaice - slianl(i) = sliclm(i) ! land/sea/snow mask - zoranl(i) = zorclm(i) ! surface roughness -! plranl(i) = plrclm(i) ! maximum stomatal resistance - tg3anl(i) = tg3clm(i) ! deep soil temperature - cnpanl(i) = cnpclm(i) ! canopy water content - veganl(i) = vegclm(i) ! vegetation cover - vetanl(i) = vetclm(i) ! vegetation type - sotanl(i) = sotclm(i) ! soil type - cvanl(i) = cvclm(i) ! cv - cvbanl(i) = cvbclm(i) ! cvb - cvtanl(i) = cvtclm(i) ! cvt -!cwu [+4l] add sih, sic - sihanl(i) = sihclm(i) ! sea ice thickness - sicanl(i) = sicclm(i) ! sea ice concentration -!clu [+4l] add vmn, vmx, slp, abs - vmnanl(i) = vmnclm(i) ! min vegetation cover - vmxanl(i) = vmxclm(i) ! max vegetation cover - slpanl(i) = slpclm(i) ! slope type - absanl(i) = absclm(i) ! max snow albedo - enddo -! - do j=1,lsoil - do i=1,len - smcanl(i,j) = smcclm(i,j) ! layer soil wetness - stcanl(i,j) = stcclm(i,j) ! soil temperature - enddo - enddo - do j=1,4 - do i=1,len - albanl(i,j) = albclm(i,j) ! albedo - enddo - enddo - do j=1,2 - do i=1,len - alfanl(i,j) = alfclm(i,j) ! vegetation fraction for albedo - enddo - enddo -! - return - end - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, -!clu [+1l] add fn()a for vmn, vmx, slp, abs - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, -!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, -!cggg snow mods end - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kprvet,kpdsot,kpdalf, -!clu [+1l] add kpd() for vmn, vmx, slp, abs - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf -!clu [+1l] add irt() for vmn, vmx, slp, abs - &, irtvmn,irtvmx,irtslp,irtabs - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me, lanom) - use machine , only : kind_io8,kind_io4 - implicit none - logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, -!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, -!cggg snow mods end - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j -!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs - &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs - real (kind=kind_io8) blto,blno,fh -! - real (kind=kind_io8) slmask(len) - real (kind=kind_io8) slmskh(imsk,jmsk) - real (kind=kind_io8) outlat(len), outlon(len) - integer kpdalb(4), kpdalf(2) -!cggg snow mods start - integer kpds(1000),kgds(1000),jpds(1000),jgds(1000) - integer lugi, lskip, lgrib, ndata -!cggg snow mods end -! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota -!clu [+1l] add fn()a for vmn, vmx, slp, abs - &, fnvmna,fnvmxa,fnslpa,fnabsa - - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & slianl(len), scvanl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), - & smcanl(len,lsoil), stcanl(len,lsoil), - & tsfan0(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - logical gaus -! -! tsf -! - irttsf = 1 - if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmask, - & iy,im,id,ih,fh,tsfanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irttsf = iret - if(iret == 1) then - write(6,*) 't surface analysis read error' - call abort - elseif(iret == -1) then - if (me == 0) then - print *,'old t surface analysis provided, indicating proper' - &, ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me == 0) print *,'t surface analysis provided.' - endif - else - if (me == 0) then -! print *,'************************************************' - print *,'no tsf analysis available. climatology used' - endif - endif -! -! tsf0 -! - if(fntsfa(1:8).ne.' ' .and. lanom) then - call fixrda(lugb,fntsfa,kpdtsf,slmask, - & iy,im,id,ih,0.,tsfan0,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - if(iret == 1) then - write(6,*) 't surface at ft=0 analysis read error' - call abort - elseif(iret == -1) then - if (me == 0) then - write(6,*) 'could not find t surface analysis at ft=0' - endif - call abort - else - print *,'t surface analysis at ft=0 found.' - endif - else - do i=1,len - tsfan0(i)=-999.9 - enddo - endif -! -! albedo -! - irtalb=0 - if(fnalba(1:8).ne.' ') then - do kk = 1, 4 - call fixrda(lugb,fnalba,kpdalb(kk),slmask, - & iy,im,id,ih,fh,albanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalb=iret - if(iret.eq.1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old albedo analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0 .and. kk .eq. 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no albedo analysis available. climatology used' - endif - endif -! -! vegetation fraction for albedo -! - irtalf=0 - if(fnalba(1:8).ne.' ') then - do kk = 1, 2 - call fixrda(lugb,fnalba,kpdalf(kk),slmask, - & iy,im,id,ih,fh,alfanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalf=iret - if(iret.eq.1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old albedo analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0 .and. kk .eq. 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegfalbedo analysis available. climatology used' - endif - endif -! -! soil wetness -! - irtwet=0 - irtsmc=0 - if(fnweta(1:8).ne.' ') then - call fixrda(lugb,fnweta,kpdwet,slmask, - & iy,im,id,ih,fh,wetanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtwet=iret - if(iret.eq.1) then - write(6,*) 'bucket wetness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old wetness analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'bucket wetness analysis provided.' - endif - elseif(fnsmca(1:8).ne.' ') then - call fixrda(lugb,fnsmca,kpdsmc,slmask, - & iy,im,id,ih,fh,smcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnsmca,kpdsmc,slmask, - & iy,im,id,ih,fh,smcanl(1,2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsmc=iret - if(iret.eq.1) then - write(6,*) 'layer soil wetness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old layer soil wetness analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'layer soil wetness analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no soil wetness analysis available. climatology used' - endif - endif -! -! read in snow depth/snow cover -! - irtscv=0 - if(fnsnoa(1:8).ne.' ') then - do i=1,len - scvanl(i)=0. - enddo -!cggg snow mods start -!cggg need to determine if the snow data is on the gaussian grid -!cggg or not. if gaussian, then data is a depth, not liq equiv -!cggg depth. if not gaussian, then data is from hua-lu's -!cggg program and is a liquid equiv. need to communicate -!cggg this to routine fixrda via the 3rd argument which is -!cggg the grib parameter id number. - call baopenr(lugb,fnsnoa,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fnsnoa) - print *,'error in opening file ',trim(fnsnoa) - call abort - endif - lugi=0 - lskip=-1 - jpds=-1 - jgds=-1 - kpds=jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - close(lugb) - if (iret .ne. 0) then - write(6,*) ' error reading header of file: ',trim(fnsnoa) - print *,'error reading header of file: ',trim(fnsnoa) - call abort - endif - if (kgds(1) == 4) then ! gaussian data is depth - call fixrda(lugb,fnsnoa,kpdsnd,slmask, - & iy,im,id,ih,fh,snoanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - snoanl=snoanl*100. ! convert from meters to liq. eq. - ! depth in mm using 10:1 ratio - else ! lat/lon data is liq equv. depth - call fixrda(lugb,fnsnoa,kpdsno,slmask, - & iy,im,id,ih,fh,snoanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -!cggg snow mods end - irtscv=iret - if(iret.eq.1) then - write(6,*) 'snow depth analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snow depth analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snow depth analysis provided.' - endif - irtsno=0 - elseif(fnscva(1:8).ne.' ') then - do i=1,len - snoanl(i)=0. - enddo - call fixrda(lugb,fnscva,kpdscv,slmask, - & iy,im,id,ih,fh,scvanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsno=iret - if(iret.eq.1) then - write(6,*) 'snow cover analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snow cover analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snow cover analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no snow/snocov analysis available. climatology used' - endif - endif -! -! sea ice mask -! - irtacn=0 - irtais=0 - if(fnacna(1:8).ne.' ') then - call fixrda(lugb,fnacna,kpdacn,slmask, - & iy,im,id,ih,fh,acnanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtacn=iret - if(iret.eq.1) then - write(6,*) 'ice concentration analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old ice concentration analysis provided', - & ' indicating proper file name is given' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'ice concentration analysis provided.' - endif - elseif(fnaisa(1:8).ne.' ') then - call fixrda(lugb,fnaisa,kpdais,slmask, - & iy,im,id,ih,fh,aisanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtais=iret - if(iret.eq.1) then - write(6,*) 'ice mask analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old ice-mask analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'ice mask analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no sea-ice analysis available. climatology used' - endif - endif -! -! surface roughness -! - irtzor=0 - if(fnzora(1:8).ne.' ') then - call fixrda(lugb,fnzora,kpdzor,slmask, - & iy,im,id,ih,fh,zoranl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtzor=iret - if(iret.eq.1) then - write(6,*) 'roughness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old roughness analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'roughness analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no srfc roughness analysis available. climatology used' - endif - endif -! -! deep soil temperature -! - irttg3=0 - irtstc=0 - if(fntg3a(1:8).ne.' ') then - call fixrda(lugb,fntg3a,kpdtg3,slmask, - & iy,im,id,ih,fh,tg3anl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irttg3=iret - if(iret.eq.1) then - write(6,*) 'deep soil tmp analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old deep soil temp analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'deep soil tmp analysis provided.' - endif - elseif(fnstca(1:8).ne.' ') then - call fixrda(lugb,fnstca,kpdstc,slmask, - & iy,im,id,ih,fh,stcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnstca,kpdstc,slmask, - & iy,im,id,ih,fh,stcanl(1,2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtstc=iret - if(iret.eq.1) then - write(6,*) 'layer soil tmp analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old deep soil temp analysis provided', - & 'iindicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'layer soil tmp analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no deep soil temp analy available. climatology used' - endif - endif -! -! vegetation cover -! - irtveg=0 - if(fnvega(1:8).ne.' ') then - call fixrda(lugb,fnvega,kpdveg,slmask, - & iy,im,id,ih,fh,veganl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtveg=iret - if(iret.eq.1) then - write(6,*) 'vegetation cover analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old vegetation cover analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'gegetation cover analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegetation cover anly available. climatology used' - endif - endif -! -! vegetation type -! - irtvet=0 - if(fnveta(1:8).ne.' ') then - call fixrda(lugb,fnveta,kpdvet,slmask, - & iy,im,id,ih,fh,vetanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvet=iret - if(iret.eq.1) then - write(6,*) 'vegetation type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old vegetation type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'vegetation type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegetation type anly available. climatology used' - endif - endif -! -! soil type -! - irtsot=0 - if(fnsota(1:8).ne.' ') then - call fixrda(lugb,fnsota,kpdsot,slmask, - & iy,im,id,ih,fh,sotanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsot=iret - if(iret.eq.1) then - write(6,*) 'soil type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old soil type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'soil type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no soil type anly available. climatology used' - endif - endif - -!clu [+120l]-------------------------------------------------------------- -! -! min vegetation cover -! - irtvmn=0 - if(fnvmna(1:8).ne.' ') then - call fixrda(lugb,fnvmna,kpdvmn,slmask, - & iy,im,id,ih,fh,vmnanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvmn=iret - if(iret.eq.1) then - write(6,*) 'shdmin analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old shdmin analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'shdmin analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no shdmin anly available. climatology used' - endif - endif - -! -! max vegetation cover -! - irtvmx=0 - if(fnvmxa(1:8).ne.' ') then - call fixrda(lugb,fnvmxa,kpdvmx,slmask, - & iy,im,id,ih,fh,vmxanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvmx=iret - if(iret.eq.1) then - write(6,*) 'shdmax analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old shdmax analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'shdmax analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no shdmax anly available. climatology used' - endif - endif - -! -! slope type -! - irtslp=0 - if(fnslpa(1:8).ne.' ') then - call fixrda(lugb,fnslpa,kpdslp,slmask, - & iy,im,id,ih,fh,slpanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtslp=iret - if(iret.eq.1) then - write(6,*) 'slope type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old slope type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'slope type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no slope type anly available. climatology used' - endif - endif - -! -! max snow albedo -! - irtabs=0 - if(fnabsa(1:8).ne.' ') then - call fixrda(lugb,fnabsa,kpdabs,slmask, - & iy,im,id,ih,fh,absanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtabs=iret - if(iret.eq.1) then - write(6,*) 'snoalb analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snoalb analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snoalb analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no snoalb anly available. climatology used' - endif - endif - -!clu ---------------------------------------------------------------------- -! - return - end - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs, vetfcs, sotfcs, alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl, vetanl, sotanl, alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & len,lsoil) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), - & zorfcs(len),albfcs(len,4),aisfcs(len), - & tg3fcs(len), - & cvfcs (len),cvbfcs(len),cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len),vegfcs(len), - & vetfcs(len),sotfcs(len),alffcs(len,2) -!cwu [+1l] add ()fcs for sih, sic - &, sihfcs(len),sicfcs(len) -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - write(6,*) ' this is a dead start run, tsfc over land is', - & ' set as lowest sigma level temperture if given.' - write(6,*) ' if not, set to climatological tsf over land is used' -! -! - do i=1,len - tsffcs(i) = tsfanl(i) ! tsf - albfcs(i,1) = albanl(i,1) ! albedo - albfcs(i,2) = albanl(i,2) ! albedo - albfcs(i,3) = albanl(i,3) ! albedo - albfcs(i,4) = albanl(i,4) ! albedo - wetfcs(i) = wetanl(i) ! soil wetness - snofcs(i) = snoanl(i) ! snow - aisfcs(i) = aisanl(i) ! seaice - slifcs(i) = slianl(i) ! land/sea/snow mask - zorfcs(i) = zoranl(i) ! surface roughness -! plrfcs(i) = plranl(i) ! maximum stomatal resistance - tg3fcs(i) = tg3anl(i) ! deep soil temperature - cnpfcs(i) = cnpanl(i) ! canopy water content - cvfcs(i) = cvanl(i) ! cv - cvbfcs(i) = cvbanl(i) ! cvb - cvtfcs(i) = cvtanl(i) ! cvt - vegfcs(i) = veganl(i) ! vegetation cover - vetfcs(i) = vetanl(i) ! vegetation type - sotfcs(i) = sotanl(i) ! soil type - alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo - alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo -!cwu [+2l] add sih, sic - sihfcs(i) = sihanl(i) ! sea ice thickness - sicfcs(i) = sicanl(i) ! sea ice concentration -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) ! min vegetation cover - vmxfcs(i) = vmxanl(i) ! max vegetation cover - slpfcs(i) = slpanl(i) ! slope type - absfcs(i) = absanl(i) ! max snow albedo - enddo -! - do j=1,lsoil - do i=1,len - smcfcs(i,j) = smcanl(i,j) ! layer soil wetness - stcfcs(i,j) = stcanl(i,j) ! soil temperature - enddo - enddo -! - return - end - subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), - & slianl(len) -! -! note that smfcs comes in with the original unit (cm?) (not grib file) -! - do i = 1, len - smcfcs(i,1) = (smcfcs(i,1)/150.) * .37 + .1 - enddo - do k = 2, lsoil - do i = 1, len - smcfcs(i,k) = smcfcs(i,1) - enddo - enddo - if(lsoil.gt.2) then - do k = 3, lsoil - do i = 1, len - stcfcs(i,k) = stcfcs(i,2) - enddo - enddo - endif -! - return - end - subroutine rof01(aisfld,len,op,crit) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) aisfld(len),crit - character*2 op -! - if(op.eq.'ge') then - do i=1,len - if(aisfld(i).ge.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'gt') then - do i=1,len - if(aisfld(i).gt.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'le') then - do i=1,len - if(aisfld(i).le.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'lt') then - do i=1,len - if(aisfld(i).lt.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - else - write(6,*) ' illegal operator in rof01. op=',op - call abort - endif -! - return - end - subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) rlapse,umask - real (kind=kind_io8) tsfc(len), orog(len), slmask(len) -! - do i=1,len - if(slmask(i).eq.umask) then - tsfc(i) = tsfc(i) - orog(i)*rlapse - endif - enddo - return - end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, - & glacir,snwmax,snwmin,landice,len,snoanl, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,me,len - logical, intent(in) :: landice - real (kind=kind_io8) sno,snwmax,snwmin -! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), - & snoclm(len), snoanl(len), glacir(len) -! - if (me .eq. 0) write(6,*) 'snodpth' -! -! use surface temperature to get snow depth estimate -! - do i=1,len - sno = 0.0 -! -! over land -! - if(slianl(i).eq.1.) then - if(scvanl(i).eq.1.0) then - if(tsfanl(i).lt.243.0) then - sno = snwmax - elseif(tsfanl(i).lt.273.0) then - sno = snwmin+(snwmax-snwmin)*(273.0-tsfanl(i))/30.0 - else - sno = snwmin - endif - endif -! -! if glacial points has snow in climatology, set sno to snomax -! - if (.not.landice) then - if(glacir(i).eq.1.0) then - sno = snoclm(i) - if(sno.eq.0.) sno=snwmax - endif - endif - endif -! -! over sea ice -! -! snow over sea ice is cycled as of 01/01/94.....hua-lu pan -! - if(slianl(i).eq.2.0) then - sno=snoclm(i) - if(sno.eq.0.) sno=snwmax - endif -! - snoanl(i) = sno - enddo - return - end subroutine snodpth - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, - & irtvet,irtsot,irtalf, landice, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : veg_type_landice, soil_type_landice - implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, - & irtalb,irtsno,irttsf,irtwet,j - &, irtvmn,irtvmx,irtslp,irtabs - logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, - & cvets,calfs,deltsfc, - & csihl,csihs,csicl,csics, - & rsihl,rsihs,rsicl,rsics, - & qsihl,qsihs,qsicl,qsics - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns - &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss -! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2) - &, sihfcs(len), sicfcs(len) - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), - & wetanl(len),snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2) - &, sihanl(len),sicanl(len) - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), - & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), - & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), - & qstcl(lsoil), qstcs(lsoil) - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! -! coeeficients of blending forecast and interpolated clim -! (or analyzed) fields over sea or land(l) (not for clouds) -! 1.0 = use of forecast -! 0.0 = replace with interpolated analysis -! -! merging coefficients are defined by parameter statement in calling program -! and therefore they should not be modified in this program. -! - rtsfl = ctsfl - ralbl = calbl - ralfl = calfl - raisl = caisl - rsnol = csnol -!clu rsmcl = csmcl - rzorl = czorl - rvegl = cvegl - rvetl = cvetl - rsotl = csotl - rsihl = csihl - rsicl = csicl - rvmnl = cvmnl - rvmxl = cvmxl - rslpl = cslpl - rabsl = cabsl -! - rtsfs = ctsfs - ralbs = calbs - ralfs = calfs - raiss = caiss - rsnos = csnos -! rsmcs = csmcs - rzors = czors - rvegs = cvegs - rvets = cvets - rsots = csots - rsihs = csihs - rsics = csics - rvmns = cvmns - rvmxs = cvmxs - rslps = cslps - rabss = cabss -! - rcv = ccv - rcvb = ccvb - rcvt = ccvt - rcnp = ccnp -! - do k=1,lsoil - rsmcl(k) = csmcl(k) - rsmcs(k) = csmcs(k) - rstcl(k) = cstcl(k) - rstcs(k) = cstcs(k) - enddo - if (fh-deltsfc < -0.001 .and. irttsf == 1) then - rtsfs = 1.0 - rtsfl = 1.0 -! do k=1,lsoil -! rsmcl(k) = 1.0 -! rsmcs(k) = 1.0 -! rstcl(k) = 1.0 -! rstcs(k) = 1.0 -! enddo - endif -! -! if analysis file name is given but no matching analysis date found, -! use guess (these are flagged by irt???=1). -! - if(irttsf == -1) then - rtsfl = 1. - rtsfs = 1. - endif - if(irtalb == -1) then - ralbl = 1. - ralbs = 1. - ralfl = 1. - ralfs = 1. - endif - if(irtais == -1) then - raisl = 1. - raiss = 1. - endif - if(irtsno == -1 .or. irtscv == -1) then - rsnol = 1. - rsnos = 1. - endif - if(irtsmc == -1 .or. irtwet == -1) then -! rsmcl = 1. -! rsmcs = 1. - do k=1,lsoil - rsmcl(k) = 1. - rsmcs(k) = 1. - enddo - endif - if(irtstc.eq.-1) then - do k=1,lsoil - rstcl(k) = 1. - rstcs(k) = 1. - enddo - endif - if(irtzor == -1) then - rzorl = 1. - rzors = 1. - endif - if(irtveg == -1) then - rvegl = 1. - rvegs = 1. - endif - if(irtvet.eq.-1) then - rvetl = 1. - rvets = 1. - endif - if(irtsot == -1) then - rsotl = 1. - rsots = 1. - endif - - if(irtacn == -1) then - rsicl = 1. - rsics = 1. - endif - if(irtvmn == -1) then - rvmnl = 1. - rvmns = 1. - endif - if(irtvmx == -1) then - rvmxl = 1. - rvmxs = 1. - endif - if(irtslp == -1) then - rslpl = 1. - rslps = 1. - endif - if(irtabs == -1) then - rabsl = 1. - rabss = 1. - endif -! - if(raiss == 1. .or. irtacn == -1) then - if (me == 0) print *,'use forecast land-sea-ice mask' - do i = 1, len - aisanl(i) = aisfcs(i) - slianl(i) = slifcs(i) - enddo - endif -! - if (me == 0) then - write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl - 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) - write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs - 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',10f7.3) -! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl -! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets - endif -! - qtsfl = 1. - rtsfl - qalbl = 1. - ralbl - qalfl = 1. - ralfl - qaisl = 1. - raisl - qsnol = 1. - rsnol -! qsmcl = 1. - rsmcl - qzorl = 1. - rzorl - qvegl = 1. - rvegl - qvetl = 1. - rvetl - qsotl = 1. - rsotl - qsihl = 1. - rsihl - qsicl = 1. - rsicl - qvmnl = 1. - rvmnl - qvmxl = 1. - rvmxl - qslpl = 1. - rslpl - qabsl = 1. - rabsl -! - qtsfs = 1. - rtsfs - qalbs = 1. - ralbs - qalfs = 1. - ralfs - qaiss = 1. - raiss - qsnos = 1. - rsnos -! qsmcs = 1. - rsmcs - qzors = 1. - rzors - qvegs = 1. - rvegs - qvets = 1. - rvets - qsots = 1. - rsots - qsihs = 1. - rsihs - qsics = 1. - rsics - qvmns = 1. - rvmns - qvmxs = 1. - rvmxs - qslps = 1. - rslps - qabss = 1. - rabss -! - qcv = 1. - rcv - qcvb = 1. - rcvb - qcvt = 1. - rcvt - qcnp = 1. - rcnp -! - do k=1,lsoil - qsmcl(k) = 1. - rsmcl(k) - qsmcs(k) = 1. - rsmcs(k) - qstcl(k) = 1. - rstcl(k) - qstcs(k) = 1. - rstcs(k) - enddo -! -! merging -! - if(me .eq. 0) then - print *, 'dbgx-- csmcl:', (csmcl(k),k=1,lsoil) - print *, 'dbgx-- rsmcl:', (rsmcl(k),k=1,lsoil) - print *, 'dbgx-- csnol, csnos:',csnol,csnos - print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos - endif - -! print *, rtsfs, qtsfs, raiss , qaiss -! *, rsnos , qsnos, rzors , qzors, rvegs , qvegs -! *, rvets , qvets, rsots , qsots -! *, rcv, rcvb, rcvt, qcv, qcvb, qcvt -! *, ralbs, qalbs, ralfs, qalfs -! print *, rtsfl, qtsfl, raisl , qaisl -! *, rsnol , qsnol, rzorl , qzorl, rvegl , qvegl -! *, rvetl , qvetl, rsotl , qsotl -! *, ralbl, qalbl, ralfl, qalfl -! -! - len_thread_m = (len+num_threads-1) / num_threads - -!$omp parallel do private(i1_t,i2_t,it,i) - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets - sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots - else - vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl - sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl - endif - enddo - enddo -!$omp end parallel do -! -!$omp parallel do private(i1_t,i2_t,it,i,k) -! - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) -! - do i=i1_t,i2_t - if(slianl(i).eq.0.) then -!.... tsffc2 is the previous anomaly + today's climatology -! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) -! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs -! - tsfanl(i) = tsffcs(i)*rtsfs + tsfanl(i)*qtsfs -! albanl(i) = albfcs(i)*ralbs + albanl(i)*qalbs - aisanl(i) = aisfcs(i)*raiss + aisanl(i)*qaiss - snoanl(i) = snofcs(i)*rsnos + snoanl(i)*qsnos - - zoranl(i) = zorfcs(i)*rzors + zoranl(i)*qzors - veganl(i) = vegfcs(i)*rvegs + veganl(i)*qvegs - sihanl(i) = sihfcs(i)*rsihs + sihanl(i)*qsihs - sicanl(i) = sicfcs(i)*rsics + sicanl(i)*qsics - vmnanl(i) = vmnfcs(i)*rvmns + vmnanl(i)*qvmns - vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs - slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps - absanl(i) = absfcs(i)*rabss + absanl(i)*qabss - else - tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl -! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl - aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl - if(rsnol.ge.0)then - snoanl(i) = snofcs(i)*rsnol + snoanl(i)*qsnol - else ! envelope method - if(snoanl(i).ne.0)then - snoanl(i) = max(-snoanl(i)/rsnol, - & min(-snoanl(i)*rsnol, snofcs(i))) - endif - endif - zoranl(i) = zorfcs(i)*rzorl + zoranl(i)*qzorl - veganl(i) = vegfcs(i)*rvegl + veganl(i)*qvegl - vmnanl(i) = vmnfcs(i)*rvmnl + vmnanl(i)*qvmnl - vmxanl(i) = vmxfcs(i)*rvmxl + vmxanl(i)*qvmxl - slpanl(i) = slpfcs(i)*rslpl + slpanl(i)*qslpl - absanl(i) = absfcs(i)*rabsl + absanl(i)*qabsl - sihanl(i) = sihfcs(i)*rsihl + sihanl(i)*qsihl - sicanl(i) = sicfcs(i)*rsicl + sicanl(i)*qsicl - endif - - cnpanl(i) = cnpfcs(i)*rcnp + cnpanl(i)*qcnp -! -! snow over sea ice is cycled -! - if(slianl(i).eq.2.) then - snoanl(i) = snofcs(i) - endif -! - enddo - -! at landice points, set the soil type, slope type and -! greenness fields to flag values. - - if (landice) then - do i=i1_t,i2_t - if (nint(slianl(i)) == 1) then - if (nint(vetanl(i)) == veg_type_landice) then - sotanl(i) = soil_type_landice - veganl(i) = 0.0 - slpanl(i) = 9.0 - vmnanl(i) = 0.0 - vmxanl(i) = 0.0 - endif - end if ! if land - enddo - endif - - do i=i1_t,i2_t - cvanl(i) = cvfcs(i)*rcv + cvanl(i)*qcv - cvbanl(i) = cvbfcs(i)*rcvb + cvbanl(i)*qcvb - cvtanl(i) = cvtfcs(i)*rcvt + cvtanl(i)*qcvt - enddo -! - do k = 1, 4 - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - albanl(i,k) = albfcs(i,k)*ralbs + albanl(i,k)*qalbs - else - albanl(i,k) = albfcs(i,k)*ralbl + albanl(i,k)*qalbl - endif - enddo - enddo -! - do k = 1, 2 - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - alfanl(i,k) = alffcs(i,k)*ralfs + alfanl(i,k)*qalfs - else - alfanl(i,k) = alffcs(i,k)*ralfl + alfanl(i,k)*qalfl - endif - enddo - enddo -! - do k = 1, lsoil - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - smcanl(i,k) = smcfcs(i,k)*rsmcs(k) + smcanl(i,k)*qsmcs(k) - stcanl(i,k) = stcfcs(i,k)*rstcs(k) + stcanl(i,k)*qstcs(k) - else -! soil moisture not used at landice points, so -! don't bother merging it. also, for now don't allow nudging -! to raise subsurface temperature above freezing. - stcanl(i,k) = stcfcs(i,k)*rstcl(k) + stcanl(i,k)*qstcl(k) - if (landice .and. slianl(i) == 1.0 .and. - & nint(vetanl(i)) == veg_type_landice) then - smcanl(i,k) = 1.0 ! use value as flag - stcanl(i,k) = min(stcanl(i,k), 273.15) - else - smcanl(i,k) = smcfcs(i,k)*rsmcl(k) + smcanl(i,k)*qsmcl(k) - end if - endif - enddo - enddo -! - enddo ! end of threaded loop ................... -!$omp end parallel do - return - end subroutine merge - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & sihnew,sicnew,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albsea,snosea,zorsea,smcsea,smcice, - & tsfmin,tsfice,albice,zorice,tgice, - & rla,rlo,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, - & smcice,tsfmin,zorsea,smcsea -!cwu [+1l] add sicnew,sihnew - &, sicnew,sihnew - integer i,me,kount1,kount2,k,len,lsoil - real (kind=kind_io8) slianl(len), slifcs(len), - & tsffcs(len),tsfanl(len) - real (kind=kind_io8) albanl(len,4), snoanl(len), zoranl(len) - real (kind=kind_io8) smcanl(len,lsoil), stcanl(len,lsoil) -!cwu [+1l] add sihanl & sicanl - real (kind=kind_io8) sihanl(len), sicanl(len) -! - real (kind=kind_io8) rla(len), rlo(len) -! - if (me .eq. 0) write(6,*) 'newice' -! - kount1 = 0 - kount2 = 0 - do i=1,len - if(slifcs(i).ne.slianl(i)) then - if(slifcs(i).eq.1..or.slianl(i).eq.1.) then - print *,'inconsistency in slifcs or slianl' - print 910,rla(i),rlo(i),slifcs(i),slianl(i), - & tsffcs(i),tsfanl(i) - 910 format(2x,'at lat=',f5.1,' lon=',f5.1,' slifcs=',f4.1, - & ' slimsk=',f4.1,' tsffcs=',f5.1,' set to tsfanl=',f5.1) - call abort - endif -! -! interpolated climatology indicates melted sea ice -! - if(slianl(i).eq.0..and.slifcs(i).eq.2.) then - tsfanl(i) = tsfmin - albanl(i,1) = albsea - albanl(i,2) = albsea - albanl(i,3) = albsea - albanl(i,4) = albsea - snoanl(i) = snosea - zoranl(i) = zorsea - do k = 1, lsoil - smcanl(i,k) = smcsea -!cwu [+1l] set stcanl to tgice (over sea-ice) - stcanl(i,k) = tgice - enddo -!cwu [+2l] set siganl and sicanl - sihanl(i) = 0. - sicanl(i) = 0. - kount1 = kount1 + 1 - endif -! -! interplated climatoloyg/analysis indicates new sea ice -! - if(slianl(i).eq.2..and.slifcs(i).eq.0.) then - tsfanl(i) = tsfice - albanl(i,1) = albice - albanl(i,2) = albice - albanl(i,3) = albice - albanl(i,4) = albice - snoanl(i) = 0. - zoranl(i) = zorice - do k = 1, lsoil - smcanl(i,k) = smcice - stcanl(i,k) = tgice - enddo -!cwu [+2l] add sihanl & sicanl - sihanl(i) = sihnew - sicanl(i) = min(one, max(sicnew,sicanl(i))) - kount2 = kount2 + 1 - endif - endif - enddo -! - if (me .eq. 0) then - if(kount1.gt.0) then - write(6,*) 'sea ice melted. tsf,alb,zor are filled', - & ' at ',kount1,' points' - endif - if(kount2.gt.0) then - write(6,*) 'sea ice formed. tsf,alb,zor are filled', - & ' at ',kount2,' points' - endif - endif -! - return - end - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, - & landice,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,i,len,me - logical, intent(in) :: landice - real (kind=kind_io8) per,snoval - real (kind=kind_io8) snoanl(len),slmask(len), - & aisanl(len),glacir(len) - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) 'qc of snow' - endif - if (.not.landice) then - kount=0 - do i=1,len - if(glacir(i).ne.0..and.snoanl(i).eq.0.) then -! if(glacir(i).ne.0..and.snoanl(i).lt.snoval*0.5) then - snoanl(i) = snoval - kount = kount + 1 - endif - enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if (me .eq. 0) then - print *,'snow filled over glacier points at ',kount, - & ' points (',per,'percent)' - endif - endif - endif ! landice check - kount = 0 - do i=1,len - if(slmask(i).eq.0.and.aisanl(i).eq.0) then - snoanl(i) = 0. - kount = kount + 1 - endif - enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if (me .eq. 0) then - print *,'snow set to zero over open sea at ',kount, - & ' points (',per,'percent)' - endif - endif - return - end subroutine qcsnow - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount1,kount,i,me,len - real (kind=kind_io8) per,aicsea,aicice,sllnd -! - real (kind=kind_io8) ais(len), glacir(len), - & amxice(len), slmask(len) - real (kind=kind_io8) rla(len), rlo(len) -! -! check sea-ice cover mask against land-sea mask -! - if (me .eq. 0) write(6,*) 'qc of sea ice' - kount = 0 - kount1 = 0 - do i=1,len - if(ais(i).ne.aicice.and.ais(i).ne.aicsea) then - print *,'sea ice mask not ',aicice,' or ',aicsea - print *,'ais(i),aicice,aicsea,rla(i),rlo(i,=', - & ais(i),aicice,aicsea,rla(i),rlo(i) - call abort - endif - if(slmask(i).eq.0..and.glacir(i).eq.1..and. -! if(slmask(i).eq.0..and.glacir(i).eq.2..and. - & ais(i).ne.1.) then - kount1 = kount1 + 1 - ais(i) = 1. - endif - if(slmask(i).eq.sllnd.and.ais(i).eq.aicice) then - kount = kount + 1 - ais(i) = aicsea - endif - enddo -! enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if(me .eq. 0) then - print *,' sea ice over land mask at ',kount,' points (',per, - & 'percent)' - endif - endif - per = float(kount1) / float(len)*100. - if(kount1.gt.0) then - if(me .eq. 0) then - print *,' sea ice set over glacier points over ocean at ', - & kount1,' points (',per,'percent)' - endif - endif -! kount=0 -! do j=1,jdim -! do i=1,idim -! if(amxice(i,j).ne.0..and.ais(i,j).eq.0.) then -! ais(i,j)=0. -! kount=kount+1 -! endif -! enddo -! enddo -! per=float(kount)/float(idim*jdim)*100. -! if(kount.gt.0) then -! print *,' sea ice exceeds maxice at ',kount,' points (',per, -! & 'percent)' -! endif -! -! remove isolated open ocean surrounded by sea ice and/or land -! -! remove isolated open ocean surrounded by sea ice and/or land -! -! ij = 0 -! do j=1,jdim -! do i=1,idim -! ij = ij + 1 -! ip = i + 1 -! im = i - 1 -! jp = j + 1 -! jm = j - 1 -! if(jp.gt.jdim) jp = jdim - 1 -! if(jm.lt.1) jm = 2 -! if(ip.gt.idim) ip = 1 -! if(im.lt.1) im = idim -! if(slmask(i,j).eq.0..and.ais(i,j).eq.0.) then -! if((slmask(ip,jp).eq.1..or.ais(ip,jp).eq.1.).and. -! & (slmask(i ,jp).eq.1..or.ais(i ,jp).eq.1.).and. -! & (slmask(im,jp).eq.1..or.ais(im,jp).eq.1.).and. -! & (slmask(ip,j ).eq.1..or.ais(ip,j ).eq.1.).and. -! & (slmask(im,j ).eq.1..or.ais(im,j ).eq.1.).and. -! & (slmask(ip,jm).eq.1..or.ais(ip,jm).eq.1.).and. -! & (slmask(i ,jm).eq.1..or.ais(i ,jm).eq.1.).and. -! & (slmask(im,jm).eq.1..or.ais(im,jm).eq.1.)) then -! ais(i,j) = 1. -! write(6,*) ' isolated open sea point surrounded by', -! & ' sea ice or land modified to sea ice', -! & ' at lat=',rla(i,j),' lon=',rlo(i,j) -! endif -! endif -! enddo -! enddo - return - end - subroutine setlsi(slmask,aisfld,len,aicice,slifld) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) aicice - real (kind=kind_io8) slmask(len), slifld(len), aisfld(len) -! -! set surface condition indicator slimsk -! - do i=1,len - slifld(i) = slmask(i) -! if(aisfld(i).eq.aicice) slifld(i) = 2.0 - if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) - & slifld(i) = 2.0 - enddo - return - end - subroutine scale(fld,len,scl) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) fld(len),scl - do i=1,len - fld(i) = fld(i) * scl - enddo - return - end - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, - & rla,rlo,len,mode,percrit,lgchek,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, - & fldlmx,fldlmn,fldomx,fldjmn,percrit, - & fldsmx,fldsmn,epsfld - integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, - & ij,nprt,kmaxs,kmins,i,me,len,mode - parameter(mmprt=2) -! - character*8 ttl - logical iceflg(len) - real (kind=kind_io8) fld(len),slimsk(len),sno(len), - & rla(len), rlo(len) - integer iwk(len) - logical lgchek -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! -! check against land-sea mask and ice cover mask -! - if(me .eq. 0) then -! print *,' ' - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' - endif -! - len_thread_m = (len+num_threads-1) / num_threads - kmaxl = 0 - kminl = 0 - kmaxo = 0 - kmino = 0 - kmaxi = 0 - kmini = 0 - kmaxj = 0 - kminj = 0 - kmaxs = 0 - kmins = 0 -!$omp parallel do private(i1_t,i2_t,it,i) -!$omp+private(nprt,ij,iwk) -!$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) -!$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) -!$omp+shared(mode,epsfld) -!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) -!$omp+shared(fld,slimsk,sno,rla,rlo) - do it=1,num_threads ! start of threaded loop - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) -! -! -! -! lower bound check over bare land -! - if (fldlmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).lt.fldlmn-epsfld) then - kminl=kminl+1 - iwk(kminl) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kminl) - do i=1,nprt - ij = iwk(i) - print 8001,rla(ij),rlo(ij),fld(ij),fldlmn - 8001 format(' bare land min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) - enddo - endif - if (mode .eq. 1) then - do i=1,kminl - fld(iwk(i)) = fldlmn - enddo - endif - endif -! -! upper bound check over bare land -! - if (fldlmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).gt.fldlmx+epsfld) then - kmaxl=kmaxl+1 - iwk(kmaxl) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxl) - do i=1,nprt - ij = iwk(i) - print 8002,rla(ij),rlo(ij),fld(ij),fldlmx - 8002 format(' bare land max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxl - fld(iwk(i)) = fldlmx - enddo - endif - endif -! -! lower bound check over snow covered land -! - if (fldsmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).lt.fldsmn-epsfld) then - kmins=kmins+1 - iwk(kmins) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmins) - do i=1,nprt - ij = iwk(i) - print 8003,rla(ij),rlo(ij),fld(ij),fldsmn - 8003 format(' sno covrd land min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmins - fld(iwk(i)) = fldsmn - enddo - endif - endif -! -! upper bound check over snow covered land -! - if (fldsmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).gt.fldsmx+epsfld) then - kmaxs=kmaxs+1 - iwk(kmaxs) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxs) - do i=1,nprt - ij = iwk(i) - print 8004,rla(ij),rlo(ij),fld(ij),fldsmx - 8004 format(' snow land max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxs - fld(iwk(i)) = fldsmx - enddo - endif - endif -! -! lower bound check over open ocean -! - if (fldomn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.0..and. - & fld(i).lt.fldomn-epsfld) then - kmino=kmino+1 - iwk(kmino) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmino) - do i=1,nprt - ij = iwk(i) - print 8005,rla(ij),rlo(ij),fld(ij),fldomn - 8005 format(' open ocean min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmino - fld(iwk(i)) = fldomn - enddo - endif - endif -! -! upper bound check over open ocean -! - if (fldomx .ne. 999.0) then - do i=i1_t,i2_t - if(fldomx.ne.999..and.slimsk(i).eq.0..and. - & fld(i).gt.fldomx+epsfld) then - kmaxo=kmaxo+1 - iwk(kmaxo) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxo) - do i=1,nprt - ij = iwk(i) - print 8006,rla(ij),rlo(ij),fld(ij),fldomx - 8006 format(' open ocean max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxo - fld(iwk(i)) = fldomx - enddo - endif - endif -! -! lower bound check over sea ice without snow -! - if (fldimn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).lt.fldimn-epsfld) then - kmini=kmini+1 - iwk(kmini) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmini) - do i=1,nprt - ij = iwk(i) - print 8007,rla(ij),rlo(ij),fld(ij),fldimn - 8007 format(' seaice no snow min. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmini - fld(iwk(i)) = fldimn - enddo - endif - endif -! -! upper bound check over sea ice without snow -! - if (fldimx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then -! & fld(i).gt.fldimx+epsfld) then - kmaxi=kmaxi+1 - iwk(kmaxi) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxi) - do i=1,nprt - ij = iwk(i) - print 8008,rla(ij),rlo(ij),fld(ij),fldimx - 8008 format(' seaice no snow max. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxi - fld(iwk(i)) = fldimx - enddo - endif - endif -! -! lower bound check over sea ice with snow -! - if (fldjmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).lt.fldjmn-epsfld) then - kminj=kminj+1 - iwk(kminj) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kminj) - do i=1,nprt - ij = iwk(i) - print 8009,rla(ij),rlo(ij),fld(ij),fldjmn - 8009 format(' sea ice snow min. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kminj - fld(iwk(i)) = fldjmn - enddo - endif - endif -! -! upper bound check over sea ice with snow -! - if (fldjmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then -! & fld(i).gt.fldjmx+epsfld) then - kmaxj=kmaxj+1 - iwk(kmaxj) = i - endif - enddo - if(me == 0 .and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxj) - do i=1,nprt - ij = iwk(i) - print 8010,rla(ij),rlo(ij),fld(ij),fldjmx - 8010 format(' seaice snow max check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxj - fld(iwk(i)) = fldjmx - enddo - endif - endif - enddo ! end of threaded loop -!$omp end parallel do -! -! print results -! - if(me .eq. 0) then -! write(6,*) 'summary of qc' - permax=0. - if(kminl.gt.0) then - per=float(kminl)/float(len)*100. - print 9001,fldlmn,kminl,per - 9001 format(' bare land min check. modified to ',f8.1, - & ' at ',i5,' points ',f8.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxl.gt.0) then - per=float(kmaxl)/float(len)*100. - print 9002,fldlmx,kmaxl,per - 9002 format(' bare land max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmino.gt.0) then - per=float(kmino)/float(len)*100. - print 9003,fldomn,kmino,per - 9003 format(' open ocean min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxo.gt.0) then - per=float(kmaxo)/float(len)*100. - print 9004,fldomx,kmaxo,per - 9004 format(' open sea max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmins.gt.0) then - per=float(kmins)/float(len)*100. - print 9009,fldsmn,kmins,per - 9009 format(' snow covered land min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxs.gt.0) then - per=float(kmaxs)/float(len)*100. - print 9010,fldsmx,kmaxs,per - 9010 format(' snow covered land max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmini.gt.0) then - per=float(kmini)/float(len)*100. - print 9005,fldimn,kmini,per - 9005 format(' bare ice min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxi.gt.0) then - per=float(kmaxi)/float(len)*100. - print 9006,fldimx,kmaxi,per - 9006 format(' bare ice max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kminj.gt.0) then - per=float(kminj)/float(len)*100. - print 9007,fldjmn,kminj,per - 9007 format(' snow covered ice min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxj.gt.0) then - per=float(kmaxj)/float(len)*100. - print 9008,fldjmx,kmaxj,per - 9008 format(' snow covered ice max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif -! commented on 06/30/99 -- moorthi -! if(lgchek) then -! if(permax.gt.percrit) then -! write(6,*) ' too many bad points. aborting ....' -! call abort -! endif -! endif -! - endif -! - return - end - subroutine setzro(fld,eps,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) fld(len),eps - do i=1,len - if(abs(fld(i)).lt.eps) fld(i) = 0. - enddo - return - end - subroutine getscv(snofld,scvfld,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) snofld(len),scvfld(len) -! - do i=1,len - scvfld(i) = 0. - if(snofld(i).gt.0.) scvfld(i) = 1. - enddo - return - end - subroutine getstc(tsffld,tg3fld,slifld,len,lsoil,stcfld,tsfimx) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer k,i,len,lsoil - real (kind=kind_io8) factor,tsfimx - real (kind=kind_io8) tsffld(len), tg3fld(len), slifld(len) - real (kind=kind_io8) stcfld(len,lsoil) -! -! layer soil temperature -! - do k = 1, lsoil - do i = 1, len - if(slifld(i).eq.1.0) then - factor = ((k-1) * 2 + 1) / (2. * lsoil) - stcfld(i,k) = factor*tg3fld(i)+(1.-factor)*tsffld(i) - elseif(slifld(i).eq.2.0) then - factor = ((k-1) * 2 + 1) / (2. * lsoil) - stcfld(i,k) = factor*tsfimx+(1.-factor)*tsffld(i) - else - stcfld(i,k) = tg3fld(i) - endif - enddo - enddo - if(lsoil.gt.2) then - do k = 3, lsoil - do i = 1, len - stcfld(i,k) = stcfld(i,2) - enddo - enddo - endif - return - end - subroutine getsmc(wetfld,len,lsoil,smcfld,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer k,i,len,lsoil,me - real (kind=kind_io8) wetfld(len), smcfld(len,lsoil) -! - if (me .eq. 0) write(6,*) 'getsmc' -! -! layer soil wetness -! - do k = 1, lsoil - do i = 1, len - smcfld(i,k) = (wetfld(i)*1000./150.)*.37 + .1 - enddo - enddo - return - end - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, - & tsfimx) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len,lsoil - real (kind=kind_io8) tsfimx - real (kind=kind_io8) sig1t(len), slianl(len), tg3anl(len) - real (kind=kind_io8) tsfanl(len), stcanl(len,lsoil) -! -! soil temperature -! - if(sig1t(1).gt.0.) then - do i=1,len - if(slianl(i).ne.0.) then - tsfanl(i) = sig1t(i) - endif - enddo - endif - call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) -! - return - end - subroutine snosfc(snoanl,tsfanl,tsfsmx,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,i,len,me - real (kind=kind_io8) per,tsfsmx - real (kind=kind_io8) snoanl(len), tsfanl(len) -! - if (me .eq. 0) write(6,*) 'set snow temp to tsfsmx if greater' - kount=0 - do i=1,len - if(snoanl(i).gt.0.) then - if(tsfanl(i).gt.tsfsmx) tsfanl(i)=tsfsmx - kount = kount + 1 - endif - enddo - if(kount.gt.0) then - if(me .eq. 0) then - per=float(kount)/float(len)*100. - write(6,*) 'snow sfc. tsf set to ',tsfsmx,' at ', - & kount, ' points ',per,'percent' - endif - endif - return - end - subroutine albocn(albclm,slmask,albomx,len) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) albomx - real (kind=kind_io8) albclm(len,4), slmask(len) - do i=1,len - if(slmask(i).eq.0) then - albclm(i,1) = albomx - albclm(i,2) = albomx - albclm(i,3) = albomx - albclm(i,4) = albomx - endif - enddo - return - end - subroutine qcmxice(glacir,amxice,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,kount,len,me - real (kind=kind_io8) glacir(len),amxice(len),per - if (me .eq. 0) write(6,*) 'qc of maximum ice extent' - kount=0 - do i=1,len - if(glacir(i).eq.1..and.amxice(i).eq.0.) then - amxice(i) = 0. - kount = kount + 1 - endif - enddo - if(kount.gt.0) then - per = float(kount) / float(len)*100. - if(me .eq. 0) write(6,*) ' max ice limit less than glacier' - &, ' coverage at ', kount, ' points ',per,'percent' - endif - return - end - subroutine qcsli(slianl,slifcs,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,kount,len,me - real (kind=kind_io8) slianl(len), slifcs(len),per - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) 'qcsli' - endif - kount=0 - do i=1,len - if(slianl(i).eq.1..and.slifcs(i).eq.0.) then - kount = kount + 1 - slifcs(i) = 1. - endif - if(slianl(i).eq.0..and.slifcs(i).eq.1.) then - kount = kount + 1 - slifcs(i) = 0. - endif - if(slianl(i).eq.2..and.slifcs(i).eq.1.) then - kount = kount + 1 - slifcs(i) = 0. - endif - if(slianl(i).eq.1..and.slifcs(i).eq.2.) then - kount = kount + 1 - slifcs(i) = 1. - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if(me .eq. 0) then - write(6,*) ' inconsistency of slmask between forecast and', - & ' analysis corrected at ',kount, ' points ',per, - & 'percent' - endif - endif - return - end -! subroutine nntprt(data,imax,fact) -! real (kind=kind_io8) data(imax) -! ilast=0 -! i1=1 -! i2=80 -!1112 continue -! if(i2.ge.imax) then -! ilast=1 -! i2=imax -! endif -! write(6,*) ' ' -! do j=1,jmax -! write(6,1111) (nint(data(imax*(j-1)+i)*fact),i=i1,i2) -! enddo -! if(ilast.eq.1) return -! i1=i1+80 -! i2=i1+79 -! if(i2.ge.imax) then -! ilast=1 -! i2=imax -! endif -! go to 1112 -!1111 format(80i1) -! return -! end - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx, me) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,me,k,i,lsoil,len - real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx - real (kind=kind_io8) tsffcs(len), snofcs(len) - real (kind=kind_io8) snoanl(len), aisanl(len), - & slianl(len), zoranl(len), - & tsfanl(len), albanl(len,4), - & smcanl(len,lsoil) - real (kind=kind_io8) smcclm(len,lsoil) -! - if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' -! -! qc of snow analysis -! -! questionable snow cover -! - kount = 0 - do i=1,len - if(slianl(i).gt.0..and. - & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then - kount = kount + 1 - snoanl(i) = 0. - tsfanl(i) = tsffcs(i) - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if (me .eq. 0) then - write(6,*) ' guess surface temp .gt. ',qctsfs, - & ' but snow analysis indicates snow cover' - write(6,*) ' snow analysis set to zero', - & ' at ',kount, ' points ',per,'percent' - endif - endif -! -! questionable no snow cover -! - kount = 0 - do i=1,len - if(slianl(i).gt.0..and. - & snofcs(i).gt.qcsnos.and.snoanl(i).lt.0.) then - kount = kount + 1 - snoanl(i) = snofcs(i) - tsfanl(i) = tsffcs(i) - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if (me .eq. 0) then - write(6,*) ' guess snow depth .gt. ',qcsnos, - & ' but snow analysis indicates no snow cover' - write(6,*) ' snow analysis set to guess value', - & ' at ',kount, ' points ',per,'percent' - endif - endif -! -! questionable sea ice cover ! this qc is disable to correct error in -! surface temparature over observed sea ice points -! -! kount = 0 -! do i=1,len -! if(slianl(i).eq.2..and. -! & tsffcs(i).gt.qctsfi.and.aisanl(i).eq.1.) then -! kount = kount + 1 -! aisanl(i) = 0. -! slianl(i) = 0. -! tsfanl(i) = tsffcs(i) -! snoanl(i) = 0. -! zoranl(i) = zoromx -! albanl(i,1) = albomx -! albanl(i,2) = albomx -! albanl(i,3) = albomx -! albanl(i,4) = albomx -! do k=1,lsoil -! smcanl(i,k) = smcclm(i,k) -! enddo -! endif -! enddo -! if(kount.gt.0) then -! per=float(kount)/float(len)*100. -! if (me .eq. 0) then -! write(6,*) ' guess surface temp .gt. ',qctsfi, -! & ' but sea-ice analysis indicates sea-ice' -! write(6,*) ' sea-ice analysis set to zero', -! & ' at ',kount, ' points ',per,'percent' -! endif -! endif -! - return - end - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, - & data,imax,jmax,rlnout,rltout,lmask,rslmsk - &, gaus,blno, blto, kgds1, kpds4, lbms) - use machine , only : kind_io8,kind_io4 - use sfccyc_module - implicit none - real (kind=kind_io8) blno,blto,wlon,rnlat,crit,data_max - integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla - integer, intent(in) :: kpds4 - logical*1, intent(in) :: lbms(imax,jmax) - real*4 :: dummy(imax,jmax) - - real (kind=kind_io8) slmask(igaul,jgaul) - real (kind=kind_io8) data(imax,jmax),rslmsk(imax,jmax) - &, rlnout(imax), rltout(jmax) - real (kind=kind_io8) a(jmax), w(jmax), radi, dlat, dlon - logical lmask, gaus -! -! set the longitude and latitudes for the grib file -! - if (kgds1 .eq. 4) then ! grib file on gaussian grid - kspla=4 - call splat(kspla, jmax, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do j=1,jmax - rltout(j) = acos(a(j)) * radi - enddo -! - if (rnlat .gt. 0.0) then - do j=1,jmax - rltout(j) = 90. - rltout(j) - enddo - else - do j=1,jmax - rltout(j) = -90. + rltout(j) - enddo - endif - elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid - dlat = -(rnlat+rnlat) / float(jmax-1) - do j=1,jmax - rltout(j) = rnlat + (j-1) * dlat - enddo - else ! grib file on some other grid - call abort - endif - dlon = 360.0 / imax - do i=1,imax - rlnout(i) = wlon + (i-1)*dlon - enddo -! -! - ijmax = imax*jmax - rslmsk = 0. -! TG3 MODS BEGIN - if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116 - & .and. kpds4 == 128) then -! print*,'turn off setrmsk for tg3' - lmask = .false. - - elseif(kpds5 == kpdtsf) then -! TG3 MODS END -! -! surface temperature -! - lmask = .false. - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit = 0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask = .true. -! -! bucket soil wetness -! - elseif(kpds5.eq.kpdwet) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit = 0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask = .true. -! write(6,*) 'wet rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! snow depth -! - elseif(kpds5 == kpdsnd) then - if(kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask=.true. - else - lmask=.false. - end if -! -! snow liq equivalent depth -! - elseif(kpds5.eq.kpdsno) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'sno rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! soil moisture -! - elseif(kpds5.eq.kpdsmc) then - if(kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask=.true. - else - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. - endif -! -! surface roughness -! - elseif(kpds5.eq.kpdzor) then - do j=1,jmax - do i=1,imax - rslmsk(i,j)=data(i,j) - enddo - enddo - crit=9.9 - call rof01(rslmsk,ijmax,'lt',crit) - lmask=.true. -! write(6,*) 'zor rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! albedo -! -! elseif(kpds5.eq.kpdalb) then -! do j=1,jmax -! do i=1,imax -! rslmsk(i,j)=data(i,j) -! enddo -! enddo -! crit=99. -! call rof01(rslmsk,ijmax,'lt',crit) -! lmask=.true. -! write(6,*) 'alb rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! albedo -! -!cbosu new snowfree albedo database has bitmap, use it. - elseif(kpds5.eq.kpdalb(1)) then - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(2)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(3)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(4)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if -! -! vegetation fraction for albedo -! - elseif(kpds5.eq.kpdalf(1)) then -! rslmsk=data -! crit=0. -! call rof01(rslmsk,ijmax,'gt',crit) -! lmask=.true. - lmask=.false. - elseif(kpds5.eq.kpdalf(2)) then -! rslmsk=data -! crit=0. -! call rof01(rslmsk,ijmax,'gt',crit) -! lmask=.true. - lmask=.false. -! -! sea ice -! - elseif(kpds5.eq.kpdais) then - lmask=.false. -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! - data_max = 0.0 - do j=1,jmax - do i=1,imax - rslmsk(i,j) = data(i,j) - data_max= max(data_max,data(i,j)) - enddo - enddo - crit=1.0 - if (data_max .gt. crit) then - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. - else - lmask=.false. - endif -! write(6,*) 'acn rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! deep soil temperature -! - elseif(kpds5.eq.kpdtg3) then - lmask=.false. -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! lmask=.true. -! -! plant resistance -! -! elseif(kpds5.eq.kpdplr) then -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! lmask=.true. -! -! write(6,*) 'plr rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! glacier points -! - elseif(kpds5.eq.kpdgla) then - lmask=.false. -! -! max ice extent -! - elseif(kpds5.eq.kpdmxi) then - lmask=.false. -! -! snow cover -! - elseif(kpds5.eq.kpdscv) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'scv rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! sea ice concentration -! - elseif(kpds5.eq.kpdacn) then - lmask=.false. - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'acn rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! vegetation cover -! - elseif(kpds5.eq.kpdveg) then -!cggg - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction - end if - enddo - enddo - lmask = .true. - else ! no bitmap, set mask the old way. - - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. - - end if -! -! soil type -! - elseif(kpds5.eq.kpdsot) then - - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo -! soil type is zero over water, use this to get a bitmap. - else - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - endif - lmask=.true. -! -! vegetation type -! - elseif(kpds5.eq.kpdvet) then - - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo -! veg type is zero over water, use this to get a bitmap. - else - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - endif - lmask=.true. -! -! these are for four new data type added by clu -- not sure its correct! -! - elseif(kpds5.eq.kpdvmn) then -! -!cggg greenness is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! - elseif(kpds5.eq.kpdvmx) then -! -!cggg greenness is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! - elseif(kpds5.eq.kpdslp) then -! -!cggg slope type is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! -!cbosu new maximum snow albedo database has bitmap - elseif(kpds5.eq.kpdabs) then - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has zero over water - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. - end if - endif -! - return - end - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, - & wlon,rnlat,rlnout,rltout,gaus,blno, blto) - use machine , only : kind_io8,kind_io4 - implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, - & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, - & rnlat,dxout,dphi,dlat,facns,tem,blno, - & blto -! -! interpolation from lat/lon grid to other lat/lon grid -! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) - &, rlnout(imxout), rltout(jmxout) - logical gaus -! - real, allocatable :: gaul(:) - real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), - & jindx1(jmxout), jindx2(jmxout) - integer jmxsav,n,kspla - data jmxsav/0/ - save jmxsav, gaul, dlati - real (kind=kind_io8) radi - real (kind=kind_io8) a(jmxin), w(jmxin) -! -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, j1_t, j2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! - if (jmxin .ne. jmxsav) then - if (jmxsav .gt. 0) deallocate (gaul, stat=iret) - allocate (gaul(jmxin)) - jmxsav = jmxin - if (gaus) then -cjfe call gaulat(gaul,jmxin) -cjfe -! - kspla=4 - call splat(kspla, jmxin, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do n=1,jmxin - gaul(n) = acos(a(n)) * radi - enddo -cjfe - do j=1,jmxin - gaul(j) = 90. - gaul(j) - enddo - else - dlat = -2*blto / float(jmxin-1) - dlati = 1 / dlat - do j=1,jmxin - gaul(j) = blto + (j-1) * dlat - enddo - endif - endif -! -! - dxin = 360. / float(imxin ) -! - do i=1,imxout - alamd = rlnout(i) - i1 = floor((alamd-blno)/dxin) + 1 - ddx(i) = (alamd-blno)/dxin-(i1-1) - iindx1(i) = modulo(i1-1,imxin) + 1 - iindx2(i) = modulo(i1 ,imxin) + 1 - enddo -! -! - len_thread_m = (jmxout+num_threads-1) / num_threads -! - if (gaus) then -! -!$omp parallel do private(j1_t,j2_t,it,j1,j2,jj) -!$omp+private(aphi) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - j2=1 - do 40 j=j1_t,j2_t - aphi=rltout(j) - do 50 jj=1,jmxin - if(aphi.lt.gaul(jj)) go to 50 - j2=jj - go to 42 - 50 continue - 42 continue - if(j2.gt.2) go to 43 - j1=1 - j2=2 - go to 44 - 43 continue - if(j2.le.jmxin) go to 45 - j1=jmxin-1 - j2=jmxin - go to 44 - 45 continue - j1=j2-1 - 44 continue - jindx1(j)=j1 - jindx2(j)=j2 - ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) - 40 continue - enddo ! end of threaded loop ................... -!$omp end parallel do -! - else -!$omp parallel do private(j1_t,j2_t,it,j1,j2,jtem) -!$omp+private(aphi) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy,dlati,blto) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - j2=1 - do 400 j=j1_t,j2_t - aphi=rltout(j) - jtem = (aphi - blto) * dlati + 1 - if (jtem .ge. 1 .and. jtem .lt. jmxin) then - j1 = jtem - j2 = j1 + 1 - ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) - elseif (jtem .eq. jmxin) then - j1 = jmxin - j2 = jmxin - ddy(j)=1.0 - else - j1 = 1 - j2 = 1 - ddy(j)=1.0 - endif -! - jindx1(j) = j1 - jindx2(j) = j2 - 400 continue - enddo ! end of threaded loop ................... -!$omp end parallel do - endif -! -! write(6,*) 'ga2la' -! write(6,*) 'iindx1' -! write(6,*) (iindx1(n),n=1,imxout) -! write(6,*) 'iindx2' -! write(6,*) (iindx2(n),n=1,imxout) -! write(6,*) 'jindx1' -! write(6,*) (jindx1(n),n=1,jmxout) -! write(6,*) 'jindx2' -! write(6,*) (jindx2(n),n=1,jmxout) -! write(6,*) 'ddy' -! write(6,*) (ddy(n),n=1,jmxout) -! write(6,*) 'ddx' -! write(6,*) (ddx(n),n=1,jmxout) -! -! -!$omp parallel do private(j1_t,j2_t,it,i,i1,i2) -!$omp+private(j,j1,j2,x,y) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(imxout,iindx1,jindx1,ddx,ddy,gauin,regout) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - do j=j1_t,j2_t - y = ddy(j) - j1 = jindx1(j) - j2 = jindx2(j) - do i=1,imxout - x = ddx(i) - i1 = iindx1(i) - i2 = iindx2(i) - regout(i,j) = (1.-x)*((1.-y)*gauin(i1,j1) + y*gauin(i1,j2)) - & + x *((1.-y)*gauin(i2,j1) + y*gauin(i2,j2)) - enddo - enddo - enddo ! end of threaded loop ................... -!$omp end parallel do -! - sum1 = 0. - sum2 = 0. - do i=1,imxin - sum1 = sum1 + gauin(i,1) - sum2 = sum2 + gauin(i,jmxin) - enddo - sum1 = sum1 / float(imxin) - sum2 = sum2 / float(imxin) -! - if (gaus) then - if (rnlat .gt. 0.0) then - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - else - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - endif - else - if (blto .lt. 0.0) then - if (rnlat .gt. 0.0) then - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - else - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - endif - else - if (rnlat .lt. 0.0) then - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - else - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - endif - endif - endif -! - return - end - subroutine landtyp(vegtype,soiltype,slptype,slmask,len) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) - +, slptype(len) -! -! make sure that the soil type and veg type are non-zero over land -! - do i = 1, len - if (slmask(i) .eq. 1) then - if (vegtype(i) .eq. 0.) vegtype(i) = 7 - if (soiltype(i) .eq. 0.) soiltype(i) = 2 - if (slptype(i) .eq. 0.) slptype(i) = 1 - endif - enddo - return - end subroutine landtyp - subroutine gaulat(gaul,k) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer n,k - real (kind=kind_io8) radi - real (kind=kind_io8) a(k), w(k), gaul(k) -! - call splat(4, k, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do n=1,k - gaul(n) = acos(a(n)) * radi - enddo -! -! print *,'gaussian lat (deg) for jmax=',k -! print *,(gaul(n),n=1,k) -! - return - 70 write(6,6000) - 6000 format(//5x,'error in gauaw'//) - stop - end -!----------------------------------------------------------------------- - subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), - & tsfclm(len), tsfcl0(len) -! -! time interpolation of anomalies -! add initial anomaly to date interpolated climatology -! - write(6,*) 'anomint' - do i=1,len - tsfanl(i) = tsfan0(i) - tsfcl0(i) + tsfclm(i) - enddo - return - end - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb - &, tile_num_ch, i_index, j_index) -! - use machine , only : kind_io8,kind_io4 - implicit none - character(len=*), intent(in) :: tile_num_ch - integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, - & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 - real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb - &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat - integer kpdalb(4), kpdalf(2) -! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc,fnalbc2 - &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), - & wetclm(len),snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len),acnclm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) - &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) - real (kind=kind_io8) slmskh(imsk,jmsk) - real (kind=kind_io8) outlat(len), outlon(len) -! - real (kind=kind_io8) slmask(len), tsfcl0(len) - real (kind=kind_io8), allocatable :: slmask_noice(:) -! - logical lanom, gaus, first -! -! set z0 based on sib vegetation type - real (kind=kind_io8) z0_sib(13) - data z0_sib /2.653, 0.826, 0.563, 1.089, 0.854, 0.856, - & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125, - & 0.011 / -! set z0 based on igbp vegetation type - real (kind=kind_io8) z0_igbp_min(20), z0_igbp_max(20) - real (kind=kind_io8) z0_season(12) - data z0_igbp_min /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, - & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, - & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, - & 0.050, 0.030/ - data z0_igbp_max /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, - & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, - & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, - & 0.050, 0.030/ -! -! dayhf : julian day of the middle of each month -! - real (kind=kind_io8) dayhf(13) - data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, - & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ -! - real (kind=kind_io8) fha(5) - real(4) fha4(5) - integer w3kindreal,w3kindint - integer ida(8),jda(8),ivtyp, kpd7 -! - real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:), - & zor(:,:),wet(:,:), - & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:), - & tg3(:), alb(:,:,:), alf(:,:), - & vet(:), sot(:), tsf2(:), - & veg(:,:), stc(:,:,:) - &, vmn(:), vmx(:), slp(:), absm(:) -! - integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2 - data first/.true./ - data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/ -! - save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, - & alb, alf, vet, sot, tsf2, veg, stc, - & vmn, vmx, slp, absm, - & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, - & landice_cat -! - logical lprnt -! - do i=1,len - tsfclm(i) = 0.0 - tsfcl2(i) = 0.0 - snoclm(i) = 0.0 - wetclm(i) = 0.0 - zorclm(i) = 0.0 - aisclm(i) = 0.0 - tg3clm(i) = 0.0 - acnclm(i) = 0.0 - cvclm(i) = 0.0 - cvbclm(i) = 0.0 - cvtclm(i) = 0.0 - cnpclm(i) = 0.0 - sliclm(i) = 0.0 - scvclm(i) = 0.0 - vmnclm(i) = 0.0 - vmxclm(i) = 0.0 - slpclm(i) = 0.0 - absclm(i) = 0.0 - enddo - do k=1,lsoil - do i=1,len - smcclm(i,k) = 0.0 - stcclm(i,k) = 0.0 - enddo - enddo - do k=1,4 - do i=1,len - albclm(i,k) = 0.0 - enddo - enddo - do k=1,2 - do i=1,len - alfclm(i,k) = 0.0 - enddo - enddo -! - iret = 0 - monend = 9999 -! - if (first) then -! -! allocate variables to be saved -! - allocate (tsf(len,2), sno(len,2), zor(len,2), - & wet(len,2), ais(len,2), acn(len,2), - & scv(len,2), smc(len,lsoil,2), - & tg3(len), alb(len,4,2), alf(len,2), - & vet(len), sot(len), tsf2(len), -!clu [+1l] add vmn, vmx, slp, abs - & vmn(len), vmx(len), slp(len), absm(len), - & veg(len,2), stc(len,lsoil,2)) -! -! get tsf climatology for the begining of the forecast -! - if (fh > 0.0) then -!cbosu - if (me == 0) print*,'bosu fh gt 0' - - iy4 = iy - if (iy < 101) iy4 = 1900 + iy4 - fha = 0 - ida = 0 - jda = 0 -! fha(2) = nint(fh) - ida(1) = iy - ida(2) = im - ida(3) = id - ida(5) = ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal == 4) then - fha4 = fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy = jda(1) - jm = jda(2) - jd = jda(3) - jh = jda(5) - if (me == 0) write(6,*) ' forecast jy,jm,jd,jh', - & jy,jm,jd,jh - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday = jdoy + jda(5) / 24. - if(rjday < dayhf(1)) rjday = rjday + 365. -! - if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! -! for monthly mean climatology -! - monend = 12 - do mm=1,monend - mmm = mm - mmp = mm + 1 - if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then - mon1 = mmm - mon2 = mmp - go to 10 - endif - enddo - print *,'wrong rjday',rjday - call abort - 10 continue - wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! read monthly mean climatology of tsf -! - kpd7 = -1 - do nn=1,2 - mon = mon1 - if (nn == 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo -! -! tsf at the begining of forecast i.e. fh=0 -! - do i=1,len - tsfcl0(i) = wei1m * tsf(i,1) + wei2m * tsf(i,2) - enddo - endif - endif -! -! compute current jy,jm,jd,jh of forecast and the day of the year -! - iy4 = iy - if (iy < 101) iy4=1900+iy4 - fha = 0 - ida = 0 - jda = 0 - fha(2) = nint(fh) - ida(1) = iy - ida(2) = im - ida(3) = id - ida(5) = ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal == 4) then - fha4 = fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy = jda(1) - jm = jda(2) - jd = jda(3) - jh = jda(5) -! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', -! & jy,jm,jd,jh,rjday - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday = jdoy + jda(5) / 24. - if(rjday < dayhf(1)) rjday = rjday + 365. - - if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me == 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! -! for monthly mean climatology -! - monend = 12 - do mm=1,monend - mmm = mm - mmp = mm + 1 - if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then - mon1 = mmm - mon2 = mmp - go to 20 - endif - enddo - print *,'wrong rjday',rjday - call abort - 20 continue - wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! for seasonal mean climatology -! - monend = 4 - is = im/3 + 1 - if (is == 5) is = 1 - do mm=1,monend - mmm = mm*3 - 2 - mmp = (mm+1)*3 - 2 - if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then - sea1 = mmm - sea2 = mmp - go to 30 - endif - enddo - print *,'wrong rjday',rjday - call abort - 30 continue - wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1)) - wei2s = 1.0 - wei1s -! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) - if (sea2 == 13) sea2 = 1 - if (me == 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', - & rjday,sea1,sea2,wei1s,wei2s -! -! for summer and winter values (maximum and minimum). -! - monend = 2 - is = im/6 + 1 - if (is == 3) is = 1 - do mm=1,monend - mmm = mm*6 - 5 - mmp = (mm+1)*6 - 5 - if(rjday >= dayhf(mmm) .and. rjday < dayhf(mmp)) then - hyr1 = mmm - hyr2 = mmp - go to 31 - endif - enddo - print *,'wrong rjday',rjday - call abort - 31 continue - wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1)) - wei2y = 1.0 - wei1y -! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) - if (hyr2 == 13) hyr2 = 1 - if (me == 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', - & rjday,hyr1,hyr2,wei1y,wei2y -! -! start reading in climatology and interpolate to the date -! - first_time : if (first) then -!cbosu - if (me == 0) print*,'bosu first time thru' -! -! annual mean climatology -! -! fraction of vegetation field for albedo -- there are two -! fraction fields in this version: strong zenith angle dependent -! and weak zenith angle dependent -! - kpd9 = -1 -cjfe - alf=0. -cjfe - - kpd7=-1 - if (ialb == 1) then -!cbosu still need facsf and facwf. read them from the production -!cbosu file - if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask - &, alf,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnalbc2, tile_num_ch, i_index, j_index, - & kpdalf(1), alf(:,1), 1, len, me) - endif - else - call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask - &, alf,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif - do i = 1, len - if(slmask(i).eq.1.) then - alf(i,2) = 100. - alf(i,1) - endif - enddo -! -! deep soil temperature -! - if(fntg3c(1:8).ne.' ') then - if ( index(fntg3c, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, - & tg3,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fntg3c, tile_num_ch, i_index, j_index, - & kpdtg3, tg3, 1, len, me) - endif - endif -! -! vegetation type -! -! when using the new gldas soil moisture climatology, a veg type -! dataset must be selected. -! - if(fnvetc(1:8).ne.' ') then - if ( index(fnvetc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, - & vet,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - landice_cat=13 - if (maxval(vet)> 13.0) landice_cat=15 - else - call fixrdc_tile(fnvetc, tile_num_ch, i_index, j_index, - & kpdvet, vet, 1, len, me) - landice_cat=15 - endif - if (me .eq. 0) write(6,*) 'climatological vegetation', - & ' type read in.' - elseif(index(fnsmcc,'soilmgldas') /= 0) then ! new soil moisture climo - if (me .eq. 0) write(6,*) 'fatal error: must choose' - if (me .eq. 0) write(6,*) 'climatological veg type when' - if (me .eq. 0) write(6,*) 'using new gldas soil moisture.' - call abort - endif -! -! soil type -! - if(fnsotc(1:8).ne.' ') then - if ( index(fnsotc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, - & sot,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnsotc, tile_num_ch, i_index, j_index, - & kpdsot, sot, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological soil type read in.' - endif - -! -! min vegetation cover -! - if(fnvmnc(1:8).ne.' ') then - if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, - & vmn,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvmnc, tile_num_ch, i_index, j_index, - & 257, vmn, 99, len, me) - - endif - if (me .eq. 0) write(6,*) 'climatological shdmin read in.' - endif -! -! max vegetation cover -! - if(fnvmxc(1:8).ne.' ') then - if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, - & vmx,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvmxc, tile_num_ch, i_index, j_index, - & 256, vmx, 99, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological shdmax read in.' - endif -! -! slope type -! - if(fnslpc(1:8).ne.' ') then - if ( index(fnslpc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, - & slp,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnslpc, tile_num_ch, i_index, j_index, - & kpdslp, slp, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological slope read in.' - endif -! -! max snow albeod -! - if(fnabsc(1:8).ne.' ') then - if ( index(fnabsc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, - & absm,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index, - & kpdabs, absm, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological snoalb read in.' - endif -!clu ---------------------------------------------------------------------- -! - is1 = sea1/3 + 1 - is2 = sea2/3 + 1 - if (is1 .eq. 5) is1 = 1 - if (is2 .eq. 5) is2 = 1 - do nn=1,2 -! -! seasonal mean climatology - if(nn.eq.1) then - isx=is1 - else - isx=is2 - endif - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 -! -! seasonal mean climatology -! -! albedo -! there are four albedo fields in this version: -! two for strong zeneith angle dependent (visible and near ir) -! and two for weak zeneith angle dependent (vis ans nir) -! - if (ialb == 0) then - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - endif -! -! monthly mean climatology -! - mon = mon1 - if (nn .eq. 2) mon = mon2 -!cbosu -!cbosu new snowfree albedo database is monthly. - if (ialb == 1) then - if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - else - do k = 1, 4 - call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, - & kpdalb(k), alb(:,k,nn), mon, len, me) - enddo - endif - endif - -! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2 -! -! tsf at the current time t -! - kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn -! -! tsf...at time t-deltsfc -! -! fh2 = fh - deltsfc -! if (fh2 .gt. 0.0) then -! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, -! & iy,im,id,ih,fh2,tsfcl2,len,iret -! &, imsk, jmsk, slmskh, gaus,blno, blto -! &, outlat, outlon, me) -! else -! do i=1,len -! tsfcl2(i) = tsfclm(i) -! enddo -! endif -! -! soil wetness -! - if(fnwetc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, - & wet(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnsmcc(1:8).ne.' ') then - if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data - kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, - & smc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - smc(i,l,nn) = smc(i,lsoil,nn) - enddo - enddo - else ! the new gldas data. it does not have data defined at landice - ! points. so for efficiency, don't have fixrdc try to - ! find a value at landice points as defined by the vet type (vet). - allocate(slmask_noice(len)) - slmask_noice=1.0 - do i = 1, len - if (nint(vet(i)) < 1 .or. - & nint(vet(i)) == landice_cat) then - slmask_noice(i) = 0.0 - endif - enddo - do k = 1, lsoil - if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) - if (k==2) kpd7=2600 ! 10_40 cm - if (k==3) kpd7=10340 ! 40_100 cm - if (k==4) kpd7=25800 ! 100_200 cm - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, - & smc(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - deallocate(slmask_noice) - endif - else - write(6,*) 'climatological soil wetness file not given' - call abort - endif -! -! soil temperature -! - if(fnstcc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, - & stc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - stc(i,l,nn) = stc(i,lsoil,nn) - enddo - enddo - endif -! -! sea ice -! - kpd7=-1 - if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, - & acn(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, - & ais(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - write(6,*) 'climatological ice cover file not given' - call abort - endif -! -! snow depth -! - kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, - & sno(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! snow cover -! - if(fnscvc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, - & scv(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - write(6,*) 'climatological snow cover read in.' - endif -! -! surface roughness -! - if(fnzorc(1:3) == 'sib') then - if (me == 0) then - write(6,*) 'roughness length to be set from sib veg type' - endif - elseif(fnzorc(1:4) == 'igbp') then - if (me == 0) then - write(6,*) 'roughness length to be set from igbp veg type' - endif - else - kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, - & zor(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -! - do i = 1, len -! set clouds climatology to zero - cvclm (i) = 0. - cvbclm(i) = 0. - cvtclm(i) = 0. -! - cnpclm(i) = 0. !set canopy water content climatology to zero - enddo -! -! vegetation cover -! - if(fnvegc(1:8).ne.' ') then - if ( index(fnvegc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, - & veg(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, - & kpdveg, veg(:,nn), mon, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological vegetation', - & ' cover read in for mon=',mon - endif - - enddo -! - mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2 -! - if (me == 0) print *,' mon1s=',mon1s,' mon2s=',mon2s - &,' sea1s=',sea1s,' sea2s=',sea2s -! - k1 = 1 ; k2 = 2 - m1 = 1 ; m2 = 2 -! - first = .false. - endif first_time -! -! to get tsf climatology at the previous call to sfccycle -! -! if (fh-deltsfc >= 0.0) then - rjdayh = rjday - deltsfc/24.0 -! else -! rjdayh = rjday -! endif -! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2=' -! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2 - if (rjdayh .ge. dayhf(mon1)) then - if (mon2 .eq. 1) mon2 = 13 - wei1x = (dayhf(mon2)-rjdayh)/(dayhf(mon2)-dayhf(mon1)) - wei2x = 1.0 - wei1x - if (mon2 .eq. 13) mon2 = 1 - else - rjdayh2 = rjdayh - if (rjdayh .lt. dayhf(1)) rjdayh2 = rjdayh2 + 365.0 - if (mon1s .eq. mon1) then - mon1s = mon1 - 1 - if (mon1s .eq. 0) mon1s = 12 - k2 = k1 - k1 = mod(k2,2) + 1 - mon = mon1s - kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,k1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif - mon2s = mon1s + 1 -! if (mon2s .eq. 1) mon2s = 13 - wei1x = (dayhf(mon2s)-rjdayh2)/(dayhf(mon2s)-dayhf(mon1s)) - wei2x = 1.0 - wei1x - if (mon2s .eq. 13) mon2s = 1 - do i=1,len - tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) - enddo - endif -! -!cbosu new albedo is monthly - if (sea1 .ne. sea1s) then - sea1s = sea1 - sea2s = sea2 - m1 = mod(m1,2) + 1 - m2 = mod(m1,2) + 1 -! -! seasonal mean climatology -! - isx = sea2/3 + 1 - if (isx == 5) isx = 1 - if (isx == 1) kpd9 = 12 - if (isx == 2) kpd9 = 3 - if (isx == 3) kpd9 = 6 - if (isx == 4) kpd9 = 9 -! -! albedo -! there are four albedo fields in this version: -! two for strong zeneith angle dependent (visible and near ir) -! and two for weak zeneith angle dependent (vis ans nir) -! -!cbosu - if (ialb == 0) then - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask - &, alb(1,k,m2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - endif - - endif - - if (mon1 .ne. mon1s) then - - mon1s = mon1 - mon2s = mon2 - k1 = mod(k1,2) + 1 - k2 = mod(k1,2) + 1 -! -! monthly mean climatology -! - mon = mon2 - nn = k2 -!cbosu - if (ialb == 1) then - if (me == 0) print*,'bosu 2nd time in clima for month ', - & mon, k1,k2 - if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7 = -1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - else - do k = 1, 4 - call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, - & kpdalb(k), alb(:,k,nn), mon, len, me) - enddo - endif - endif -! -! tsf at the current time t -! - kpd7 = -1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! soil wetness -! - if (fnwetc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, - & wet(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif (fnsmcc(1:8).ne.' ') then - if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data - kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, - & smc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - smc(i,l,nn) = smc(i,lsoil,nn) - enddo - enddo - else ! the new gldas data. it does not have data defined at landice - ! points. so for efficiency, don't have fixrdc try to - ! find a value at landice points as defined by the vet type (vet). - allocate(slmask_noice(len)) - slmask_noice=1.0 - do i = 1, len - if (nint(vet(i)) < 1 .or. - & nint(vet(i)) == landice_cat) then - slmask_noice(i) = 0.0 - endif - enddo - do k = 1, lsoil - if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) - if (k==2) kpd7=2600 ! 10_40 cm - if (k==3) kpd7=10340 ! 40_100 cm - if (k==4) kpd7=25800 ! 100_200 cm - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, - & smc(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - deallocate(slmask_noice) - endif - else - write(6,*) 'climatological soil wetness file not given' - call abort - endif -! -! sea ice -! - kpd7 = -1 - if (fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, - & acn(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif (fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, - & ais(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - write(6,*) 'climatological ice cover file not given' - call abort - endif -! -! snow depth -! - kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, - & sno(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! snow cover -! - if (fnscvc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, - & scv(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - write(6,*) 'climatological snow cover read in.' - endif -! -! surface roughness -! - if (fnzorc(1:3) == 'sib') then - if (me == 0) then - write(6,*) 'roughness length to be set from sib veg type' - endif - elseif(fnzorc(1:4) == 'igbp') then - if (me == 0) then - write(6,*) 'roughness length to be set from igbp veg type' - endif - else - kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, - & zor(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -! -! vegetation cover -! - if (fnvegc(1:8) .ne. ' ') then - if ( index(fnvegc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, - & veg(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, - & kpdveg, veg(:,nn), mon, len, me) - endif -! if (me .eq. 0) write(6,*) 'climatological vegetation', -! & ' cover read in for mon=',mon - endif -! - endif -! -! now perform the time interpolation -! -! when chosen, set the z0 based on the vegetation type. -! for this option to work, namelist variable fnvetc must be -! set to point at the proper vegetation type file. - if (fnzorc(1:3) == 'sib') then - if (fnvetc(1:4) == ' ') then - if (me==0) write(6,*) "must choose sib veg type climo file" - call abort - endif - zorclm = 0.0 - do i=1,len - ivtyp = nint(vet(i)) - if (ivtyp >= 1 .and. ivtyp <= 13) then - zorclm(i) = z0_sib(ivtyp) - endif - enddo - elseif(fnzorc(1:4) == 'igbp') then - if (fnvetc(1:4) == ' ') then - if (me == 0) write(6,*) "must choose igbp veg type climo file" - call abort - endif - zorclm = 0.0 - do i=1,len - ivtyp = nint(vet(i)) - if (ivtyp >= 1 .and. ivtyp <= 20) then - z0_season(1) = z0_igbp_min(ivtyp) - z0_season(7) = z0_igbp_max(ivtyp) - if (outlat(i) < 0.0) then - zorclm(i) = wei1y * z0_season(hyr2) + - & wei2y * z0_season(hyr1) - else - zorclm(i) = wei1y * z0_season(hyr1) + - & wei2y * z0_season(hyr2) - endif - endif - enddo - else - do i=1,len - zorclm(i) = wei1m * zor(i,k1) + wei2m * zor(i,k2) - enddo - endif -! - do i=1,len - tsfclm(i) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2) - snoclm(i) = wei1m * sno(i,k1) + wei2m * sno(i,k2) - cvclm(i) = 0.0 - cvbclm(i) = 0.0 - cvtclm(i) = 0.0 - cnpclm(i) = 0.0 - tsfcl2(i) = tsf2(i) - enddo -! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m -! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) -! - if (fh .eq. 0.0) then - do i=1,len - tsfcl0(i) = tsfclm(i) - enddo - endif - if (rjdayh .ge. dayhf(mon1)) then - do i=1,len - tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) - tsfcl2(i) = tsf2(i) - enddo - endif -! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x -! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) -! &,' mon1s=',mon1s,' mon2s=',mon2s -! &,' slmask=',slmask(iprnt) -! - if(fnacnc(1:8).ne.' ') then - do i=1,len - acnclm(i) = wei1m * acn(i,k1) + wei2m * acn(i,k2) - enddo - elseif(fnaisc(1:8).ne.' ') then - do i=1,len - aisclm(i) = wei1m * ais(i,k1) + wei2m * ais(i,k2) - enddo - endif -! - if(fnwetc(1:8).ne.' ') then - do i=1,len - wetclm(i) = wei1m * wet(i,k1) + wei2m * wet(i,k2) - enddo - elseif(fnsmcc(1:8).ne.' ') then - do k=1,lsoil - do i=1,len - smcclm(i,k) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2) - enddo - enddo - endif -! - if(fnscvc(1:8).ne.' ') then - do i=1,len - scvclm(i) = wei1m * scv(i,k1) + wei2m * scv(i,k2) - enddo - endif -! - if(fntg3c(1:8).ne.' ') then - do i=1,len - tg3clm(i) = tg3(i) - enddo - elseif(fnstcc(1:8).ne.' ') then - do k=1,lsoil - do i=1,len - stcclm(i,k) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2) - enddo - enddo - endif -! - if(fnvegc(1:8).ne.' ') then - do i=1,len - vegclm(i) = wei1m * veg(i,k1) + wei2m * veg(i,k2) - enddo - endif -! - if(fnvetc(1:8).ne.' ') then - do i=1,len - vetclm(i) = vet(i) - enddo - endif -! - if(fnsotc(1:8).ne.' ') then - do i=1,len - sotclm(i) = sot(i) - enddo - endif - - -!clu ---------------------------------------------------------------------- -! - if(fnvmnc(1:8).ne.' ') then - do i=1,len - vmnclm(i) = vmn(i) - enddo - endif -! - if(fnvmxc(1:8).ne.' ') then - do i=1,len - vmxclm(i) = vmx(i) - enddo - endif -! - if(fnslpc(1:8).ne.' ') then - do i=1,len - slpclm(i) = slp(i) - enddo - endif -! - if(fnabsc(1:8).ne.' ') then - do i=1,len - absclm(i) = absm(i) - enddo - endif -!clu ---------------------------------------------------------------------- -! -!cbosu diagnostic print - if (me == 0) print*,'monthly albedo weights are ', - & wei1m,' for k', k1, wei2m, ' for k', k2 - - if (ialb == 1) then - do k=1,4 - do i=1,len - albclm(i,k) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2) - enddo - enddo - else - do k=1,4 - do i=1,len - albclm(i,k) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2) - enddo - enddo - endif -! - do k=1,2 - do i=1,len - alfclm(i,k) = alf(i,k) - enddo - enddo -! -! end of climatology reads -! - return - end subroutine clima - subroutine fixrdc_tile(filename_raw, tile_num_ch, - & i_index, j_index, kpds, - & var, mon, npts, me) - use netcdf - use machine , only : kind_io8 - implicit none - character(len=*), intent(in) :: filename_raw - character(len=*), intent(in) :: tile_num_ch - integer, intent(in) :: npts, me, kpds, mon - integer, intent(in) :: i_index(npts) - integer, intent(in) :: j_index(npts) - real(kind_io8), intent(out) :: var(npts) - character(len=500) :: filename - character(len=80) :: errmsg - integer :: i, ii, ncid, t - integer :: error, id_dim - integer :: nx, ny, num_times - integer :: id_var - real(kind=4), allocatable :: dummy(:,:,:) - ii=index(filename_raw,"tileX") - - do i = 1, len(filename) - filename(i:i) = " " - enddo - - filename = filename_raw(1:ii-1) // tile_num_ch // ".nc" - - if (me == 0) print*, ' in fixrdc_tile for mon=',mon, - & ' filename=', trim(filename) - - error=nf90_open(trim(filename), nf90_nowrite, ncid) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'nx', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=nx) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'ny', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=ny) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'time', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=num_times) - if (error /= nf90_noerr) call netcdf_err(error) - - select case (kpds) - case(11) - error=nf90_inq_varid(ncid, 'substrate_temperature', id_var) - case(87) - error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) - case(159) - error=nf90_inq_varid(ncid, 'maximum_snow_albedo', id_var) - case(189) - error=nf90_inq_varid(ncid, 'visible_black_sky_albedo', id_var) - case(190) - error=nf90_inq_varid(ncid, 'visible_white_sky_albedo', id_var) - case(191) - error=nf90_inq_varid(ncid, 'near_IR_black_sky_albedo', id_var) - case(192) - error=nf90_inq_varid(ncid, 'near_IR_white_sky_albedo', id_var) - case(214) - error=nf90_inq_varid(ncid, 'facsf', id_var) - case(224) - error=nf90_inq_varid(ncid, 'soil_type', id_var) - case(225) - error=nf90_inq_varid(ncid, 'vegetation_type', id_var) - case(236) - error=nf90_inq_varid(ncid, 'slope_type', id_var) - case(256:257) - error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) - case default - print*,'fatal error in fixrdc_tile of sfcsub.F.' - print*,'unknown variable.' - call abort - end select - if (error /= nf90_noerr) call netcdf_err(error) - - allocate(dummy(nx,ny,1)) - - if (kpds == 256) then ! max veg greenness - - var = -9999. - do t = 1, num_times - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - do ii = 1,npts - var(ii) = max(var(ii), dummy(i_index(ii),j_index(ii),1)) - enddo - enddo - - elseif (kpds == 257) then ! min veg greenness - - var = 9999. - do t = 1, num_times - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - do ii = 1, npts - var(ii) = min(var(ii), dummy(i_index(ii),j_index(ii),1)) - enddo - enddo - - else - - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,mon/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - - do ii = 1, npts - var(ii) = dummy(i_index(ii),j_index(ii),1) - enddo - - endif - - deallocate(dummy) - - error=nf90_close(ncid) - - select case (kpds) - case(159) ! max snow alb - var = var * 100.0 - case(214) ! facsf - where (var < 0.0) var = 0.0 - var = var * 100.0 - case(189:192) - var = var * 100.0 - case(256:257) - var = var * 100.0 - end select - - return - - end subroutine fixrdc_tile - subroutine netcdf_err(error) - - use netcdf - implicit none - - integer,intent(in) :: error - character(len=256) :: errmsg - - errmsg = nf90_strerror(error) - print*,'fatal error in sfcsub.F: ', trim(errmsg) - call abort - - end subroutine netcdf_err - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, - & gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami - &, jj,w3kindreal,w3kindint - real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto -! -! read in grib climatology files and interpolate to the input -! grid. grib files should allow all the necessary parameters -! to be extracted from the description records. -! -! - character*500 fngrib -! character*80 fngrib, asgnstr -! - real (kind=kind_io8) slmskh(imsk,jmsk) -! - real (kind=kind_io8) gdata(len), slmask(len) - real (kind=kind_io8), allocatable :: data(:,:), rslmsk(:,:) - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) - real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) -! - logical lmask, yr2kc, gaus, ijordr - logical*1, allocatable :: lbms(:) -! - integer, intent(in) :: kpds7 - integer kpds(1000),kgds(1000) - integer jpds(1000),jgds(1000), kpds0(1000) - real (kind=kind_io8) outlat(len), outlon(len) -! - allocate(data8(1:mdata)) - allocate(lbms(mdata)) -! -! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv -! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/ -! &, kpds1_sv/-1/ -! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv -! &, rlngrb, rltgrb -! - iret = 0 -! - if (me .eq. 0) write(6,*) ' in fixrdc for mon=',mon - &,' fngrib=',trim(fngrib) -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb -! - lugi = 0 -! - lskip = -1 - jpds = -1 - jgds = -1 - jpds(5) = kpds5 - jpds(7) = kpds7 - kpds = jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - if (me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif - yr2kc = (kpds(8) / 100) .gt. 0 - kpds0 = jpds - kpds0(4) = -1 - kpds0(18) = -1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if (iret==99) write(6,*) ' field not found.' - call abort - endif -! -! handling climatology file -! - lskip = -1 - n = 0 - jpds = kpds0 - jpds(9) = mon - if(jpds(9).eq.13) jpds(9) = 1 - call w3kind(w3kindreal,w3kindint) - if (w3kindreal==8) then - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - else if (w3kindreal==4) then - allocate(data4(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) write(6,*) ' input grib file dates=', - & (kpds(i),i=8,11) - if(jret.eq.0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - imax=kgds(2) - jmax=kgds(3) - ijmax=imax*jmax - allocate (data(imax,jmax)) - do j=1,jmax - jj = (j-1)*imax - do i=1,imax - data(i,j) = data8(jj+i) - enddo - enddo - if (me .eq. 0) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax - else - write(6,*) ' error in getgb - jret=', jret - call abort - endif -! -! if (me == 0) then -! write(6,*) ' maxmin of input as is' -! kmami=1 -! call maxmin(data(1,1),ijmax,kmami) -! endif -! - call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me == 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat - endif - call subst(data,imax,jmax,dlon,dlat,ijordr) -! -! first get slmask over input grid -! - allocate (rlngrb(imax), rltgrb(jmax)) - allocate (rslmsk(imax,jmax)) - - call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, - & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk - &, gaus,blno, blto, kgds(1), kpds(4), lbms) -! write(6,*) ' kpds5=',kpds5,' lmask=',lmask -! - inttyp = 0 - if(kpds5.eq.225) inttyp = 1 - if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.236) inttyp = 1 - if(kpds5.eq.224) inttyp = 1 - if (me .eq. 0) then - if(inttyp.eq.1) print *, ' nearest grid point used' - &, ' kpds5=',kpds5, ' lmask = ',lmask - endif -! - call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, - & gdata,len,lmask,rslmsk,slmask - &, outlat, outlon,me) -! - deallocate (rlngrb, stat=iret) - deallocate (rltgrb, stat=iret) - deallocate (data, stat=iret) - deallocate (rslmsk, stat=iret) - call baclose(lugb,iret) -! - deallocate(data8) - deallocate(lbms) - return - end subroutine fixrdc - subroutine fixrda(lugb,fngrib,kpds5,slmask, - & iy,im,id,ih,fh,gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, - & rjday,blto -! -! read in grib climatology/analysis files and interpolate to the input -! dates and the grid. grib files should allow all the necessary parameters -! to be extracted from the description records. -! -! nrepmx: max number of days for going back date search -! nvalid: analysis later than (current date - nvalid) is regarded as -! valid for current analysis -! - parameter(nrepmx=15, nvalid=4) -! - character*500 fngrib -! character*80 fngrib, asgnstr -! - real (kind=kind_io8) slmskh(imsk,jmsk) -! - real (kind=kind_io8) gdata(len), slmask(len) - real (kind=kind_io8), allocatable :: data(:,:),rslmsk(:,:) - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) - real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) -! - logical lmask, yr2kc, gaus, ijordr - logical*1 lbms(mdata) -! - integer kpds(1000),kgds(1000) - integer jpds(1000),jgds(1000), kpds0(1000) - real (kind=kind_io8) outlat(len), outlon(len) -! -! dayhf : julian day of the middle of each month -! - real (kind=kind_io8) dayhf(13) - data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, - & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ -! -! mjday : number of days in a month -! - integer mjday(12) - data mjday/31,28,31,30,31,30,31,31,30,31,30,31/ -! - real (kind=kind_io8) fha(5) - real(4) fha4(5) - integer ida(8),jda(8) -! - allocate(data8(1:mdata)) - iret = 0 - monend = 9999 -! -! compute jy,jm,jd,jh of forecast and the day of the year -! - iy4=iy - if(iy.lt.101) iy4=1900+iy4 - fha=0 - ida=0 - jda=0 - fha(2)=nint(fh) - ida(1)=iy - ida(2)=im - ida(3)=id - ida(5)=ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - fha4=fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy=jda(1) - jm=jda(2) - jd=jda(3) - jh=jda(5) -! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', -! & jy,jm,jd,jh,rjday - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday=jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. - - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me .eq. 0) then - write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! - write(6,*) ' ' - write(6,*) '************************************************' - endif -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb -! - lugi = 0 -! - lskip=-1 - jpds=-1 - jgds=-1 - jpds(5)=kpds5 - kpds = jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - if (me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif - yr2kc = (kpds(8) / 100) .gt. 0 - kpds0=jpds - kpds0(4)=-1 - kpds0(18)=-1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if(iret==99) write(6,*) ' field not found.' - call abort - endif -! -! handling analysis file -! -! find record for the given hour/day/month/year -! - nrept=0 - jpds=kpds0 - lskip = -1 - iyr=jy - if(iyr.le.100) iyr=2050-mod(2050-iyr,100) - imo=jm - idy=jd - ihr=jh -! year 2000 compatible data - if (yr2kc) then - jpds(8) = iyr - else - jpds(8) = mod(iyr,1900) - endif - 50 continue - jpds( 8)=mod(iyr-1,100)+1 - jpds( 9)=imo - jpds(10)=idy -! jpds(11)=ihr - jpds(21)=(iyr-1)/100+1 - call w3kind(w3kindreal,w3kindint) - if (w3kindreal == 8) then - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - elseif (w3kindreal == 4) then - allocate (data4(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) write(6,*) ' input grib file dates=', - & (kpds(i),i=8,11) - if(jret.eq.0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - imax=kgds(2) - jmax=kgds(3) - ijmax=imax*jmax - allocate (data(imax,jmax)) - do j=1,jmax - jj = (j-1)*imax - do i=1,imax - data(i,j) = data8(jj+i) - enddo - enddo - else - if(nrept.eq.0) then - if (me .eq. 0) then - write(6,*) ' no matching dates found. start searching', - & ' nearest matching dates (going back).' - endif - endif -! -! no matching ih found. search nearest hour -! - if(ihr.eq.6) then - ihr=0 - go to 50 - elseif(ihr.eq.12) then - ihr=0 - go to 50 - elseif(ihr.eq.18) then - ihr=12 - go to 50 - elseif(ihr.eq.0.or.ihr.eq.-1) then - idy=idy-1 - if(idy.eq.0) then - imo=imo-1 - if(imo.eq.0) then - iyr=iyr-1 - if(iyr.lt.0) iyr=99 - imo=12 - endif - idy=31 - if(imo.eq.4.or.imo.eq.6.or.imo.eq.9.or.imo.eq.11) idy=30 - if(imo.eq.2) then - if(mod(iyr,4).eq.0) then - idy=29 - else - idy=28 - endif - endif - endif - ihr=-1 - if (me .eq. 0) write(6,*) ' decremented dates=', - & iyr,imo,idy,ihr - nrept=nrept+1 - if(nrept.gt.nvalid) iret=-1 - if(nrept.gt.nrepmx) then - if (me .eq. 0) then - write(6,*) ' searching range exceeded.' - &, ' may be wrong grib file given' - write(6,*) ' fngrib=',trim(fngrib) - write(6,*) ' terminating search and', - & ' and setting gdata to -999' - write(6,*) ' range max=',nrepmx - endif -! imax=kgds(2) -! jmax=kgds(3) -! ijmax=imax*jmax -! do ij=1,ijmax -! data(ij)=0. -! enddo - go to 100 - endif - go to 50 - else - if (me .eq. 0) then - write(6,*) ' search of analysis for ihr=',ihr,' failed.' - write(6,*) ' kpds=',kpds - write(6,*) ' iyr,imo,idy,ihr=',iyr,imo,idy,ihr - endif - go to 100 - endif - endif -! - 80 continue -! if (me == 0) then -! write(6,*) ' maxmin of input as is' -! kmami=1 -! call maxmin(data(1,1),ijmax,kmami) -! endif -! - call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me == 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat - endif - call subst(data,imax,jmax,dlon,dlat,ijordr) -! -! first get slmask over input grid -! - allocate (rlngrb(imax), rltgrb(jmax)) - allocate (rslmsk(imax,jmax)) - call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, - & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk -! & data,imax,jmax,abs(dlon),abs(dlat),lmask,rslmsk -!cggg &, gaus,blno, blto, kgds(1)) - &, gaus,blno, blto, kgds(1), kpds(4), lbms) - -! write(6,*) ' kpds5=',kpds5,' lmask=',lmask -! - inttyp = 0 - if(kpds5.eq.225) inttyp = 1 - if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.66) inttyp = 1 - if(inttyp.eq.1) print *, ' nearest grid point used' -! - call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, - & gdata,len,lmask,rslmsk,slmask - &, outlat, outlon, me) -! - deallocate (rlngrb, stat=iret) - deallocate (rltgrb, stat=iret) - deallocate (data, stat=iret) - deallocate (rslmsk, stat=iret) - call baclose(lugb,iret2) -! write(6,*) ' ' - deallocate(data8) - return -! - 100 continue - iret=1 - do i=1,len - gdata(i) = -999. - enddo -! - call baclose(lugb,iret2) -! - deallocate(data8) - return - end subroutine fixrda - subroutine snodpth2(glacir,snwmax,snoanl, len, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,me,len - real (kind=kind_io8) snwmax -! - real (kind=kind_io8) snoanl(len), glacir(len) -! - if (me .eq. 0) write(6,*) 'snodpth2' -! - do i=1,len -! -! if glacial points has snow in climatology, set sno to snomax -! - if(glacir(i).ne.0..and.snoanl(i).lt.snwmax*0.5) then - snoanl(i) = snwmax + snoanl(i) - endif -! - enddo - return - end diff --git a/sorc/global_chgres.fd/surface_chgres.f90 b/sorc/global_chgres.fd/surface_chgres.f90 deleted file mode 100755 index 7b57ab69d..000000000 --- a/sorc/global_chgres.fd/surface_chgres.f90 +++ /dev/null @@ -1,2992 +0,0 @@ -!> @file -!! -!! interpolate land fields from one grid to another. -!! -!! a collection of routines to interpolate land fields -!! from one grid to another. -!! -!! program history log: -!! 2005-10-25 gayno - initial version -!! 2006-04-25 gayno - use ipolates library to interpolate -!! continous fields. modified for use -!! with gfs and wrf. -!! 2011-07-01 Moorthi - Added unfiltered orography for angulation correction -!! 2019-06-10 Ramstrom - Allow processing of tile numbers >= 10 for multiple -!! nests -!! 2019-06-12 Ramstrom - Allow processing of all-ocean nest; suppress errors -!! from null land variable interpolation -!! -!! @author gayno @date 2005-10-25 -!! - module surface_chgres -!----------------------------------------------------------------------- -! some variable definitions. -! -! climo_fields_opt option for determining climo fields on -! output grid. 1 ONLY!! -! 1-interpolate all from input grid -! 2-interpolate veg, soil, slope type -! from input grid. others from -! sfccycle program. -! 3-all from sfccycle program. -! landice_opt 1-no landice input grid -> landice output grid -! 2-landice input grid -> landice output grid -! 3-no landice input grid -> no landice output grid -! 4-landice input grid -> no landice output grid -! 5-landice output grid regardless of whether -! input grid has landice or not. -!----------------------------------------------------------------------- - - integer, private :: climo_fields_opt ! only for 1 - integer, private :: landice_opt - - integer, allocatable, private :: iindx_output(:) - integer, allocatable, private :: jindx_output(:) - - real, private :: mdl_res_input ! model resol in degrees - real, private :: mdl_res_output ! model resol in degrees - -!----------------------------------------------------------------------- -! these are flag values for veg and soil type at land ice points. -! they depend on the raw data source used. -! -! zobler soil type -> 9 -! statsgo soil type -> 16 -! usgs veg type -> 24 -! sib veg type -> 13 -! igbp veg type -> 15 -!----------------------------------------------------------------------- - - integer, private :: veg_type_ice - integer, private :: veg_type_ice_input - integer, private :: soil_type_ice - -!----------------------------------------------------------------------- -! note: "_input" refers to the input grid, "_output" refers -! to the output grid, "_output_ext" refers to data on output grid -! from an external process, such as sfccycle or gayno's wrf si. -! -! smcref_input/output onset of soil moisture stress -! smcdry_input/output air dry soil moisture limit -! smcwilt_input/output plant wilting point -! smclow_input/output soil moisture scalar multiplier -! smchigh_input/output soil moisture scalar multiplier -! smcmax_input/output maximum soil moisture content -! beta_input/output soil 'b' parameter -! psis_input/output saturated soil potential -! satdk_input/output saturated soil hydraulic conductivity -!----------------------------------------------------------------------- - - integer, parameter, private :: max_soil_types=50 - integer, parameter, private :: max_veg_types=50 - real, private :: salp_output - real, private :: snup_output(max_veg_types) - - real, private :: beta_input(max_soil_types) - real, private :: beta_output(max_soil_types) - real, private :: psis_input(max_soil_types) - real, private :: psis_output(max_soil_types) - real, private :: satdk_input(max_soil_types) - real, private :: satdk_output(max_soil_types) - real, private :: smcdry_input(max_soil_types) - real, private :: smcdry_output(max_soil_types) - real, private :: smchigh_input - real, private :: smchigh_output - real, private :: smclow_input - real, private :: smclow_output - real, private :: smcmax_input(max_soil_types) - real, private :: smcmax_output(max_soil_types) - real, private :: smcref_input(max_soil_types) - real, private :: smcref_output(max_soil_types) - real, private :: smcwilt_input(max_soil_types) - real, private :: smcwilt_output(max_soil_types) - -!---------------------------------------------------------------------- -! note: "_input" refers to the input grid, "_output" refers -! to the output grid, "_output_ext" refers to data on output grid -! from an external process, such as sfccycle or gayno's wrf si. -! -! when the modis data/new radiation treatment (ialb=1) is -! selected, these arrays hold (gfs): -! --------------------------------------------------------------------- -! -! alnsf - near ir blacksky albedo -! alnwf - near ir whitesky albedo -! alvsf - visible blacksky albedo -! alvwf - visible whitesky albedo -! -! --------------------------------------------------------------------- -! when the one degree data/older radiation treatment (ialb=0) is -! selected, these arrays hold (gfs): -! --------------------------------------------------------------------- -! -! alnsf - near ir albedo, strong cosz dependence -! alnwf - near ir albedo, weak cosz dependence -! alvsf - vis albedo, strong cosz dependence -! alvwf - vis albedo, weak cosz dependence -! -! --------------- -! other variables: -! --------------- -! -! albedo - include effects of snow cover - wrf/nam -! canopy_mc - canopy moisture content -! facsf - fraction, strong cosz dependence -! facwf - fraction, weak cosz dependence -! sea_ice_fract - sea ice fraction, decimal -! greenfrc - greenness fraction -! greenfrc_max - max annual greenness fraction -! greenfrc_min - min annual greenness fraction -! sea_ice_depth - sea ice depth -! lsmask - land/sea mask -! mxsnow_alb - maximum snow albedo -! orog - orography -! sea_ice_flag - yes/no sea ice flag -! skin_temp - skin temperature, sst over water -! snow_depth - physical snow depth -! snow_free_albedo - wrf/nam radiation package -! snow_liq_equiv - liq equivalent snow depth -! soilm_liq - liquid soil moisture -! soilm_tot - total soil moisture -! soil_temp - soil temperature -! slope_type - soil slope type (category) -! soil_type - soil type (category) -! substrate_temp - soil substrate temperature -! veg_type - vegetation type (category) -! z0 - roughness length -!----------------------------------------------------------------------- - - integer, allocatable, private :: slope_type_output_ext(:) - integer, allocatable, private :: soil_type_output_ext(:) - integer, allocatable, private :: veg_type_output_ext(:) - - real, allocatable, private :: alnsf_output_ext(:) - real, allocatable, private :: alnwf_output_ext(:) - real, allocatable, private :: alvsf_output_ext(:) - real, allocatable, private :: alvwf_output_ext(:) - real, allocatable, private :: facsf_output_ext(:) - real, allocatable, private :: facwf_output_ext(:) - real, allocatable, private :: greenfrc_output_ext(:) - real, allocatable, private :: greenfrc_max_output_ext(:) - real, allocatable, private :: greenfrc_min_output_ext(:) - real, allocatable, private :: mxsnow_alb_output_ext(:) - real, allocatable, private :: snow_free_albedo_output_ext(:) - real, allocatable, private :: substrate_temp_output_ext(:) - real, allocatable, private :: z0_output_ext(:) - -!----------------------------------------------------------------------- -! these structures are to be used by the program that uses this -! module to hold the input and output data. -!----------------------------------------------------------------------- - - type, public :: sfc1d - real, allocatable :: albedo(:) - real, allocatable :: alnsf(:) - real, allocatable :: alnwf(:) - real, allocatable :: alvsf(:) - real, allocatable :: alvwf(:) - real, allocatable :: canopy_mc(:) - real, allocatable :: facsf(:) - real, allocatable :: facwf(:) - real, allocatable :: sea_ice_fract(:) - real, allocatable :: greenfrc(:) - real, allocatable :: greenfrc_max(:) - real, allocatable :: greenfrc_min(:) - real, allocatable :: sea_ice_depth(:) - real, allocatable :: lats(:) - real, allocatable :: lons(:) - real, allocatable :: lsmask(:) - real, allocatable :: mxsnow_alb(:) - real, allocatable :: orog(:) - real, allocatable :: sea_ice_temp(:) - real, allocatable :: skin_temp(:) - real, allocatable :: snow_depth(:) - real, allocatable :: snow_free_albedo(:) - real, allocatable :: snow_liq_equiv(:) - real, allocatable :: soilm_liq(:,:) - real, allocatable :: soilm_tot(:,:) - real, allocatable :: soil_temp(:,:) - real, allocatable :: substrate_temp(:) - real, allocatable :: z0(:) - integer, allocatable :: sea_ice_flag(:) - integer, allocatable :: slope_type(:) - integer, allocatable :: soil_type(:) - integer, allocatable :: veg_type(:) - end type sfc1d - - type, public :: sfc2d - real, allocatable :: alnsf(:,:) - real, allocatable :: alnwf(:,:) - real, allocatable :: alvsf(:,:) - real, allocatable :: alvwf(:,:) - real, allocatable :: canopy_mc(:,:) - real, allocatable :: facsf(:,:) - real, allocatable :: facwf(:,:) - real, allocatable :: sea_ice_fract(:,:) - real, allocatable :: greenfrc(:,:) - real, allocatable :: greenfrc_max(:,:) - real, allocatable :: greenfrc_min(:,:) - real, allocatable :: sea_ice_depth(:,:) - real, allocatable :: lsmask(:,:) - real, allocatable :: mxsnow_alb(:,:) - real, allocatable :: orog(:,:) - real, allocatable :: sea_ice_temp(:,:) - real, allocatable :: skin_temp(:,:) - real, allocatable :: snow_depth(:,:) - real, allocatable :: snow_liq_equiv(:,:) - real, allocatable :: snow_free_albedo(:,:) - real, allocatable :: soilm_liq(:,:,:) - real, allocatable :: soilm_tot(:,:,:) - real, allocatable :: soil_temp(:,:,:) - real, allocatable :: substrate_temp(:,:) - real, allocatable :: z0(:,:) - integer, allocatable :: sea_ice_flag(:,:) - integer, allocatable :: slope_type(:,:) - integer, allocatable :: soil_type(:,:) - integer, allocatable :: veg_type(:,:) - end type sfc2d - - contains - - subroutine surface_chgres_driver(imdl_output, jmdl_output, & - ijmdl_output, nsoil_output, & - kgds_output, output, & - imdl_input, jmdl_input, & - orog_uf,use_ufo, nst_anl, & - nsoil_input, hour, month, & - day, year, fhour, & - kgds_input, input, ialb, & - isot, ivegsrc, tile_num, merge, iret) -!$$$ subprogram documentation block -! -! subprogram: surface_chgres_driver driver routine for this module -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: call some prep routines, then call main interpolation -! routine. -! -! program history log: -! 2005-10-19 gayno - initial version -! 2006-04-25 gayno - created common interface for gfs and wrf. -! -! usage: call surface_chgres_driver(imdl_output, jmdl_output, & -! ijmdl_output, nsoil_output, & -! lonsperlat_output, & -! kgds_output, output, & -! imdl_input, jmdl_input, & -! nsoil_input, hour, month, & -! day, year, fhour, & -! kgds_input, input, ialb, & -! isot, ivegsrc, merge, iret) -! input arguments: -! day cycle day -! fhour forecast hour -! hour cycle hour -! imdl_input i-dimension, input grid -! imdl_output i-dimension, output grid -! input land data on input grid -! jmdl_input j-dimension, input grid -! jmdl_output j-dimension, output grid -! kgds_input grib grid description section of input grid -! kgds_output grib grid description section of output grid -! lonserplat_output number of i points in each j row, output grid -! month cycle month -! merge used for regional model. set to false for gfs -! nsoil_input number of soil layers, input grid -! nsoil_output number of soil layers, output grid -! year cycle year -! ialb when '1', use new bosu albedo. when '0', -! use old albedo -! isot when '1', use new statsgo soil stype. -! when '0', use zobler soi type -! ivegsrc when '1', use new igbp vegetation type. -! when '2', use sib vegetation type -! outputs: -! iret error status, non-zero if there is a -! problem in this module. -! output land data on output grid -! -! subprograms called: -! setup - read program namelist, calculate soil parameters -! get_ext_climo_global - call sfccycle program to get climo -! fields on output grid -! call interp - interpolate and initialize land states on -! output grid -! attributes: -! langauge: fortran 90 -! - implicit none - - type(sfc2d) :: input - type(sfc1d) :: output - - integer, intent(in) :: hour, month, day, year, ialb, isot, ivegsrc - integer :: i, j, ij, ii, jj - integer, intent(in) :: imdl_input - integer, intent(in) :: imdl_output - integer, intent(in) :: ijmdl_output - integer, intent(inout) :: iret - integer, intent(in) :: jmdl_input - integer, intent(in) :: jmdl_output - integer, intent(in) :: kgds_input(200) - integer, intent(in) :: kgds_output(200) - integer, intent(in) :: nsoil_input - integer, intent(in) :: nsoil_output - integer, intent(in) :: tile_num - - logical, intent(in) :: merge - - real, intent(in) :: fhour - real :: r - real, intent(in) :: orog_uf(ijmdl_output) - logical,intent(in) :: use_ufo, nst_anl - -!----------------------------------------------------------------------- -! perform various setup tasks. -!----------------------------------------------------------------------- - - iret = 0 ! becomes non-zero if there is an error in this module. - - print*,"- CALL SETUP ROUTINE" - call setup (kgds_input, input, imdl_input, jmdl_input, imdl_output, iret) - if (iret /= 0) return - -!----------------------------------------------------------------------- -! the output arrays are 1-d. keep track of their 2-d indices for -! various diagnostics. -! -! Get any output grid fixed fields (such as greenness) that are not -! to be interpolated from the input grid. for gfs, we call the -! sfccycle program, for nmm we read them in from grib files. -!----------------------------------------------------------------------- - - allocate (iindx_output(ijmdl_output)) - allocate (jindx_output(ijmdl_output)) - ij = 0 - do j = 1,jmdl_output - do i = 1, imdl_output - ij=ij+1 - iindx_output(ij)=i - jindx_output(ij)=j - enddo - enddo - - print*,'- CALL CYCLE TO GET SURFACE STATIC/CLIMO FIELDS ON OUTPUT GRIDS.' - call get_ext_climo_global(ijmdl_output, output%lsmask, output%orog, & - orog_uf,use_ufo,nst_anl, & - output, hour, month, day, year, fhour, & - ialb, isot, ivegsrc, iindx_output, & - jindx_output, tile_num) - - print*,"- CALL INTERP ROUTINE" - - call interp (imdl_input, jmdl_input, kgds_input, ijmdl_output, & - nsoil_input, nsoil_output, & - input, output, imdl_output, jmdl_output, & - kgds_output, ialb, merge, iret) - - - deallocate(iindx_output,jindx_output) - - return - - end subroutine surface_chgres_driver - - subroutine interp (imdl_input, jmdl_input, & - kgds_input, ijmdl_output, & - nsoil_input, nsoil_output, & - input, output, imdl_output, & - jmdl_output, kgds_output, ialb, merge, iret) -!$$$ subprogram documentation block -! -! subprogram: interp interpolate land states -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: interpolate land states from one grid to another. -! discreet fields (such as soil/veg type) and fields -! that are a function of these discreet fields are -! always interpolated via nearest neighbor. other -! continuous fields are interpolated by budget, -! nearest neighbor or bilinear depending on the -! resolutions of the input and output grids. one -! exception is snow, which is never interpolated -! using bilinear. -! -! program history log: -! 2005-10-19 gayno - initial version -! 2006-04-25 gayno - modified to use ipolates library. -! modified to handle both gfs and nmm. -! -! usage: call interp (imdl_input, jmdl_input, & -! kgds_input, ijmdl_output, & -! nsoil_input, nsoil_output, & -! input, output, imdl_output, & -! jmdl_output, kgds_output, merge, iret) -! -! input arguments: -! ialb 1-modis albedo data -! imdl_input i-dimension, input grid -! imdl_output i-dimension, output grid -! ijmdl_output number of grid points, output grid -! input land data on input grid -! jmdl_input j-dimension, input grid -! jmdl_output j-dimension, output grid -! kgds_input grib grid description section of input grid -! kgds_output grib grid description section of output grid -! merge set to false for gfs -! nsoil_input number of soil layers, input grid -! nsoil_output number of soil layers, output grid -! outputs: -! iret error status, non-zero if a problem -! output land data on output grid -! -! subprograms called: -! gdswzd - convert from lat/lon to x/y on a gaussian grid -! ll2xy_egrid - convert from lat/lon to x/y on an e-grid grid -! find_nn_new - finds nearest neighbor input point for each -! output point that is the same type (land, -! landice, non-land) -! adjust_soilt_for_orog - adjust soil temperature for differences in -! orography between input and output grids -! calc_albedo - calculate albedo based on snow cover -! calc_liq_soilm - calculate liquid soil moisture -! rescale_soilm - rescale soil moisture for changes in -! soil type -! -! attributes: -! langauge: fortran 90 -! - use ll2xy_utils, only : ll2xy_egrid - - use interp_utils, only : find_nn_new - - use soil_utils, only : rescale_soilm, adjust_soilt_for_orog, & - calc_liq_soilm, calc_albedo - - use gdswzd_mod - - implicit none - - character*6 :: grid_type - real, parameter :: frz_ice=271.2, frz_h20=273.16 - integer :: count_land_output, count_nonland_output - integer :: count_sea_ice_output - integer, parameter :: flag_value = -999 - integer :: i,j, ij, ii, jj, n - integer, allocatable :: ibi(:), ibo(:) - integer, intent(in) :: ijmdl_output - integer, allocatable :: ijsav_land_output(:), ijsav_nonland_output(:), & - ijsav_sea_ice_output(:) - integer, intent(in) :: ialb, imdl_input, jmdl_input - integer, intent(in) :: imdl_output, jmdl_output - integer :: ipopt(20), int_opt, no - integer :: ipopt_snow(20), int_opt_snow - integer, allocatable :: ipts(:,:),jpts(:,:) - integer, intent(inout) :: iret - integer, intent(in) :: kgds_input(200), kgds_output(200) - integer :: kgds_output_tmp(200), kgdso1 - integer, allocatable :: mask_input(:,:) - integer, allocatable :: mask_output(:) - integer :: nsoil, nret - integer, intent(in) :: nsoil_input - integer, intent(in) :: nsoil_output - integer, allocatable :: nn_iindx_wrt_input_grid(:) - integer, allocatable :: nn_jindx_wrt_input_grid(:) - integer, allocatable :: soil_type_sav(:) - - logical, intent(in) :: merge - - real :: center_lat_input, center_lon_input - real :: dx_input, dy_input - real, allocatable :: input_dat(:,:,:) - real, allocatable :: lats_land_output(:), lons_land_output(:) - real, allocatable :: lats_nonland_output(:), lons_nonland_output(:) - real, allocatable :: lats_sea_ice_output(:), lons_sea_ice_output(:) - real, allocatable :: lsmask_output_temp(:) - real, allocatable :: orog_sav(:) - real, allocatable :: output_data_nonland(:), output_data_land(:) - real, allocatable :: output_data_sea_ice(:), output_data_land2(:,:) - real, allocatable :: output_data_sea_ice2(:,:) - real, allocatable :: snow_m(:) - real, allocatable :: soilm_sav(:,:) - real, allocatable :: xindx_wrt_input_grid(:) - real, allocatable :: yindx_wrt_input_grid(:) - - logical*1, allocatable :: bitmap_land_input(:,:) - logical*1, allocatable :: bitmap_land_output(:) - logical*1, allocatable :: bitmap_sea_ice_input(:,:) - logical*1, allocatable :: bitmap_sea_ice_output(:) - logical*1, allocatable :: bitmap_nonland_input(:,:) - logical*1, allocatable :: bitmap_nonland_output(:) - logical*1, allocatable :: bitmap_land_input2(:,:,:) - logical*1, allocatable :: bitmap_land_output2(:,:) - logical*1, allocatable :: bitmap_sea_ice_input2(:,:,:) - logical*1, allocatable :: bitmap_sea_ice_output2(:,:) - logical :: rescale_soil_moist - logical :: sea_ice_defaults - logical :: veg_from_input - - type(sfc2d) :: input - type(sfc1d) :: output - -!----------------------------------------------------------------------- -! the following variables are setup for use by the ipolates routines. -! -! to properly handle coastlines, the ipolates routines are passed -! the land and non-land points separately. -!----------------------------------------------------------------------- - - iret = 0 - - count_land_output=0 - count_nonland_output=0 - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0) then - count_land_output=count_land_output+1 - else - count_nonland_output=count_nonland_output+1 - endif - enddo - - if (count_land_output == 0) then - print '("count_land_output found ZERO land points.")' - endif - if (count_nonland_output == 0) then - print '("count_nonland_output found ZERO land points.")' - endif - - -!----------------------------------------------------------------------- -! note: there are separate options for handling snow (avoid -! bilinear method). Since IPOLATES does recognize the fv3 -! grid, you can't use the budget method. -!----------------------------------------------------------------------- - - ipopt=0 - - if (mdl_res_input <= (0.75*mdl_res_output)) then - print*,"- INTERPOLATE CONTINUOUS DATA FIELDS USING BILINEAR METHOD." - kgds_output_tmp = kgds_output - kgdso1 = -1 ! for subsection of model grid. - int_opt = 0 - ipopt(1)=1 - ipopt(2) = nint(1.0 / mdl_res_input) + 1 ! search box width of 1 deg. - int_opt_snow = 2 ! use neighbor method instead for snow. - ipopt_snow = 0 - ipopt_snow(1) = nint(1.0 / mdl_res_input) + 1 ! search box width of 1 deg. - else - print*,"- INTERPOLATE CONTINUOUS DATA FIELDS USING NEIGHBOR METHOD." - ipopt(1) = nint(1.0 / mdl_res_input) + 1 ! search box width of 1 deg. - kgdso1 = -1 ! for subsection of model grid. - int_opt = 2 - int_opt_snow = int_opt - ipopt_snow = ipopt - end if - -!----------------------------------------------------------------------- -! set up bitmap to tell ipolates where the land and non-land points -! are on the input and output grids. -!----------------------------------------------------------------------- - - allocate(bitmap_land_output(count_land_output)) - bitmap_land_output = .false. - allocate(output_data_land(count_land_output)) - output_data_land=0.0 - - 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 - if (output%lsmask(ij) > 0.0) then - count_land_output=count_land_output+1 - ijsav_land_output(count_land_output)=ij - lats_land_output(count_land_output)=output%lats(ij) - lons_land_output(count_land_output)=output%lons(ij) - endif - enddo - - allocate(bitmap_land_input(imdl_input,jmdl_input)) - bitmap_land_input=.false. - where(input%lsmask > 0.0) bitmap_land_input=.true. - -! non-land - - allocate(output_data_nonland(count_nonland_output)) - output_data_nonland=0.0 - allocate(bitmap_nonland_output(count_nonland_output)) - bitmap_nonland_output = .false. - - allocate(ijsav_nonland_output(count_nonland_output)) - allocate(lats_nonland_output(count_nonland_output)) - allocate(lons_nonland_output(count_nonland_output)) - - count_nonland_output=0 - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then - count_nonland_output=count_nonland_output+1 - ijsav_nonland_output(count_nonland_output)=ij - lats_nonland_output(count_nonland_output)=output%lats(ij) - lons_nonland_output(count_nonland_output)=output%lons(ij) - endif - enddo - - allocate(bitmap_nonland_input(imdl_input,jmdl_input)) - bitmap_nonland_input=.false. - where(input%lsmask == 0.0) bitmap_nonland_input=.true. - - allocate(bitmap_sea_ice_input(imdl_input,jmdl_input)) ! sea ice - bitmap_sea_ice_input=.false. - where(input%sea_ice_flag == 1) bitmap_sea_ice_input=.true. - -!----------------------------------------------------------------------- -! given the grib gds info of the input grid, and the lats and lons of -! output grid, calculate the x/y location of the output grid points -! with respect to the input grid. -!----------------------------------------------------------------------- - - allocate (xindx_wrt_input_grid(ijmdl_output)) - allocate (yindx_wrt_input_grid(ijmdl_output)) - - print*,"- DETERMINE CORRESPONDING X/Y ON INPUT GRID" - if(kgds_input(1) == 4) then - call gdswzd(kgds_input, -1, ijmdl_output, -999.9, & - xindx_wrt_input_grid, & - yindx_wrt_input_grid, & - output%lons, output%lats, nret) - grid_type="global" - elseif(kgds_input(1) == 203) then - center_lat_input = float(kgds_input(7)) * 0.001 - center_lon_input = float(kgds_input(8)) * 0.001 - dx_input = -(float(kgds_input(199)) * 0.00001) - dy_input = float(kgds_input(200)) * 0.00001 -! because of the e-grid's stagger, the routine ll2xy_egrid routine -! outputs nearest i/j whereas the gaussian routine (based on ipolates) -! outputs a float value. the rest of this module expects a float, -! so convert temp arrays i/jpts to a float value after routine call. - allocate (ipts(imdl_input,jmdl_input)) - allocate (jpts(imdl_input,jmdl_input)) - call ll2xy_egrid(output%lats, output%lons, imdl_input, jmdl_input, & - center_lat_input, center_lon_input, dx_input, dy_input, & - imdl_output, jmdl_output, ipts, jpts) - xindx_wrt_input_grid = reshape(float(ipts),(/ijmdl_output/)) - yindx_wrt_input_grid = reshape(float(jpts),(/ijmdl_output/)) - deallocate(ipts,jpts) - grid_type="egrid" - end if - -!----------------------------------------------------------------------- -! landice points are based on the vegetation type. so, need to -! handle this field first. -!----------------------------------------------------------------------- - - veg_from_input=.true. ! get veg_type from input grid - if (allocated(veg_type_output_ext)) then - print*,'- REPLACE VEG TYPE WITH EXTERNAL DATA.' - output%veg_type = 0 - where (output%lsmask > 0.0) output%veg_type = veg_type_output_ext - veg_from_input=.false. ! veg_type from externally prepared process. - ! don't get from input grid - deallocate (veg_type_output_ext) - end if - -!----------------------------------------------------------------------- -! for each point on the output grid, find the nearest neighbor -! point on the input grid. if output point is land (landice, water), -! the nearest neighbor will always be land (landice, water). -!----------------------------------------------------------------------- - - allocate (nn_iindx_wrt_input_grid(ijmdl_output)) - allocate (nn_jindx_wrt_input_grid(ijmdl_output)) - - allocate (mask_output(ijmdl_output)) - allocate (mask_input(imdl_input,jmdl_input)) - - if (landice_opt == 2 .and. .not.(veg_from_input)) then - do j = 1, jmdl_input - do i = 1, imdl_input - if (input%lsmask(i,j) > 0.0) then - if (input%veg_type(i,j) == veg_type_ice_input) then - mask_input(i,j) = 2 - else - mask_input(i,j) = 1 - end if - else - mask_input(i,j) = 0 - endif - enddo - enddo - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0) then - if (output%veg_type(ij) == veg_type_ice) then - mask_output(ij) = 2 - else - mask_output(ij) = 1 - end if - else - mask_output(ij) = 0 - endif - enddo - else - do j = 1, jmdl_input - do i = 1, imdl_input - if (input%lsmask(i,j) > 0.0) then - mask_input(i,j) = 1 - else - mask_input(i,j) = 0 - endif - enddo - enddo - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0) then - mask_output(ij) = 1 - else - mask_output(ij) = 0 - endif - enddo - end if - - print*,"- CALC NEAREST NEIGHBOR POINTS." - call find_nn_new(imdl_input, jmdl_input, mask_input, & - ijmdl_output, mask_output, & - flag_value, grid_type, mdl_res_input, merge, & - iindx_output, jindx_output, & - xindx_wrt_input_grid, yindx_wrt_input_grid, & - nn_iindx_wrt_input_grid, & - nn_jindx_wrt_input_grid) - - deallocate (mask_output) - deallocate (mask_input) - deallocate (xindx_wrt_input_grid) - deallocate (yindx_wrt_input_grid) - -!----------------------------------------------------------------------- -! if user selects, interpolate veg type from input grid. always -! use nearest neighbor approach on this discreet field. -!----------------------------------------------------------------------- - - if (veg_from_input) then - print*,"- INTERPOLATE VEG TYPE FROM INPUT GRID" - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then ! non-land points - output%veg_type(ij) = 0 - else - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - output%veg_type(ij) = input%veg_type(ii,jj) - else ! no nearest neighbor that is land. use a default. - output%veg_type(ij) = 6 - endif - end if - enddo - end if - -!----------------------------------------------------------------------- -! sea ice flag...and when using sea ice model - fraction and depth. -! logic is as follows: -! -! no ice model input -> no ice model output : interpolate ice flag -! as 0 or 100% coverage. -! -! no ice model input -> ice model output : interpolate ice flag -! as 0 or 100% coverage. set fract and depth to default values. -! -! ice model input -> ice model output : interpolate ice fraction. -! if > 50%, set ice flag to yes. interpolate ice depth. ensure -! consistency with ice flag. -! -! ice model input -> no ice model output : interpolate ice fraction. -! if > 50%, set ice flag to yes. -!----------------------------------------------------------------------- - - if (.not. allocated (input%sea_ice_fract)) then !input grid is pre-seaice model - if (count_nonland_output > 0) then - print*,"- INTERPOLATE SEA ICE FLAG FROM INPUT GRID." - bitmap_nonland_output=.false. - output_data_nonland=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_nonland_output - allocate(ibo(1)) - allocate(input_dat(imdl_input,jmdl_input,1)) - input_dat(:,:,1)=float(input%sea_ice_flag) - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_nonland_output, & - 1, 1, bitmap_nonland_input, input_dat, & - no, lats_nonland_output, lons_nonland_output, ibo, & - bitmap_nonland_output, output_data_nonland, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! is grid all non-land? - output%sea_ice_flag = 0 ! land - do ij = 1, count_nonland_output - if (bitmap_nonland_output(ij)) then - output%sea_ice_flag(ijsav_nonland_output(ij))=nint(output_data_nonland(ij)) ! 50% or greater - else - if(abs(lats_nonland_output(ij)) > 55.0) then ! use latitude based default - output%sea_ice_flag(ijsav_nonland_output(ij))=1 ! search failed, use default - else - output%sea_ice_flag(ijsav_nonland_output(ij))=0 ! search failed, use default - end if - endif - enddo - deallocate(input_dat) - sea_ice_defaults=.true. - else ! input grid used sea ice model, - if (count_nonland_output > 0) then - print*,"- INTERPOLATE SEA ICE FRACTION FROM INPUT GRID." - bitmap_nonland_output=.false. - output_data_nonland=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_nonland_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_nonland_output, & - 1, 1, bitmap_nonland_input, input%sea_ice_fract, & - no, lats_nonland_output, lons_nonland_output, ibo, & - bitmap_nonland_output, output_data_nonland, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! is grid all non-land? - output%sea_ice_flag = 0 ! land - do ij = 1, count_nonland_output - if (bitmap_nonland_output(ij)) then - if (output_data_nonland(ij) >= .15) then ! make this a variable? - output%sea_ice_flag(ijsav_nonland_output(ij))=1 - else - output%sea_ice_flag(ijsav_nonland_output(ij))=0 - endif - else ! use a default value - if(abs(lats_nonland_output(ij)) > 55.0) then - output%sea_ice_flag(ijsav_nonland_output(ij))=1 - else - output%sea_ice_flag(ijsav_nonland_output(ij))=0 - end if - endif - enddo - sea_ice_defaults=.false. - if (allocated(output%sea_ice_fract)) then ! output grid to use sea ice model - output%sea_ice_fract = 0.0 ! land - do ij = 1, count_nonland_output - if (bitmap_nonland_output(ij)) then - if (output_data_nonland(ij) >= .15) then ! make this a variable? - output%sea_ice_fract(ijsav_nonland_output(ij))=output_data_nonland(ij) - else - output%sea_ice_fract(ijsav_nonland_output(ij))=0.0 - endif - else - if (output%sea_ice_flag(ijsav_nonland_output(ij)) == 1) then - output%sea_ice_fract(ijsav_nonland_output(ij))=1.0 - end if - endif - enddo - end if - end if - -!----------------------------------------------------------------------- -! now that we know the sea ice on the output grid, set the -! mask for ice for future ipolates calls. -!----------------------------------------------------------------------- - - count_sea_ice_output=0 - do ij = 1, ijmdl_output - if (output%sea_ice_flag(ij) == 1) then - count_sea_ice_output=count_sea_ice_output+1 - endif - enddo - - if (count_sea_ice_output > 0) then - - allocate(output_data_sea_ice(count_sea_ice_output)) - output_data_sea_ice=0.0 - allocate(bitmap_sea_ice_output(count_sea_ice_output)) - bitmap_sea_ice_output = .false. - - allocate(ijsav_sea_ice_output(count_sea_ice_output)) - allocate(lats_sea_ice_output(count_sea_ice_output)) - allocate(lons_sea_ice_output(count_sea_ice_output)) - - count_sea_ice_output=0 - do ij = 1, ijmdl_output - if (output%sea_ice_flag(ij) == 1) then - count_sea_ice_output=count_sea_ice_output+1 - ijsav_sea_ice_output(count_sea_ice_output)=ij - lats_sea_ice_output(count_sea_ice_output)=output%lats(ij) - lons_sea_ice_output(count_sea_ice_output)=output%lons(ij) - endif - enddo - - end if - -!------------------------------------------------------------------------ -! output grid to use sea ice model. -! -! if sea_ice_defaults logical is true, then the input grid did not -! run with the sea ice model, so need to set fract and depth to -! default values. -! -! if logical is false, then input grid did run with ice model. -! fraction was calculated above, so now interpolate depth. -!------------------------------------------------------------------------ - if (allocated(output%sea_ice_fract) .and. allocated(output%sea_ice_depth)) then - if (count_sea_ice_output == 0) then - output%sea_ice_fract = 0.0 - output%sea_ice_depth = 0.0 - elseif (sea_ice_defaults) then - print*,"- INITIALIZE SEA ICE FRACTION AND DEPTH WITH DEFAULT VALUES" - do ij = 1, ijmdl_output - if (output%sea_ice_flag(ij) == 1) then - output%sea_ice_fract(ij) = 1.0 - if (output%lats(ij) > 0.0) then - output%sea_ice_depth(ij) = 3.0 ! in meters - else - output%sea_ice_depth(ij) = 1.5 ! in meters - end if - else - output%sea_ice_fract(ij) = 0.0 - output%sea_ice_depth(ij) = 0.0 - endif - enddo - else - print*,"- INTERPOLATE SEA ICE DEPTH FROM INPUT GRID." - bitmap_sea_ice_output=.false. - output_data_sea_ice=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_sea_ice_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_sea_ice_output, & - 1, 1, bitmap_sea_ice_input, input%sea_ice_depth, & - no, lats_sea_ice_output, lons_sea_ice_output, & - ibo, bitmap_sea_ice_output, & - output_data_sea_ice, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - output%sea_ice_depth = 0.0 ! open water/land - do ij = 1, count_sea_ice_output - if (bitmap_sea_ice_output(ij)) then - output%sea_ice_depth(ijsav_sea_ice_output(ij)) = & - output_data_sea_ice(ij) - else ! use a default value - if (output%sea_ice_flag(ijsav_sea_ice_output(ij)) == 1) then - output%sea_ice_depth(ijsav_sea_ice_output(ij))=1.5 - end if - endif - enddo - endif - end if - -!----------------------------------------------------------------------- -! always use externally generated substrate temps as these are -! tied to the terrain. when running with land ice options, ensure -! it is below freezing. note: for wrf grids, this field is read in -! the driver and passed in. so, only need to do land ice option check. -!----------------------------------------------------------------------- - - if (kgds_output(1) == 4 .or. kgds_output(1) == 0) then ! gaussian/latlon grid - output%substrate_temp = substrate_temp_output_ext - deallocate (substrate_temp_output_ext) - end if - - if (landice_opt == 1 .or. landice_opt == 2) then - print*,"- ENSURE SUBSTRATE TEMP BELOW FREEZING AT LAND ICE." - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%substrate_temp(ij) = min(output%substrate_temp(ij), frz_h20) - endif - enddo - endif - - if (kgds_output(1) == 4 .or. kgds_output(1) == 0) goto 77 ! gaussian/latlon grid - - where (output%lsmask == 0.0) output%substrate_temp = 280.0 ! water flag - where (output%sea_ice_flag == 1) output%substrate_temp = frz_ice ! sea ice flag - - 77 continue - -!----------------------------------------------------------------------- -! treat cmc as discreet field because it is a function of veg type. -!----------------------------------------------------------------------- - print*,"- INTERPOLATE CANOPY MOISTURE CONTENT" - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then ! non-land points - output%canopy_mc(ij) = 0 - else - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - output%canopy_mc(ij) = input%canopy_mc(ii,jj) - else ! no nearest neighbor that is land. use default. - output%canopy_mc(ij) = 0 - endif - endif - enddo - -!----------------------------------------------------------------------- -! treat soil moist as discreet field because it is a function of -! soil type. note: may want to consider other interpolation -! methods in the future as long as they use a soil type "mask." -!----------------------------------------------------------------------- - print*,"- INTERPOLATE TOTAL SOIL MOISTURE" - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then ! non-land points - output%soilm_tot(ij,:) = 1.0 - else - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - if (nsoil_output == nsoil_input) then - do n = 1, nsoil_output - output%soilm_tot(ij,n) = input%soilm_tot(ii,jj,n) - enddo - elseif (nsoil_output > nsoil_input) then - output%soilm_tot(ij,1) = input%soilm_tot(ii,jj,1) - do n = 2, nsoil_output - nsoil = min(n,nsoil_input) - output%soilm_tot(ij,n) = input%soilm_tot(ii,jj,nsoil) - enddo - else ! logic hardwired for 4->2 layers with thicknesses of - ! 0-.1,.1-.4,.4-1.0,1.0-2.0 and 0-.1,1.0-2.0 meters. - output%soilm_tot(ij,1) = input%soilm_tot(ii,jj,1) - output%soilm_tot(ij,2) =(0.3*input%soilm_tot(ii,jj,2) + & - 0.6*input%soilm_tot(ii,jj,3) + & - 1.0*input%soilm_tot(ii,jj,4))/1.9 - endif - else ! no nearest neighbor that is land. use default. - ! will be overwritten later if landice. - output%soilm_tot(ij,:) = 0.2 - endif - endif - enddo - -!----------------------------------------------------------------------- -! treat roughness as a discreet field as it is tied to vegetation -! type over land. (over water, it is a state variable, so might want -! to consider an approach other than nearest neighbor someday.) -!------------------------------------------------------------------------ - print*,"- INTERPOLATE Z0 FROM INPUT GRID." - do ij = 1, ijmdl_output - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - output%z0(ij) = input%z0(ii,jj) - else ! use a default value - if (output%lsmask(ij) > 0.0) then ! points with land - output%z0(ij) = 30.0 ! cm - else - if (output%sea_ice_flag(ij) == 1) then - output%z0(ij) = 1.0 ! cm - else ! open water - output%z0(ij) = 0.01 ! cm - end if - endif - endif - enddo -!----------------------------------------------------------------------- -! replace interpolated z0 with externally generated z0 -! on the output grid (if this data was read in). the externally -! generated data is only valid over land. -!----------------------------------------------------------------------- - if (allocated(z0_output_ext)) then - print*,'- REPLACE Z0 WITH EXTERNAL DATA AT LAND POINTS.' - where(output%lsmask > 0.0) output%z0 = z0_output_ext - deallocate (z0_output_ext) - end if - -!----------------------------------------------------------------------- -! skin temperature -!----------------------------------------------------------------------- - - print*,"- INTERPOLATE SKIN TEMPERATURE FROM INPUT GRID." -! at land points - if (count_land_output > 0) then - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_land_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%skin_temp, & - no, lats_land_output, lons_land_output, ibo, & - bitmap_land_output, output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES SKIN TEMP LAND',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%skin_temp= 0.0 - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - output%skin_temp(ijsav_land_output(ij))=output_data_land(ij) - else ! default value - output%skin_temp(ijsav_land_output(ij)) = & - output%substrate_temp(ijsav_land_output(ij)) - endif - enddo - -! now do over non-land. note that skint is a mix of ice and open water temp. - if (count_nonland_output > 0) then - bitmap_nonland_output=.false. - output_data_nonland=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_nonland_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_nonland_output, & - 1, 1, bitmap_nonland_input, input%skin_temp, & - no, lats_nonland_output, lons_nonland_output, ibo, & - bitmap_nonland_output, output_data_nonland, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES SKIN TEMP NON LAND',iret - return - endif - deallocate(ibo) - endif - do ij = 1, count_nonland_output - if (bitmap_nonland_output(ij)) then - output%skin_temp(ijsav_nonland_output(ij))=output_data_nonland(ij) - else - if(abs(lats_nonland_output(ij)) >= 60.0) then - output%skin_temp(ijsav_nonland_output(ij)) = 273.16 - elseif(abs(lats_nonland_output(ij)) <= 30.0) then - output%skin_temp(ijsav_nonland_output(ij)) = 300.0 - else - output%skin_temp(ijsav_nonland_output(ij)) = (-.8947)*(abs(lats_nonland_output(ij))) + 326.84 - endif - endif - enddo - -! at sea ice points, don't let skin temp go above the freezing point. -! at open water points, don't let sst go below freezing point. - - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then - if (output%sea_ice_flag(ij) == 1) then - output%skin_temp(ij) = min(output%skin_temp(ij),frz_h20) - else - output%skin_temp(ij) = max(output%skin_temp(ij),(frz_ice+.01)) - endif - endif - enddo - -!----------------------------------------------------------------------- -! set sea ice temperature. relationship between skin temp and -! sea ice temp is: -! skint = icefract*tice + (1-icefract)*271.21 -! where 271.21K is the temp of any open water in the grid cell. -!----------------------------------------------------------------------- - if (allocated(output%sea_ice_temp)) then - do ij = 1, ijmdl_output - output%sea_ice_temp(ij) = output%skin_temp(ij) - if(output%sea_ice_flag(ij) == 1) then - output%sea_ice_temp(ij) = (output%skin_temp(ij) & - -(frz_ice)*(1.-output%sea_ice_fract(ij)))/output%sea_ice_fract(ij) - end if - enddo - end if - -!----------------------------------------------------------------------- -! soil temperature over land. treat as discreet field. -!----------------------------------------------------------------------- - allocate (orog_sav(ijmdl_output)) - orog_sav=0.0 - do n=1, nsoil_output - output%soil_temp(:,n)=output%skin_temp ! flag value open water - enddo - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0) then - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - if (nsoil_output == nsoil_input) then - do n = 1, nsoil_output - output%soil_temp(ij,n) = input%soil_temp(ii,jj,n) - enddo - elseif (nsoil_output > nsoil_input) then - output%soil_temp(ij,1) = input%soil_temp(ii,jj,1) - do n = 2, nsoil_output - nsoil = min(n,nsoil_input) - output%soil_temp(ij,n) = input%soil_temp(ii,jj,nsoil) - enddo - else ! logic hardwired for 4->2 layers with thicknesses of - ! 0-.1,.1-.4,.4-1.0,1.0-2.0 and 0-.1,1.0-2.0 meters. - output%soil_temp(ij,1) = input%soil_temp(ii,jj,1) - output%soil_temp(ij,2) =(0.3*input%soil_temp(ii,jj,2) + & - 0.6*input%soil_temp(ii,jj,3) + & - 1.0*input%soil_temp(ii,jj,4))/1.9 - endif - orog_sav(ij) = input%orog(ii,jj) - else - print*,'- *WARNING* SETTING TO DEFAULT VALUES AT POINT ', & - iindx_output(ij), jindx_output(ij) - orog_sav(ij) = output%orog(ij) ! turn off soil t adjustment - output%soil_temp(ij,:) = output%substrate_temp(ij) - endif - endif - enddo -!----------------------------------------------------------------------- -! "soil" temperature over sea ice. treat as continuous field. -! ipolates expects the number of ice levels to be the same. -! hence, the temporary variables for the input and output -! grids are both allocated to nsoil_input. the vertical -! interpolation to the output grid occurs in the logic -! after the ipolates call. -!----------------------------------------------------------------------- - - if (count_sea_ice_output > 0) then - - print*,"- INTERPOLATE SEA ICE COLUMN TEMPS FROM INPUT GRID." - allocate(bitmap_sea_ice_output2(count_sea_ice_output,nsoil_input)) - bitmap_sea_ice_output2=.false. - allocate(bitmap_sea_ice_input2(imdl_input,jmdl_input,nsoil_input)) - do n=1, nsoil_input - bitmap_sea_ice_input2(:,:,n)=bitmap_sea_ice_input - enddo - allocate(output_data_sea_ice2(count_sea_ice_output,nsoil_input)) - output_data_sea_ice2=0.0 - allocate(input_dat(imdl_input,jmdl_input,nsoil_input)) - do n=1, nsoil_input - input_dat(:,:,n)=input%soil_temp(:,:,n) - enddo - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_sea_ice_output - allocate(ibo(nsoil_input)) - allocate(ibi(nsoil_input)) - ibi=1 - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_sea_ice_output, & - nsoil_input, ibi, bitmap_sea_ice_input2, input_dat, & - no, lats_sea_ice_output, lons_sea_ice_output, ibo, & - bitmap_sea_ice_output2, output_data_sea_ice2, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate (ibi, ibo) - do ij = 1, count_sea_ice_output - if (bitmap_sea_ice_output2(ij,1)) then - if (nsoil_output == nsoil_input) then - do n = 1, nsoil_output - output%soil_temp(ijsav_sea_ice_output(ij),n) = & - output_data_sea_ice2(ij,n) - enddo - elseif (nsoil_output > nsoil_input) then - output%soil_temp(ijsav_sea_ice_output(ij),1) = & - output_data_sea_ice2(ij,1) - do n = 2, nsoil_output - nsoil = min(n,nsoil_input) - output%soil_temp(ijsav_sea_ice_output(ij),n) = & - output_data_sea_ice2(ij,nsoil) - enddo - else ! logic hardwired for 4->2 layers with thicknesses of - ! 0-.1,.1-.4,.4-1.0,1.0-2.0 and 0-.1,1.0-2.0 meters. - output%soil_temp(ijsav_sea_ice_output(ij),1) = & - output_data_sea_ice2(ij,1) - output%soil_temp(ijsav_sea_ice_output(ij),2) = & - (0.3*output_data_sea_ice2(ij,2) + & - 0.6*output_data_sea_ice2(ij,3) + & - 1.0*output_data_sea_ice2(ij,4))/1.9 - endif - else ! use a default value - output%soil_temp(ijsav_sea_ice_output(ij),:) = frz_ice - endif - enddo - deallocate (bitmap_sea_ice_output2, bitmap_sea_ice_input2, & - output_data_sea_ice2, input_dat) - - end if ! no ice - -!----------------------------------------------------------------------- -! for snow liq equiv, interpolate snow at land and sea ice points -! separately to prevent large gfs-imposed depths over land from -! influencing the snow depth at ice. -!----------------------------------------------------------------------- - - print*,"- INTERPOLATE SNOW LIQUID EQUIV FROM INPUT GRID." - -! first do snow at land points - if (count_land_output > 0) then - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_land_output - allocate(ibo(1)) - call ipolates(int_opt_snow, ipopt_snow, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%snow_liq_equiv, & - no, lats_land_output, lons_land_output, ibo, bitmap_land_output, & - output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES FOR SNOW LIQUID EQUIVALENT ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%snow_liq_equiv= 0.0 ! non-land -! the budget interpolation can spread very shallow amounts of snow over -! somewhat large areas. eliminate these. make sure these zeroed -! amounts agree with the snow depth calculated later. - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - if (int_opt == 3 .and. output_data_land(ij) < 0.2) then - output%snow_liq_equiv(ijsav_land_output(ij))=0.0 - else - output%snow_liq_equiv(ijsav_land_output(ij))=output_data_land(ij) - end if - else - if(abs(lats_land_output(ij)) > 55.0) then - output%snow_liq_equiv(ijsav_land_output(ij))= 2.5 ! search failed, use default (mm) - end if - endif - enddo - -! now do snow over sea ice. - if (count_sea_ice_output > 0) then - - bitmap_sea_ice_output=.false. - output_data_sea_ice=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_sea_ice_output - allocate(ibo(1)) - call ipolates(int_opt_snow, ipopt_snow, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_sea_ice_output, & - 1, 1, bitmap_sea_ice_input, input%snow_liq_equiv, & - no, lats_sea_ice_output, lons_sea_ice_output, ibo, & - bitmap_sea_ice_output, output_data_sea_ice, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - do ij = 1, count_sea_ice_output - if (bitmap_sea_ice_output(ij)) then - output%snow_liq_equiv(ijsav_sea_ice_output(ij))=output_data_sea_ice(ij) - endif - enddo - endif ! no ice - -!----------------------------------------------------------------------- -! set state variables when initializing a land ice run. -!----------------------------------------------------------------------- - if (landice_opt == 1 .or. landice_opt == 2) then - print*,"- INITIALIZE STATE FIELDS AT POINTS WITH PERMANENT LAND ICE" - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. output%veg_type(ij) == veg_type_ice) then - output%canopy_mc(ij) = 0.0 - output%snow_liq_equiv(ij) = max(output%snow_liq_equiv(ij),100.) ! in mm - output%soilm_tot(ij,:) = 1.0 - endif - enddo - end if - -!----------------------------------------------------------------------- -! physical snow depth. not used for pre noah lsm runs. -! -! if input data was pre noah lsm, the snow depth array on the input grid -! will not be allocated. in this case, set depth to -! 10 times the snow liquid water equivalent. -! -! when initializing land ice case, ensure depth is at least 1 meter. -!----------------------------------------------------------------------- - - if (allocated(output%snow_depth)) then - print*,"- PROCESS SNOW DEPTH" - output%snow_depth = 0.0 - if (.not. allocated (input%snow_depth)) then - print*,"- INITIALIZE SNOW DEPTH FROM LIQ EQUIV." - do ij = 1, ijmdl_output - output%snow_depth(ij) = output%snow_liq_equiv(ij)*10.0 - enddo - else - if (count_land_output > 0) then - print*,"- INTERPOLATE SNOW DEPTH FROM INPUT GRID - LAND." - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_land_output - call ipolates(int_opt_snow, ipopt_snow, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%snow_depth, & - no, lats_land_output, lons_land_output, ibo, bitmap_land_output, & - output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! are there land points? -! note: very shallow amounts of liquid equivalent are zeroed out -! when the budget interpolation is used. make sure depth is consistent. - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - if (output%snow_liq_equiv(ijsav_land_output(ij))==0.0) then - output%snow_depth(ijsav_land_output(ij))=0.0 - else - output%snow_depth(ijsav_land_output(ij))=output_data_land(ij) - end if - else ! default value. - output%snow_depth(ijsav_land_output(ij)) = & - output%snow_liq_equiv(ijsav_land_output(ij))*10.0 - endif - enddo - if (landice_opt == 1 .or. landice_opt == 2) then - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%snow_depth(ij) = max(output%snow_depth(ij),1000.) ! in mm - end if - enddo - endif -! now do snow over sea ice. - if (count_sea_ice_output > 0) then - print*,"- INTERPOLATE SNOW DEPTH FROM INPUT GRID - NON LAND." - bitmap_sea_ice_output=.false. - output_data_sea_ice=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_sea_ice_output - allocate(ibo(1)) - call ipolates(int_opt_snow, ipopt_snow, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_sea_ice_output, & - 1, 1, bitmap_sea_ice_input, input%snow_depth, & - no, lats_sea_ice_output, lons_sea_ice_output, ibo, & - bitmap_sea_ice_output, output_data_sea_ice, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - do ij = 1, count_sea_ice_output - if (bitmap_sea_ice_output(ij)) then ! ipolates found data -! ensure interpolated liq equiv is consistent with depth - if (output%snow_liq_equiv(ijsav_sea_ice_output(ij)) == 0.0) then - output%snow_depth(ijsav_sea_ice_output(ij)) = 0.0 - else - output%snow_depth(ijsav_sea_ice_output(ij))=output_data_sea_ice(ij) - endif - endif - enddo - endif ! no ice - endif - endif - -!----------------------------------------------------------------------- -! adjust soil temperatures for new orography -!----------------------------------------------------------------------- - - call adjust_soilt_for_orog(output%soil_temp, orog_sav, output%orog, & - output%lsmask, ijmdl_output, nsoil_output) - - deallocate (orog_sav) - -!----------------------------------------------------------------------- -! if input grid had landice, and output grid has landice, then -! need to ensure terrain adjustment did not raise sub-surface -! temperature above freezing. if initializing landice, -! use the substrate temp, which has already been qc'd for t>freezing. -!----------------------------------------------------------------------- - - if (landice_opt == 2) then - print*,"- ENSURE COLUMN TEMPERATURES BELOW FREEZING AT LAND ICE" - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%skin_temp(ij) = min(output%skin_temp(ij), frz_h20) - output%soil_temp(ij,:) = min(output%soil_temp(ij,:), frz_h20) - endif - enddo - endif - - if (landice_opt == 1) then - print*,"- INITIALIZE COLUMN TEMPERATURES AT POINTS WITH LAND ICE" - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%skin_temp(ij) = output%substrate_temp(ij) - output%soil_temp(ij,:) = output%substrate_temp(ij) - endif - enddo - end if - -!----------------------------------------------------------------------- -! soil type is discreet field, always use nearest neighbor. -!----------------------------------------------------------------------- - print*,"- INTERPOLATE SOIL TYPE" - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then ! non-land points - output%soil_type(ij) = 0 - else - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - output%soil_type(ij) = input%soil_type(ii,jj) - else ! no nearest neighbor that is land. use default. - if (landice_opt == 2 .and. output%veg_type(ij) == veg_type_ice) then - output%soil_type(ij) = soil_type_ice - else - output%soil_type(ij) = 2 - end if - endif - endif - enddo -!----------------------------------------------------------------------- -! the soil moisture rescaling algorithms depend on any changes to -! soil type. so, save the soil type interpolated from the input grid. -!----------------------------------------------------------------------- - rescale_soil_moist = .false. - -!----------------------------------------------------------------------- -! set soil type flag value at landice when initializing landice runs. -!----------------------------------------------------------------------- - if (landice_opt == 1) then - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%soil_type(ij) = soil_type_ice - endif - enddo - end if - - allocate(soil_type_sav(ijmdl_output)) - soil_type_sav = output%soil_type ! interpolated from input grid. - -!----------------------------------------------------------------------- -! replace interpolated soil type with externally generated soil type -! on the output grid (if this data was read in). -!----------------------------------------------------------------------- - if (allocated(soil_type_output_ext)) then - print*,'- REPLACE SOIL TYPE WITH EXTERNAL DATA.' - rescale_soil_moist = .true. - output%soil_type = 0 - where (output%lsmask > 0.0) output%soil_type = soil_type_output_ext - deallocate (soil_type_output_ext) - if (landice_opt == 1 .or. landice_opt == 2) then - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%soil_type(ij) = soil_type_ice - endif - enddo - end if - end if - -!----------------------------------------------------------------------- -! this option is used when the input grid has land ice, but the -! user does not want land ice on the output grid. need to set -! a soil moisture at these points. use the reference value for the -! soil type as a default start value. -!----------------------------------------------------------------------- - if (landice_opt == 4) then - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%soilm_tot(ij,1) > 0.99) then ! flag for landice. at these - ! points all layers are set to 1.0 - ! so just check the top layer. - soil_type_sav(ij) = output%soil_type(ij) ! turn off soilm rescaling - output%soilm_tot(ij,:) = smcref_output(output%soil_type(ij)) - endif - enddo - endif - -!----------------------------------------------------------------------- -! greenness. valid only over land. -!----------------------------------------------------------------------- - if (allocated(greenfrc_output_ext)) then - print*,'- USE EXTERNAL DATA TO SET GREENNESS.' - output%greenfrc = 0. - where(output%lsmask > 0.) output%greenfrc = greenfrc_output_ext - deallocate (greenfrc_output_ext) - else ! greenness interpolated from input grid. - if (count_land_output > 0) then - print*,"- INTERPOLATE GREENNESS FROM INPUT GRID." - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(1)) - no=count_land_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%greenfrc, & - no, lats_land_output, lons_land_output, ibo, & - bitmap_land_output, output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%greenfrc= 0.0 ! non-land - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - output%greenfrc(ijsav_land_output(ij))=output_data_land(ij) - else - output%greenfrc(ijsav_land_output(ij))=0.4 ! search failed, use default - endif - enddo - end if -!----------------------------------------------------------------------- -! once greenness is set, zero output any canopy moisture content -! at points with zero vegetation. recall, a greenness of 1% actually -! means bare ground. -!----------------------------------------------------------------------- - do ij = 1, ijmdl_output - if (output%greenfrc(ij) < 0.011) then - output%canopy_mc(ij) = 0.0 - endif - enddo -!----------------------------------------------------------------------- -! greenness is zero at landice points. -!----------------------------------------------------------------------- - if (landice_opt ==1 .or. landice_opt == 2) then - print*,"- SET GREENNESS AT LANDICE POINTS." - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%greenfrc(ij) = 0.0 - endif - enddo - end if - -!----------------------------------------------------------------------- -! min/max greenness. only processed when using the noah lsm. -!----------------------------------------------------------------------- - - if (allocated(output%greenfrc_min) .and. allocated(output%greenfrc_max)) then - if (allocated(greenfrc_min_output_ext) .and. & - allocated(greenfrc_max_output_ext)) then - print*,'- USE EXTERNAL DATA FOR MAX/MIN GREEENNESS.' - output%greenfrc_min = 0. - where(output%lsmask > 0.) output%greenfrc_min = greenfrc_min_output_ext - deallocate (greenfrc_min_output_ext) - output%greenfrc_max = 0. - where(output%lsmask > 0.) output%greenfrc_max = greenfrc_max_output_ext - deallocate (greenfrc_max_output_ext) - elseif (.not. allocated(input%greenfrc_max) .and. & - .not. allocated(input%greenfrc_min) ) then - print*,"- ABORT. INPUT FILE DOES NOT HAVE MAX/MIN GREENNESS." - iret = 99 - return - else - if (count_land_output > 0) then - print*,"- INTERPOLATE MAX/MIN GREENNESS FROM INPUT GRID." - allocate(bitmap_land_output2(count_land_output,2)) - bitmap_land_output2=.false. - allocate(bitmap_land_input2(imdl_input,jmdl_input,2)) - bitmap_land_input2(:,:,1)=bitmap_land_input - bitmap_land_input2(:,:,2)=bitmap_land_input - allocate(output_data_land2(count_land_output,2)) - output_data_land2=0.0 - allocate(input_dat(imdl_input,jmdl_input,2)) - input_dat(:,:,1)=input%greenfrc_min - input_dat(:,:,2)=input%greenfrc_max - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(2)) - no=count_land_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 2, (/1,1/), bitmap_land_input2, input_dat, & - no, lats_land_output, lons_land_output, ibo, & - bitmap_land_output2, output_data_land2, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%greenfrc_min= 0.0 ! non-land - output%greenfrc_max= 0.0 ! non-land - do ij = 1, count_land_output - if (bitmap_land_output2(ij,1)) then - output%greenfrc_min(ijsav_land_output(ij))=output_data_land2(ij,1) - else - output%greenfrc_min(ijsav_land_output(ij))=0.2 ! search failed, use default - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,2)) then - output%greenfrc_max(ijsav_land_output(ij))=output_data_land2(ij,2) - else - output%greenfrc_max(ijsav_land_output(ij))=0.5 ! search failed, use default - endif - enddo - deallocate(bitmap_land_input2, bitmap_land_output2, input_dat, output_data_land2) - end if -!----------------------------------------------------------------------- -! set greenness to zero at land ice points. -!----------------------------------------------------------------------- - if (landice_opt ==1 .or. landice_opt == 2) then - print*,"- SET MAX/MIN GREENNESS TO ZERO AT LAND ICE." - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%greenfrc_min(ij) = 0.0 - output%greenfrc_max(ij) = 0.0 - endif - enddo - end if - end if - -!----------------------------------------------------------------------- -! slope type not used for pre-noah lsm runs. treat as discreet field. -!----------------------------------------------------------------------- - if (allocated (output%slope_type)) then - if (allocated(slope_type_output_ext)) then - print*,'- USE EXTERNAL DATA FOR SLOPE TYPE.' - output%slope_type = 0 - where (output%lsmask > 0.0) output%slope_type = slope_type_output_ext - deallocate (slope_type_output_ext) - elseif (.not. allocated (input%slope_type)) then - print*,"- ABORT. INPUT FILE DOES NOT HAVE SLOPE TYPE." - iret = 99 - return - else ! interpolate from input grid - print*,'- INTERPOLATE SLOPE TYPE FROM INPUT GRID.' - do ij = 1, ijmdl_output - if (output%lsmask(ij) == 0.0) then ! non-land points - output%slope_type(ij) = 0 - else - if ( (nn_iindx_wrt_input_grid(ij) /= flag_value) .and. & - (nn_jindx_wrt_input_grid(ij) /= flag_value) ) then - ii = nn_iindx_wrt_input_grid(ij) - jj = nn_jindx_wrt_input_grid(ij) - output%slope_type(ij) = input%slope_type(ii,jj) - else ! no nearest neighbor that is land. use default. - output%slope_type(ij) = 2 - endif - endif - enddo - end if - if (landice_opt == 1 .or. landice_opt == 2) then - print*,"- INITIALIZE SLOPE TYPE AT LANDICE POINTS." - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - output%slope_type(ij) = 9 - endif - enddo - end if - end if - -!----------------------------------------------------------------------- -! snow free albedo. note: at non-land points, the gfs calculates -! albedo internally. for surface files prior to 200501, the -! albedo was set to a flag value of 0.01, otherwise, it is set to -! 0.06. -!----------------------------------------------------------------------- - - SNOWFREE_ALB : if (allocated(output%alvsf)) then ! using 4 component albedo - - if (allocated(alvsf_output_ext) .and. & - allocated(alnsf_output_ext) .and. & - allocated(alnwf_output_ext) .and. & - allocated(alvwf_output_ext) .and. & - allocated(facsf_output_ext) .and. & - allocated(facwf_output_ext)) then - if (allocated(output%sea_ice_fract) .and. & - allocated(output%sea_ice_depth) ) then ! surface file is ivs 200501 - output%alvsf = 0.06 - output%alnsf = 0.06 - output%alnwf = 0.06 - output%alvwf = 0.06 - else ! surface file prior to ivs 200501 - output%alvsf = 0.01 - output%alnsf = 0.01 - output%alnwf = 0.01 - output%alvwf = 0.01 - endif - print*,'- SET ALVSF WITH EXTERNAL DATA OVER LAND' - where (output%lsmask > 0.0) output%alvsf = alvsf_output_ext - deallocate (alvsf_output_ext) - print*,'- SET ALNSF WITH EXTERNAL DATA OVER LAND' - where (output%lsmask > 0.0) output%alnsf = alnsf_output_ext - deallocate (alnsf_output_ext) - print*,'- SET ALNWF WITH EXTERNAL DATA OVER LAND' - where (output%lsmask > 0.0) output%alnwf = alnwf_output_ext - deallocate (alnwf_output_ext) - print*,'- SET ANVWF WITH EXTERNAL DATA OVER LAND' - where (output%lsmask > 0.0) output%alvwf = alvwf_output_ext - deallocate (alvwf_output_ext) - print*,'- SET FACSF WITH EXTERNAL DATA OVER LAND' - output%facsf = 0.0 ! non-land - where (output%lsmask > 0.0) output%facsf = facsf_output_ext - deallocate (facsf_output_ext) - print*,'- SET FACWF WITH EXTERNAL DATA OVER LAND' - output%facwf = 0.0 - where (output%lsmask > 0.0) output%facwf = facwf_output_ext - deallocate (facwf_output_ext) - else ! interp from input grid. - if (count_land_output > 0) then - print*,"- INTERP SNOW-FREE ALBEDO FROM INPUT GRID" - allocate(bitmap_land_output2(count_land_output,6)) - bitmap_land_output2=.false. - allocate(bitmap_land_input2(imdl_input,jmdl_input,6)) - bitmap_land_input2(:,:,1)=bitmap_land_input - bitmap_land_input2(:,:,2)=bitmap_land_input - bitmap_land_input2(:,:,3)=bitmap_land_input - bitmap_land_input2(:,:,4)=bitmap_land_input - bitmap_land_input2(:,:,5)=bitmap_land_input - bitmap_land_input2(:,:,6)=bitmap_land_input - allocate(output_data_land2(count_land_output,6)) - output_data_land2=0.0 - allocate(input_dat(imdl_input,jmdl_input,6)) - input_dat(:,:,1)=input%alnsf - input_dat(:,:,2)=input%alnwf - input_dat(:,:,3)=input%alvsf - input_dat(:,:,4)=input%alvwf - input_dat(:,:,5)=input%facsf - input_dat(:,:,6)=input%facwf - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - allocate(ibo(6)) - no=count_land_output - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 6, (/1,1,1,1,1,1/), bitmap_land_input2, input_dat, & - no, lats_land_output, lons_land_output, ibo, & - bitmap_land_output2, output_data_land2, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES SNOW-FREE ALBEDO ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%facsf=0.0 ! non-land - output%facwf=0.0 ! non-land - if (allocated(output%sea_ice_fract) .and. & ! non-land points - allocated(output%sea_ice_depth) ) then ! surface file is ivs 200501 - output%alnsf=0.06 - output%alnwf=0.06 - output%alvsf=0.06 - output%alvwf=0.06 - else - output%alnsf=0.01 - output%alnwf=0.01 - output%alvsf=0.01 - output%alvwf=0.01 - endif - do ij = 1, count_land_output - if (bitmap_land_output2(ij,1)) then - output%alnsf(ijsav_land_output(ij))=output_data_land2(ij,1) - else - if (ialb == 1) then ! modis data - output%alnsf(ijsav_land_output(ij))=0.30 ! search failed, use default - else ! 1 degree gfs data - output%alnsf(ijsav_land_output(ij))=0.25 ! search failed, use default - endif - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,2)) then - output%alnwf(ijsav_land_output(ij))=output_data_land2(ij,2) - else - if (ialb == 1) then ! modis - output%alnwf(ijsav_land_output(ij))=0.29 ! search failed, use default - else ! 1 degree gfs data - output%alnwf(ijsav_land_output(ij))=0.2 ! search failed, use default - endif - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,3)) then - output%alvsf(ijsav_land_output(ij))=output_data_land2(ij,3) - else - if (ialb == 1) then ! modis - output%alvsf(ijsav_land_output(ij))=0.15 ! search failed, use default - else ! 1 degree gfs data - output%alvsf(ijsav_land_output(ij))=0.15 ! search failed, use default - endif - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,4)) then - output%alvwf(ijsav_land_output(ij))=output_data_land2(ij,4) - else - if (ialb == 1) then ! modis - output%alvwf(ijsav_land_output(ij))=0.14 ! search failed, use default - else ! 1 degree gfs data - output%alvwf(ijsav_land_output(ij))=0.1 ! search failed, use default - end if - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,5)) then - output%facsf(ijsav_land_output(ij))=output_data_land2(ij,5) - else - output%facsf(ijsav_land_output(ij))=0.5 ! search failed, use default - endif - enddo - do ij = 1, count_land_output - if (bitmap_land_output2(ij,6)) then - output%facwf(ijsav_land_output(ij))=output_data_land2(ij,6) - else - output%facwf(ijsav_land_output(ij))=0.5 ! search failed, use default - endif - enddo - deallocate(bitmap_land_input2, bitmap_land_output2, input_dat, output_data_land2) - end if -!----------------------------------------------------------------------- -! single snowfree albedo used by wrf/nmm -!----------------------------------------------------------------------- - elseif (allocated(output%snow_free_albedo)) then - if (allocated(snow_free_albedo_output_ext)) then - print*,"- SET SNOW FREE ALBEDO WITH EXTERNAL DATA" - output%snow_free_albedo = 0.06 ! open water - where (output%lsmask > 0.0) output%snow_free_albedo = & - snow_free_albedo_output_ext ! land - where (output%sea_ice_flag == 1) output%snow_free_albedo = 0.65 ! sea ice - else - if (count_land_output > 0) then - print*,"- INTERPOLATE SNOW-FREE (BASE) ALBEDO FROM INPUT GRID." - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_land_output - allocate(ibo(1)) - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%snow_free_albedo, & - no, lats_land_output, lons_land_output, ibo, & - bitmap_land_output, output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%snow_free_albedo = 0.06 ! open water - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - output%snow_free_albedo(ijsav_land_output(ij))=output_data_land(ij) - else - output%snow_free_albedo(ijsav_land_output(ij))=0.2 ! search failed, use default - endif - enddo - where (output%sea_ice_flag == 1) output%snow_free_albedo = 0.65 ! sea ice - endif - endif SNOWFREE_ALB - -!----------------------------------------------------------------------- -! maximum snow albedo for noah runs. -!----------------------------------------------------------------------- - if (allocated (output%mxsnow_alb)) then - if (allocated(mxsnow_alb_output_ext)) then - print*,'- SET MAX SNOW ALBEDO WITH EXTERNAL DATA.' - output%mxsnow_alb = 0.0 - where (output%lsmask>0.0) output%mxsnow_alb = mxsnow_alb_output_ext - deallocate (mxsnow_alb_output_ext) - elseif (.not. allocated(input%mxsnow_alb)) then - print*,"- ABORT. INPUT FILE DOES NOT HAVE MAX SNOW ALBEDO." - iret = 99 - return - else ! interpolate from input grid - if (count_land_output > 0) then - print*,"- INTERPOLATE MAX SNOW ALBEDO FROM INPUT GRID." - bitmap_land_output=.false. - output_data_land=0.0 - kgds_output_tmp=kgds_output - kgds_output_tmp(1) = kgdso1 - no=count_land_output - allocate(ibo(1)) - call ipolates(int_opt, ipopt, kgds_input, kgds_output_tmp, & - (imdl_input*jmdl_input), count_land_output, & - 1, 1, bitmap_land_input, input%mxsnow_alb, & - no, lats_land_output, lons_land_output, ibo, bitmap_land_output, & - output_data_land, iret) - if (iret /= 0) then - print*,'- ERROR IN IPOLATES ',iret - return - endif - deallocate(ibo) - endif ! are there land points? - output%mxsnow_alb= 0.0 ! non-land - do ij = 1, count_land_output - if (bitmap_land_output(ij)) then - output%mxsnow_alb(ijsav_land_output(ij))=output_data_land(ij) - else - output%mxsnow_alb(ijsav_land_output(ij))=0.7 ! search failed, use default - endif - enddo - end if - end if - -!----------------------------------------------------------------------- -! if the soil types have changed, need to rescale -! the soil moisture. -!----------------------------------------------------------------------- - if (rescale_soil_moist) then - print*,'- RESCALE SOIL MOISTURE FOR NEW SOIL TYPE.' - allocate (soilm_sav(ijmdl_output,nsoil_output)) - soilm_sav = output%soilm_tot - allocate (lsmask_output_temp(ijmdl_output)) - lsmask_output_temp = output%lsmask -! don't bother doing this at landice points as soil moisture is -! not used. - if (landice_opt == 1 .or. landice_opt == 2) then - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - lsmask_output_temp(ij) = 0.0 - endif - enddo - endif - call rescale_soilm(soilm_sav, output%soilm_tot, & - soil_type_sav, output%soil_type, & - smcdry_input, smcdry_output, & - smcwilt_input, smcwilt_output, & - smcref_input, smcref_output, & - smcmax_input, smcmax_output, & - lsmask_output_temp, output%greenfrc, & - ijmdl_output, & - nsoil_output, max_soil_types) - deallocate (soilm_sav) - deallocate (lsmask_output_temp) - end if - deallocate(soil_type_sav) - -!----------------------------------------------------------------------- -! now calculate the liquid portion of the total soil moisture. -!----------------------------------------------------------------------- - if (allocated (output%soilm_liq)) then - print*,'- CALCULATE LIQUID PORTION OF TOTAL SOIL MOISTURE.' - output%soilm_liq = 1.0 ! flag value for non-land points - allocate (lsmask_output_temp(ijmdl_output)) - lsmask_output_temp = output%lsmask -! don't bother doing this at landice points as soil moisture is -! not used. - if (landice_opt == 1 .or. landice_opt == 2) then - - do ij = 1, ijmdl_output - if (output%lsmask(ij) > 0.0 .and. & - output%veg_type(ij) == veg_type_ice) then - lsmask_output_temp(ij) = 0.0 - endif - enddo - endif - if (count_land_output > 0) then - print*,'- CALCULATE LIQUID PORTION OF TOTAL SOIL MOISTURE AF.' - call calc_liq_soilm(output%soil_type, output%soilm_tot, & - output%soil_temp, output%soilm_liq, & - lsmask_output_temp, beta_output, & - psis_output, smcmax_output, & - max_soil_types, & - ijmdl_output, nsoil_output) - endif - deallocate (lsmask_output_temp) - end if - -!----------------------------------------------------------------------- -! for single albedo, need to calc snow effects. -!----------------------------------------------------------------------- - if (allocated (output%albedo)) then - print*,"- CALCULATE SNOW EFFECT ON ALBEDO" - output%albedo=0.06 ! open water value - allocate (snow_m(ijmdl_output)) - snow_m = output%snow_liq_equiv * 0.001 - call calc_albedo(output%lsmask, output%veg_type, ijmdl_output, & - salp_output, snup_output, max_veg_types, & - output%snow_free_albedo, output%mxsnow_alb, & - snow_m, output%albedo) - where(output%sea_ice_flag == 1) output%albedo = 0.65 ! as in eta after may 3, 05 - deallocate (snow_m) - end if - - - where(output%sea_ice_flag == 1) output%lsmask = 2.0 - - deallocate (bitmap_land_output, bitmap_land_input) - deallocate (bitmap_nonland_output, bitmap_nonland_input) - deallocate (bitmap_sea_ice_input) - deallocate (ijsav_land_output, ijsav_nonland_output) - deallocate (lats_land_output, lons_land_output) - deallocate (lats_nonland_output, lons_nonland_output) - deallocate (nn_iindx_wrt_input_grid, nn_jindx_wrt_input_grid) - deallocate (output_data_land, output_data_nonland) - if (allocated (output_data_sea_ice)) deallocate(output_data_sea_ice) - if (allocated (bitmap_sea_ice_output)) deallocate(bitmap_sea_ice_output) - if (allocated (lats_sea_ice_output)) deallocate(lats_sea_ice_output) - if (allocated (lons_sea_ice_output)) deallocate(lons_sea_ice_output) - if (allocated (ijsav_sea_ice_output)) deallocate(ijsav_sea_ice_output) - - print*,'- COMPLETED INTERP' - - return - - end subroutine interp -!----------------------------------------------------------------------- - subroutine setup(kgds_input, input, imdl_input, jmdl_input, & - imo, iret) -!$$$ subprogram documentation block -! -! subprogram: setup perform various setup tasks -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: read configuration namelist, calculate model resolution, -! calculate some soil parameters. -! -! program history log: -! 2005-10-19 gayno - initial version -! -! usage: 'call setup' with the following arguments -! input arguments (input/output denotes input/output grid): -! kgds_input grib grid description section of input grid -! input surface data on input grid -! i/jmdl_input i/j dimensions of input grid -! output arguments -! iret error status, non-zero means an error occurred -! other outputs: -! mdl_res_input/output resolution (in degrees) of model -! input/output grid -! smcref_input/output onset of soil moisture stress, input/output -! grid values -! smcdry_input/output air dry soil moisture limit, input/output -! grid values -! smcwilt_input/output plant wilting point, input/output grid -! values -! soil_type_ice soil type for land ice points -! veg_type_ice veg type for land ice (output grid) -! veg_type_ice_input veg type for land ice (input grid) -! -! namelists: -! options: -! climo_fields_opt option for determining climo fields on -! output grid. 1 ONLY!! -! 1-interpolate all from input grid -! 2-interpolate veg, soil, slope type -! from input grid. others from -! cycle program. -! 3-all from cycle program. -! landice_opt 1-no landice input grid -> landice output grid -! 2-landice input grid -> landice output grid -! 3-no landice input grid -> no landice output grid -! 4-landice input grid -> no landice output grid -! 5-landice on output grid regardless of -! whether input grid has landice or not. -! soil_parameters (input/output grid values): -! soil_src_input/output source of soil type database (ex: zobler) -! smclow_input/output soil moisture scalar multiplier -! smchigh_input/output soil moisture scalar multiplier -! smcmax_input/output maximum soil moisture content -! beta_input/output soil 'b' parameter -! psis_input/output saturated soil potential -! satdk_input/output saturated soil hydraulic conductivity -! -! veg_parameters: -! veg_src_input/output source of veg type database (ex: usgs) -! salp_output plant factor in albedo calculation -! snup_output plant factor in albedo calculation -! -! input files: -! unit 81 configuration namelists -! -! subprograms called: -! calc_soil_parms - calculate soil parameters -! -! attributes: -! langauge: fortran 90 -! -!$$$ - use soil_utils, only : calc_soil_parms - - implicit none - - character*10 :: soil_src_input, soil_src_output, & - veg_src_input, veg_src_output - - integer, intent(in) :: imdl_input, jmdl_input - integer :: i,j, istat - integer, intent(in) :: kgds_input(200), imo - integer, intent(inout) :: iret - - type(sfc2d) :: input - - namelist /soil_parameters/ soil_src_input, & - smclow_input, & - smchigh_input, & - smcmax_input, & - beta_input, & - psis_input, & - satdk_input, & - soil_src_output, & - smclow_output, & - smchigh_output, & - smcmax_output, & - beta_output, & - psis_output, & - satdk_output - - namelist /veg_parameters/ veg_src_input, & - veg_src_output, & - salp_output, & - snup_output - - namelist /options/ climo_fields_opt, & - landice_opt - - iret=0 - print*,"- READ CONFIGURATION NAMELIST." - open(81, iostat=istat, err=900) - read(81, nml=soil_parameters, iostat=istat, err=910) - read(81, nml=veg_parameters, iostat=istat, err=910) - read(81, nml=options, iostat=istat, err=910) - close(81) - - mdl_res_input = 360.0 / float(kgds_input(2)) - print*,"- RESOLUTION OF INPUT GRID IN DEGREES IS: ", mdl_res_input - - mdl_res_output = 360.0 / (float(imo) * 4.0) - print*,"- RESOLUTION OF OUTPUT GRID IN DEGREES IS: ", mdl_res_output - -!----------------------------------------------------------------------- -! the flag values of soil and veg type for landice depend on -! what raw databases were used. -!----------------------------------------------------------------------- - - select case (trim(soil_src_output)) - case("zobler") - soil_type_ice=9 - case("statsgo") - soil_type_ice=16 - case default - print*,'- BAD CHOICE OF OUTPUT GRID SOIL SOURCE ',trim(soil_src_output) - iret=1 - return - end select - - select case (trim(veg_src_output)) - case("usgs") - veg_type_ice=24 - case("sib") - veg_type_ice=13 - case("igbp") - veg_type_ice=15 - case default - print*,'- BAD CHOICE OF OUTPUT GRID VEG SOURCE ',trim(veg_src_output) - iret=2 - return - end select - - select case (trim(veg_src_input)) - case("usgs") - veg_type_ice_input=24 - case("sib") - veg_type_ice_input=13 - case("igbp") - veg_type_ice_input=15 - case default - print*,'- BAD CHOICE OF INPUT GRID VEG SOURCE ',trim(veg_src_input) - iret=3 - return - end select - -!----------------------------------------------------------------------- -! parameters for soil type on input/output grids. -!----------------------------------------------------------------------- - - print*,'- CALCULATE SOIL PARAMETERS' - call calc_soil_parms(smclow_input, smchigh_input, & - smcmax_input, beta_input, & - satdk_input, psis_input, max_soil_types, & - smcref_input, smcwilt_input, smcdry_input) - - call calc_soil_parms(smclow_output, smchigh_output, & - smcmax_output, beta_output, & - satdk_output, psis_output, max_soil_types, & - smcref_output, smcwilt_output, smcdry_output) - -!----------------------------------------------------------------------- -! certain landice options are only valid if the input grid has -! or does not have landice. check for the soil moisture flag value -! of 1.0 at land ice points. -!----------------------------------------------------------------------- - - if (landice_opt == 1 .or. landice_opt == 3) then - do j = 1, jmdl_input - do i = 1, imdl_input - if (input%lsmask(i,j) > 0.0 .and. input%soilm_tot(i,j,1) > 0.99) then - print*,"- LANDICE OPTION OF ", landice_opt, " IS NOT VALID WHEN" - print*,"- INPUT DATA HAS LANDICE." - iret=4 - return - end if - enddo - enddo - elseif (landice_opt == 2 .or. landice_opt == 4) then - do j = 1, jmdl_input - do i = 1, imdl_input - if (input%lsmask(i,j) > 0.0 .and. input%soilm_tot(i,j,1) > 0.99) then - return - end if - enddo - enddo - print*,"- LANDICE OPTION OF ", landice_opt, " IS NOT VALID WHEN" - print*,"- INPUT DATA DOES NOT HAVE LANDICE." - iret=5 - return - elseif (landice_opt == 5) then - print*,"- WILL FORCE LANDICE INITIALIZATION." - landice_opt = 1 ! for rest of module, 1 and 5 are equivalent. - end if - - return - -900 print*,"- ERROR OPENING CONFIG NAMELIST. ISTAT IS ", istat - iret=6 - return - -910 print*,"- ERROR READING CONFIG NAMELIST. ISTAT IS ", istat - iret=7 - return - - end subroutine setup -!----------------------------------------------------------------------- - subroutine get_ext_climo_global(ijmdl_output, lsmask_output, orog_output, & - orog_uf, use_ufo, nst_anl, output, & - hour, month, day, & - year, fhour, ialb, isot, ivegsrc, & - iindx_output, jindx_output, tile_num) -!$$$ subprogram documentation block -! -! subprogram: get_ext_climo_global get climo fields on global grid -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: get climo fields, such as soil type and albedo on the -! output grid by calling the surface cycle code. according -! to the option selected by the user, the climo fields on the -! output grid will come from either surface cycle or be -! interpolated from the input grid. if a field is to be -! interpolated from the input grid, the corresponding array -! from surface cycle will be deallocated. -! note!! surface cycle is only called to get the climo -! fields on the grid. NOT to update the SST, snow or sea ice. -! -! program history log: -! 2005-10-19 gayno - initial version -! -! usage: call subroutine get_ext_climo_global & -! (ijmdl_output, & -! lsmask_output, orog_output, orog_uf, & -! use_ufo, nst_anl, output, & -! hour, month, day, & -! year, fhour, ialb, isot, ivegsrc) -! input arguments: -! ijmdl_output number of grid points, output grid -! lsmask_output landmask (0-nonland, 1-land) output grid -! orog_output orography of output grid -! orog_uf unfiltered orography of output grid -! use_ufo when 'true' use unfiltered orography -! nst_anl when 'true' use nsst model -! hour/month/day/year YYYYMMDDHH of cycle -! fhour forecast hour with respect to cycle time -! ialb when '1', use bosu albedo. when '0', -! use old albedo -! isot when '1', use new statsgo soil type. -! when '0', use zobler soil type -! ivegsrc when '1', use new igbp vegetation type. -! when '2', use sib vegetation type -! outputs: -! substrate_temp_output_ext substrate temperature from sfccycle -! soil_type_output_ext soil type from sfccycle -! veg_type_output_ext vegetation type from sfccycle -! slope_type_output_ext slope type from sfccycle -! mxsnow_alb_output_ext max snow albedo from sfccycle -! z0_output_ext roughness from sfccycle -! greenfrc_output_ext greenness fraction from sfccycle -! greenfrc_min_output_ext min greenness fraction from sfccycle -! greenfrc_max_output_ext max greenness fraction from sfccycle -! facsf_output_ext fraction, strong cosz dependence from sfccycle -! facwf_output_ext fraction, weak cosz dependence from sfccycle -! -! - old radiation treatment (ialb = 0) -! alnsf_output_ext near ir albedo, strong cosz depend. from sfccycle -! alnwf_output_ext near ir albedo, weak cosz depend. from sfccycle -! alvsf_output_ext vis albedo, strong cosz depend. from sfccycle -! alvwf_output_ext vis albedo, weak cosz depend. from sfccycle -! -! - new radiation treatment (ialb = 1) -! alnsf_output_ext near ir black sky albedo -! alnwf_output_ext near ir white sky albedo -! alvsf_output_ext visible black sky albedo -! alvwf_output_ext visible white sky albedo -! -! subprograms called: -! sfccycle - calculate soil parameters -! -! attributes: -! langauge: fortran 90 -! -!$$$ - use machine, only : kind_io8 - - implicit none - - integer, parameter :: sz_nml = 1 - - character(len=4) :: input_nml_file(sz_nml) - character(len=6) :: tile_num_ch - - integer, intent(in) :: hour, month, day, year, ialb - integer, intent(in) :: ijmdl_output, isot, ivegsrc - integer, intent(in) :: iindx_output(ijmdl_output) - integer, intent(in) :: jindx_output(ijmdl_output) - integer, intent(in) :: tile_num - integer :: lsoil - integer, parameter :: lugb = 51 - integer :: nlunit - - real, intent(in) :: fhour - real, intent(in) :: lsmask_output(ijmdl_output) - real, intent(in) :: orog_output(ijmdl_output) - real, intent(in) :: orog_uf (ijmdl_output) - logical,intent(in) :: use_ufo, nst_anl - - real (kind=kind_io8), allocatable :: sig1t(:), & - slmask(:), orog(:), sihfcs(:), sicfcs(:), sitfcs(:),& - swdfcs(:), slcfcs(:,:), vmnfcs(:), vmxfcs(:), & - slpfcs(:), absfcs(:), TSFFCS(:), SNOFCS(:), ZORFCS(:), & - ALBFCS(:,:), TG3FCS(:), CNPFCS(:), SMCFCS(:,:), STCFCS(:,:), & - slifcs(:), AISFCS(:), vegfcs(:), vetfcs(:), & - sotfcs(:), ALFFCS(:,:), CVFCS(:), CVBFCS(:), CVTFCS(:), & - lats(:), lons(:) - - real(kind=kind_io8) :: deltsfc, fh - - type(sfc1d), intent(in) :: output - - input_nml_file = "NULL" - - tile_num_ch=" " - if (tile_num < 10) then - write(tile_num_ch, "(a4,i1)") "tile", tile_num - else - write(tile_num_ch, "(a4,i2)") "tile", tile_num - endif - - lsoil = 4 - deltsfc = 0.0 - fh = fhour - - allocate (sig1t(ijmdl_output), slmask(ijmdl_output), & - orog(ijmdl_output), sihfcs(ijmdl_output), & - sicfcs(ijmdl_output), swdfcs(ijmdl_output), & - sitfcs(ijmdl_output), & - slcfcs(ijmdl_output,lsoil), vmnfcs(ijmdl_output), & - vmxfcs(ijmdl_output), slpfcs(ijmdl_output), & - absfcs(ijmdl_output), TSFFCS(ijmdl_output), & - SNOFCS(ijmdl_output), zorfcs(ijmdl_output), & - ALBFCS(ijmdl_output,4), tg3fcs(ijmdl_output), & - CNPFCS(ijmdl_output), SMCFCS(ijmdl_output,lsoil), & - STCFCS(ijmdl_output,lsoil), slifcs(ijmdl_output), & - AISFCS(ijmdl_output), & - vegfcs(ijmdl_output), vetfcs(ijmdl_output), & - sotfcs(ijmdl_output), ALFFCS(ijmdl_output,2), & - CVFCS(ijmdl_output), CVBFCS(ijmdl_output), & - CVTFCS(ijmdl_output), lats(ijmdl_output), & - lons(ijmdl_output)) - - slmask = lsmask_output - - orog = orog_output - -!orog = orog_output - orog_uf - - nlunit = 35 - - sig1t = 0.0; sihfcs = 0.0; sicfcs = 0.0; swdfcs = 0.0 - slcfcs = 0.0; vmnfcs = 0.0; vmxfcs = 0.0; slpfcs = 0.0 - absfcs = 0.0; tsffcs = 0.0; snofcs = 0.0; zorfcs = 0.0 - albfcs = 0.0; tg3fcs = 0.0; cnpfcs = 0.0; smcfcs = 0.0 - stcfcs = 0.0; slifcs = 0.0; aisfcs = 0.0; - vegfcs = 0.0; vetfcs = 0.0; sotfcs = 0.0; alffcs = 0.0 - cvfcs = 0.0; cvbfcs = 0.0; cvtfcs = 0.0; sitfcs = 0.0 - lats=output%lats; lons=output%lons - call SFCCYCLE(LUGB,ijmdl_output,LSOIL,SIG1T,DELTSFC, & - year,month,day,hour,FH, & - lats, lons, SLMASK,OROG,orog_uf,use_ufo,nst_anl, & - SIHFCS,SICFCS,SITFCS, & - SWDFCS,SLCFCS, & - VMNFCS, VMXFCS, SLPFCS, ABSFCS, & - TSFFCS,SNOFCS,ZORFCS,ALBFCS,TG3FCS, & - CNPFCS,SMCFCS,STCFCS,slifcs,AISFCS, & - VEGFCS, VETFCS, SOTFCS, ALFFCS, & - CVFCS,CVBFCS,CVTFCS,0,NLUNIT, & - SZ_NML, INPUT_NML_FILE, IALB, ISOT, IVEGSRC, & - TRIM(TILE_NUM_CH), IINDX_OUTPUT, JINDX_OUTPUT) -!----------------------------------------------------------------------- -! if an array is deallocated, the rest of code knows to interpolate -! that field from the input grid. -! -! always use tbot from surface cycle as it is imitmately tied to the -! output terrain. -!----------------------------------------------------------------------- - - allocate (substrate_temp_output_ext(ijmdl_output)) - substrate_temp_output_ext = tg3fcs - - if (climo_fields_opt == 3) then - allocate (soil_type_output_ext(ijmdl_output)) - soil_type_output_ext = nint(sotfcs) - allocate (veg_type_output_ext(ijmdl_output)) - veg_type_output_ext = nint(vetfcs) - allocate (slope_type_output_ext(ijmdl_output)) - slope_type_output_ext = nint(slpfcs) - end if - - if (climo_fields_opt == 2 .or. climo_fields_opt == 3) then - allocate (mxsnow_alb_output_ext(ijmdl_output)) - mxsnow_alb_output_ext = absfcs - allocate (z0_output_ext(ijmdl_output)) - z0_output_ext = zorfcs - allocate (greenfrc_output_ext(ijmdl_output)) - greenfrc_output_ext = vegfcs - allocate (greenfrc_min_output_ext(ijmdl_output)) - greenfrc_min_output_ext = vmnfcs - allocate (greenfrc_max_output_ext(ijmdl_output)) - greenfrc_max_output_ext = vmxfcs - allocate (alnsf_output_ext(ijmdl_output)) - alnsf_output_ext = albfcs(:,3) - allocate (alnwf_output_ext(ijmdl_output)) - alnwf_output_ext = albfcs(:,4) - allocate (alvsf_output_ext(ijmdl_output)) - alvsf_output_ext = albfcs(:,1) - allocate (alvwf_output_ext(ijmdl_output)) - alvwf_output_ext = albfcs(:,2) - allocate (facsf_output_ext(ijmdl_output)) - facsf_output_ext = alffcs(:,1) - allocate (facwf_output_ext(ijmdl_output)) - facwf_output_ext = alffcs(:,2) - end if - - deallocate (sig1t, slmask, orog, sihfcs, sicfcs, swdfcs, & - slcfcs, vmnfcs, vmxfcs, slpfcs, absfcs, sitfcs, & - TSFFCS, SNOFCS, zorfcs, ALBFCS, tg3fcs, & - CNPFCS, SMCFCS, STCFCS, slifcs, AISFCS, & - vegfcs, vetfcs, sotfcs, ALFFCS, CVFCS, CVBFCS, CVTFCS, & - lats, lons) - - return - end subroutine get_ext_climo_global -!----------------------------------------------------------------------- - subroutine get_ext_climo_nmm(imdl_output, jmdl_output, curr_hour, & - curr_mon, curr_day, curr_year, iret) -!$$$ subprogram documentation block -! -! subprogram: get_ext_climo_nmm get climo fields on nmm grid -! prgmmr: gayno org: w/np2 date: 2006-04-14 -! -! abstract: get climo fields, such as soil type and albedo on the -! output grid by reading them from grib files. -! user selects what fields to read in by setting the -! namelist entries for the path/name of the grib file. -! if a field is NOT read in from the grib file, it -! will be interpolated from the input grid. -! -! program history log: -! 2006-04-14 gayno - initial version -! -! usage: 'call get_ext_climo_global' with the following arguments -! input arguments: -! i/jmdl_output number of grid points, output grid -! in the i/j direction -! curr_hour/mon/day/year current time (used to interpolate -! monthly datasets) -! outputs: -! soil_type_output_ext soil type -! veg_type_output_ext vegetation type -! slope_type_output_ext slope type -! mxsnow_alb_output_ext max snow albedo -! z0_output_ext roughness -! greenfrc_output_ext greenness fraction -! snow_free_output_ext snowfree albedo -! -! namelists: -! optional_output_fields: (path/name of climo grib files) -! snow_free_albedo_output_file -! greenfrc_output_file -! mxsnow_alb_output_file -! slope_type_output_file -! soil_type_output_file -! veg_type_output_file -! z0_output_file -! -! input files: -! unit 81 configuration namelists -! -! subprograms called: -! read_grib_data - read single grib field -! degrib_climo - degrib multiple time period grib file -! time_interp - time interpolate a field to current date -! inventory - inventory multiple time period grib file -! -! attributes: -! langauge: fortran 90 -! -!$$$ - - use read_write_utils, only : read_grib_data, & - date, & - degrib_climo, & - time_interp, & - inventory - - implicit none - - namelist /optional_output_fields/ snow_free_albedo_output_file, & - greenfrc_output_file, & - mxsnow_alb_output_file, & - slope_type_output_file, & - soil_type_output_file, & - veg_type_output_file, & - z0_output_file - - character*150 :: soil_type_output_file - character*150 :: veg_type_output_file - character*150 :: slope_type_output_file - character*150 :: mxsnow_alb_output_file - character*150 :: greenfrc_output_file - character*150 :: snow_free_albedo_output_file - character*150 :: z0_output_file - - integer, intent(in) :: imdl_output, jmdl_output, & - curr_hour, curr_day, & - curr_year, curr_mon - - integer :: iret, param_num, tot_num_recs, & - curr_minute, ijmdl_output, istat - - real, allocatable :: dummy(:) - real, allocatable :: data_climo(:,:,:) - - type (date), allocatable :: dates(:) - - iret = 0 - - print*,"- READ CONFIGURATION NAMELIST." - - open(81, iostat=istat, err=900) - read(81, nml=optional_output_fields, iostat=istat, err=910) - close(81) - - ijmdl_output = imdl_output * jmdl_output - -!----------------------------------------------------------------------- -! if user chooses, read soil type, veg type, slope type and -! max snow albedo. -!----------------------------------------------------------------------- - - if (len_trim(soil_type_output_file) > 0) then - print*,"- DEGRIB SOIL TYPE ON OUTPUT GRID" - allocate (dummy(ijmdl_output)) - allocate (soil_type_output_ext(ijmdl_output)) - call read_grib_data(soil_type_output_file, 224, dummy, & - ijmdl_output, iret) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID SOIL TYPE' - return - end if - soil_type_output_ext = nint(dummy) - deallocate (dummy) - end if - - if (len_trim(veg_type_output_file) > 0) then - print*,"- DEGRIB VEG TYPE ON OUTPUT GRID" - allocate (dummy(ijmdl_output)) - allocate (veg_type_output_ext(ijmdl_output)) - call read_grib_data(veg_type_output_file, 225, dummy, & - ijmdl_output, iret) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID VEG TYPE' - return - end if - veg_type_output_ext = nint(dummy) - deallocate (dummy) - end if - - if (len_trim(slope_type_output_file) > 0) then - print*,"- DEGRIB SLOPE TYPE ON OUTPUT GRID" - allocate (dummy(ijmdl_output)) - allocate (slope_type_output_ext(ijmdl_output)) - call read_grib_data(slope_type_output_file, 222, dummy, & - ijmdl_output, iret) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID SLOPE TYPE' - return - end if - slope_type_output_ext = nint(dummy) - deallocate (dummy) - end if - - if (len_trim(mxsnow_alb_output_file) > 0) then - print*,"- DEGRIB MAX SNOW ALBEDO ON OUTPUT GRID" - allocate (mxsnow_alb_output_ext(ijmdl_output)) - call read_grib_data(mxsnow_alb_output_file, 159, & - mxsnow_alb_output_ext, ijmdl_output, iret) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID MAX SNOW ALBEDO' - return - end if -! grib standard is %, but model expects decimal. - mxsnow_alb_output_ext = mxsnow_alb_output_ext * 0.01 - end if - -!----------------------------------------------------------------------- -! greenness fraction. -!----------------------------------------------------------------------- - - if (len_trim(greenfrc_output_file) > 0) then - print*,"- DEGRIB GREENNESS ON OUTPUT GRID" - param_num = 87 - call inventory(greenfrc_output_file, param_num, tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID GREENNESS FRACTION.' - return - end if - allocate (dates(tot_num_recs)) - allocate (data_climo(imdl_output,jmdl_output,tot_num_recs)) - call degrib_climo(data_climo, dates, ijmdl_output, & - param_num, greenfrc_output_file, & - tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID GREENNESS FRACTION.' - return - end if - allocate (greenfrc_output_ext(ijmdl_output)) - greenfrc_output_ext = 0.0 -! need to adjust this for fcst hour???? - curr_minute = 0 - call time_interp(data_climo, dates, tot_num_recs, & - ijmdl_output, curr_year, curr_mon, curr_day, & - curr_hour, curr_minute, greenfrc_output_ext) -! grib standard is %, but model expects decimal. - greenfrc_output_ext = greenfrc_output_ext * 0.01 - deallocate (dates) - deallocate (data_climo) - end if - -!----------------------------------------------------------------------- -! albedo (snow free) -!----------------------------------------------------------------------- - - if (len_trim(snow_free_albedo_output_file) > 0) then - print*,"- DEGRIB SNOW FREE ALBEDO ON OUTPUT GRID" - param_num = 170 - call inventory(snow_free_albedo_output_file, param_num, & - tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID SNOW-FREE ALBEDO' - return - end if - allocate (dates(tot_num_recs)) - allocate (data_climo(imdl_output,jmdl_output,tot_num_recs)) - call degrib_climo(data_climo, dates, ijmdl_output, & - param_num, snow_free_albedo_output_file, & - tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID SNOW-FREE ALBEDO' - return - end if - allocate (snow_free_albedo_output_ext(ijmdl_output)) - snow_free_albedo_output_ext = 0.0 -! need to adjust this for fcst hour???? - curr_minute = 0 - call time_interp(data_climo, dates, tot_num_recs, & - ijmdl_output, curr_year, curr_mon, curr_day, & - curr_hour, curr_minute, snow_free_albedo_output_ext) -! grib standard is %, but model uses decimal. - snow_free_albedo_output_ext = snow_free_albedo_output_ext * 0.01 - deallocate (dates) - deallocate (data_climo) - end if - -!----------------------------------------------------------------------- -! roughness length. -!----------------------------------------------------------------------- - - if (len_trim(z0_output_file) > 0) then - print*,"- DEGRIB ROUGHNESS ON OUTPUT GRID" - param_num = 83 - call inventory(z0_output_file, param_num, tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID ROUGHNESS LENGTH' - return - end if - allocate (dates(tot_num_recs)) - allocate (data_climo(imdl_output,jmdl_output,tot_num_recs)) - call degrib_climo(data_climo, dates, ijmdl_output, & - param_num, z0_output_file, tot_num_recs, iret, 0) - if (iret /= 0) then - print*,'- ERROR DEGRIBBING OUTPUT GRID ROUGHNESS LENGTH' - return - end if - allocate (z0_output_ext(ijmdl_output)) - z0_output_ext = -1.0 -!nmm does not use a time varying field. no need to time interp. - if (tot_num_recs > 1) then - curr_minute = 0 - call time_interp(data_climo, dates, tot_num_recs, & - ijmdl_output, curr_year, curr_mon, curr_day, & - curr_hour, curr_minute, z0_output_ext) - else - z0_output_ext = reshape(data_climo(:,:,1),(/ijmdl_output/)) - end if -!----------------------------------------------------------------------- -! interp code expects z0 in cm, raw data in meters. -!----------------------------------------------------------------------- - z0_output_ext = z0_output_ext * 100.0 - deallocate (data_climo) - deallocate (dates) - end if - - return - -900 print*,"- ERROR OPENING CONFIG NAMELIST. ISTAT IS ", istat - iret = 11 - return - -910 print*,"- ERROR READING CONFIG NAMELIST. ISTAT IS ", istat - iret = 12 - return - - end subroutine get_ext_climo_nmm - -!----------------------------------------------------------------------- - subroutine surface_chgres_ax2d(dum) -!$$$ subprogram documentation block -! -! subprogram: surface_chgres_ax2d free up memory -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: deallocate a sfc2d data structure -! -! program history log: -! 2005-10-19 gayno - initial version -! -! usage: call surface_chgres_ax2d(dum) -! input arguments: -! dum data structure containing several surface fields -! -! attributes: -! langauge: fortran 90 -! -!$$$ - type (sfc2d), intent(inout) :: dum - - if (allocated (dum%alnsf)) deallocate (dum%alnsf) - if (allocated (dum%alnwf)) deallocate (dum%alnwf) - if (allocated (dum%alvsf)) deallocate (dum%alvsf) - if (allocated (dum%alvwf)) deallocate (dum%alvwf) - if (allocated (dum%canopy_mc)) deallocate (dum%canopy_mc) - if (allocated (dum%facsf)) deallocate (dum%facsf) - if (allocated (dum%facwf)) deallocate (dum%facwf) - if (allocated (dum%sea_ice_fract)) deallocate (dum%sea_ice_fract) - if (allocated (dum%greenfrc)) deallocate (dum%greenfrc) - if (allocated (dum%greenfrc_max)) deallocate (dum%greenfrc_max) - if (allocated (dum%greenfrc_min)) deallocate (dum%greenfrc_min) - if (allocated (dum%sea_ice_depth)) deallocate (dum%sea_ice_depth) - if (allocated (dum%lsmask)) deallocate (dum%lsmask) - if (allocated (dum%mxsnow_alb)) deallocate (dum%mxsnow_alb) - if (allocated (dum%orog)) deallocate (dum%orog) - if (allocated (dum%sea_ice_temp)) deallocate (dum%sea_ice_temp) - if (allocated (dum%skin_temp)) deallocate (dum%skin_temp) - if (allocated (dum%snow_depth)) deallocate (dum%snow_depth) - if (allocated (dum%snow_liq_equiv)) deallocate (dum%snow_liq_equiv) - if (allocated (dum%snow_free_albedo))deallocate (dum%snow_free_albedo) - if (allocated (dum%soilm_liq)) deallocate (dum%soilm_liq) - if (allocated (dum%soilm_tot)) deallocate (dum%soilm_tot) - if (allocated (dum%soil_temp)) deallocate (dum%soil_temp) - if (allocated (dum%z0)) deallocate (dum%z0) - if (allocated (dum%sea_ice_flag)) deallocate (dum%sea_ice_flag) - if (allocated (dum%slope_type)) deallocate (dum%slope_type) - if (allocated (dum%soil_type)) deallocate (dum%soil_type) - if (allocated (dum%veg_type)) deallocate (dum%veg_type) - - end subroutine surface_chgres_ax2d -!----------------------------------------------------------------------- - subroutine surface_chgres_ax1d(dum) -!$$$ subprogram documentation block -! -! subprogram: surface_chgres_ax1d free up memory -! prgmmr: gayno org: w/np2 date: 2005-10-19 -! -! abstract: deallocate a sfc1d data structure -! -! program history log: -! 2005-10-19 gayno - initial version -! -! usage: call surface_chgres_ax1d(dum) -! input arguments: -! dum data structure containing several surface fields -! -! attributes: -! langauge: fortran 90 -! -!$$$ - type (sfc1d), intent(inout) :: dum - - if (allocated (dum%albedo)) deallocate (dum%albedo) - if (allocated (dum%alnsf)) deallocate (dum%alnsf) - if (allocated (dum%alnwf)) deallocate (dum%alnwf) - if (allocated (dum%alvsf)) deallocate (dum%alvsf) - if (allocated (dum%alvwf)) deallocate (dum%alvwf) - if (allocated (dum%canopy_mc)) deallocate (dum%canopy_mc) - if (allocated (dum%facsf)) deallocate (dum%facsf) - if (allocated (dum%facwf)) deallocate (dum%facwf) - if (allocated (dum%sea_ice_fract)) deallocate (dum%sea_ice_fract) - if (allocated (dum%greenfrc)) deallocate (dum%greenfrc) - if (allocated (dum%greenfrc_max)) deallocate (dum%greenfrc_max) - if (allocated (dum%greenfrc_min)) deallocate (dum%greenfrc_min) - if (allocated (dum%sea_ice_depth)) deallocate (dum%sea_ice_depth) - if (allocated (dum%lats)) deallocate (dum%lats) - if (allocated (dum%lons)) deallocate (dum%lons) - if (allocated (dum%lsmask)) deallocate (dum%lsmask) - if (allocated (dum%mxsnow_alb)) deallocate (dum%mxsnow_alb) - if (allocated (dum%orog)) deallocate (dum%orog) - if (allocated (dum%sea_ice_temp)) deallocate (dum%sea_ice_temp) - if (allocated (dum%skin_temp)) deallocate (dum%skin_temp) - if (allocated (dum%snow_depth)) deallocate (dum%snow_depth) - if (allocated (dum%snow_free_albedo))deallocate (dum%snow_free_albedo) - if (allocated (dum%snow_liq_equiv)) deallocate (dum%snow_liq_equiv) - if (allocated (dum%soilm_liq)) deallocate (dum%soilm_liq) - if (allocated (dum%soilm_tot)) deallocate (dum%soilm_tot) - if (allocated (dum%soil_temp)) deallocate (dum%soil_temp) - if (allocated (dum%substrate_temp)) deallocate (dum%substrate_temp) - if (allocated (dum%z0)) deallocate (dum%z0) - if (allocated (dum%sea_ice_flag)) deallocate (dum%sea_ice_flag) - if (allocated (dum%slope_type)) deallocate (dum%slope_type) - if (allocated (dum%soil_type)) deallocate (dum%soil_type) - if (allocated (dum%veg_type)) deallocate (dum%veg_type) - - end subroutine surface_chgres_ax1d - - end module surface_chgres diff --git a/ush/global_chgres.sh b/ush/global_chgres.sh deleted file mode 100755 index d2770edea..000000000 --- a/ush/global_chgres.sh +++ /dev/null @@ -1,547 +0,0 @@ -#!/bin/ksh -################################################################################ -#### UNIX Script Documentation Block -# . . -# Script name: global_chgres.sh -# Script description: Convert GFS restart files to the FV3 cubed-sphere grid. -# -# Author: Mark Iredell Org: NP23 Date: 1999-03-01 -# -# Abstract: This script converts the GFS restart files, namely the sigma -# file, surface file, nst file or all 3, to the cubed-sphere grid. When -# converting an nst file, you must also convert a surface file. -# All input files are specified by the first three arguments. -# The horizontal/vertical resolution of the output files is given by -# the CASE/LEVS arguments. When the input sigma file is sigio format, -# the conversion is done in two steps. First, the spectral coefficients -# are converted to grid point space. By default, this intermediate -# data are on a gaussian grid with i/j dimension as described by the -# input file header. These defaults may be overridden by the IDRT, -# LONB and LATB environment variables. The sigma file is converted -# to all six sides of the cube. The surface and nst files are only -# converted to one side of the cube (as specified by the TILE_NUM -# environment variable). I.e., you must run this script six times -# to fully convert a surface or nst file. -# -# Script history log: -# 1999-03-01 Mark Iredell -# 2011-08-05 Added logic for nst restart files. G. Gayno -# 2011-10-10 Updated for gaea - S. Moorthi -# 2016-12-27 Updated for FV3 core. G. Gayno -# 2017-04-12 Remove references to output nsst file. nsst data -# now written to surface restart file. -# 2018-02-09 Updated for regional grids. -# -# Usage: global_chgres.sh SIGINP SFCINP NSTINP CASE LEVS -# -# Input script positional parameters: -# 1 Input sigma file (SIGINP) -# 2 Input surface file (SFCINP) -# 3 Input nst file (NSTINP). Note: fv3gfs -# places nst data in the surface file. -# Set NSTINP to NULL when using fv3gfs. -# 4 Output cubed-sphere resolution (CASE) -# 5 New number of vertical sigma levels (LEVS) -# -# Imported Shell Variables: -# SIGINP Input sigma file -# overridden by $1; skip sigma conversion if missing -# SFCINP Input surface file -# overridden by $2; skip surface conversion if missing -# NSTINP Input nst file -# overridden by $3; skip surface conversion if missing -# CASE Output cubed-sphere resolution. -# overridden by $4. -# LEVS New number of sigma levels -# overridden by $5; one or the other is required -# OUTTYP Output file type. Not used yet. The sigma/atms and -# surface/nsst files are output in netcdf. -# IDRT When converting an atmospheric file in sigio format, -# this is the grid type after spectral conversion. -# 4: guassian(default); 0: lat-lon -# LONB When converting an atmospheric file in sigio format, -# this is the number of longitudes of the intermediate grid -# after spectral conversion. When converting a surface -# file, this is the number of longitudes of the input -# climatological soil moisture data file. -# LATB When converting an atmospheric file in sigio format, -# this is the number of latitudes of the intermediate grid -# after spectral conversion. When converting a surface -# file, this is the number of latitudes of the input -# climatological soil moisture data file. -# NTRAC New number of tracers -# defaults to input sigma file value -# REGIONAL Process stand-alone regional grid. When '1', remove halo -# from grids and create an atmospheric boundary file. -# When '2', create boundary file only. When '0', -# do neither (process as normal for a global grid). -# Default is '0'. -# HALO When processing a stand-alone regional grid, this -# specifies the number of rows/cols for the halo. -# Default is '0'. -# IDVC New vertical coordinate id (1 for sigma, 2 for hybrid) -# defaults to input sigma file value -# IDSL New midlayer pressure id (1 for phillips, 2 for mean) -# defaults to input sigma file value -# TILE_NUM The number of the cubed-sphere tile to convert surface -# and nst data. -# NWROOT A string that defaults to /nwprod -# gfs_ver Version number. Defaults to v15.0.0. -# BASEDIR Base directory. Defaults to /nwprod2 -# HOMEgfs GFS home directory. Defaults to $BASEDIR/gfs.${gfs_ver} -# FIXam Directory for global climo files -# Defaults to $HOMEgfs/fix/fix_am -# FIXfv3 Directory for model 'grid' and 'orography' files. -# Defaults to HOMEgfs/fix/fix_fv3_gmted2010 -# EXECgfs Directory for global executables. -# Defaults to $HOMEgfs/exec -# DATA working directory -# (if nonexistent will be made, used and deleted) -# defaults to current working directory -# XC Suffix to add to executables -# defaults to none -# SIGLEVEL New sigma levels ("NULL" to use from input sigma file) -# defaults to ${FIXam}/global_siglevel.l${LEVS}.txt -# FNGLAC Input glacier climatology GRIB file -# defaults to ${FIXam}/global_glacier.2x2.grb -# FNMXIC Input maximum sea ice climatology GRIB file -# defaults to ${FIXam}/global_maxice.2x2.grb -# FNTSFC Input SST climatology GRIB file -# defaults to ${FIXam}/global_sstclim.2x2.grb -# FNSNOC Input snow climatology GRIB file -# defaults to ${FIXam}/global_snoclim.1.875.grb -# FNZORC Input roughness climatology -# defaults to sib vegtetation type-based lookup table -# FNVETC must be set to ${FIXam}/global_vegtype.1x1.grb -# FNALBC Input 4-component albedo climatology GRIB file -# defaults to ${FIXam}/global_albedo4.1x1.grb -# FNALBC2 Input 'facsf' and 'facwf' albedo climatology GRIB file -# defaults to ${FIXam}/global_albedo4.1x1.grb -# FNAISC Input sea ice climatology GRIB file -# defaults to ${FIXam}/global_iceclim.2x2.grb -# FNTG3C Input deep soil temperature climatology GRIB file -# defaults to ${FIXam}/global_tg3clim.2.6x1.5.grb -# FNVEGC Input vegetation fraction climatology GRIB file -# defaults to ${FIXam}/global_vegfrac.1x1.grb -# FNVETC Input vegetation type climatology GRIB file -# defaults to ${FIXam}/global_vegtype.1x1.grb -# FNSOTC Input soil type climatology GRIB file -# defaults to ${FIXam}/global_soiltype.1x1.grb -# FNSMCC Input soil moisture climatology GRIB file -# defaults to ${FIXam}/global_soilmgldas.statsgo.t$JCAP.$LONB.$LATB.grb -# FNVMNC Input min veg frac climatology GRIB file -# defaults to ${FIXam}/global_shdmin.0.144x0.144.grb -# FNVMXC Input max veg frac climatology GRIB file -# defaults to ${FIXam}/global_shdmax.0.144x0.144.grb -# FNSLPC Input slope type climatology GRIB file -# defaults to ${FIXam}/global_slope.1x1.grb -# FNABSC Input max snow albedo climatology GRIB file -# defaults to ${FIXam}/global_snoalb.1x1.grb -# FNMSKH Input high resolution land mask GRIB file -# defaults to ${FIXam}/seaice_newland.grb -# CLIMO_ -# FIELDS_OPT 1-Climo/static fields (albedo, soil type, greenness, etc.) -# interpolated from input grid. -# 2-Vegetation, slope and soil type interpolated from input -# grid. All other climo/static fields from sfccycle. -# 3-All climo/static fields from sfccycle. -# defaults to '3' -# LANDICE_OPT 1-Input no landice => output landice -# 2-Input landice => output landice. -# 3-Input no landice => output no landice -# 4-Input landice => output no landice -# 5-Output landice regardless of input -# LSOIL 2-Output file with 2 soil layers -# 4-Output file with 4 soil layers -# 0-Default, number of soil layers same as input file -# IVSSFC Version number of surface restart file -# 0-Default, same as input file. -# LONSPERLAT New lonsperlat ("NULL" to use from input surface file) -# CHGRESEXEC Change resolution executable -# defaults to ${EXECgfs}/global_chgres -# INISCRIPT Preprocessing script -# defaults to none -# LOGSCRIPT Log posting script -# defaults to none -# ERRSCRIPT Error processing script -# defaults to 'eval [[ $err = 0 ]]' -# ENDSCRIPT Postprocessing script -# defaults to none -# CHGRESVARS Other namelist inputs to the change resolution executable -# such as IGEN,MQUICK. Defaults to none set. -# NTHREADS Number of threads -# defaults to 1 -# NTHSTACK Size of stack per thread -# defaults to 64000000 -# PGMOUT Executable standard output -# defaults to $pgmout, then to '&1' -# PGMERR Executable standard error -# defaults to $pgmerr, then to '&1' -# pgmout Executable standard output default -# pgmerr Executable standard error default -# REDOUT standard output redirect ('1>' or '1>>') -# defaults to '1>', or to '1>>' to append if $PGMOUT is a file -# REDERR standard error redirect ('2>' or '2>>') -# defaults to '2>', or to '2>>' to append if $PGMERR is a file -# VERBOSE Verbose flag (YES or NO) -# defaults to NO -# FV3GRID_TILE# Contains grid information (lat/lon) for the cubed-sphere grid. -# One file for each of the six tiles. -# FV3OROG_TILE# Contains mask and orography for the cubed-sphere grid. -# One file for each of the six tiles. -# -# Exported Shell Variables: -# PGM Current program name -# pgm -# ERR Last return code -# err -# -# Modules and files referenced: -# scripts : $INISCRIPT -# $LOGSCRIPT -# $ERRSCRIPT -# $ENDSCRIPT -# -# programs : $CHGRESEXEC -# -# input data : $1 or $SIGINP -# $2 or $SFCINP -# $3 or $NSTINP -# $SIGLEVEL -# $LONSPERLAT -# $FVGRID_TILE[1-6] -# $FVOROG_TILE[1-6] -# -# output data: -# $PGMOUT -# $PGMERR -# -# scratch : ${DATA}/chgres.inp.sig -# ${DATA}/chgres.inp.siglevel -# ${DATA}/chgres.inp.sfc -# ${DATA}/chgres.inp.nst -# ${DATA}/chgres.inp.lpl3 -# ${DATA}/chgres.fv3.grd.t[1-6] -# ${DATA}/chgres.fv3.orog.t[1-6] -# ${DATA}/fort.35 -# ${DATA}/fort.81 -# ${DATA}/NULL -# -# Remarks: -# -# Condition codes -# 0 - no problem encountered -# >0 - some problem encountered -# -# Control variable resolution priority -# 1 Command line argument. -# 2 Environment variable. -# 3 Inline default. -# -# Attributes: -# Language: POSIX shell -# Machine: IBM SP -# -#### -################################################################################ -# Set environment. -VERBOSE=${VERBOSE:-"NO"} -if [[ "$VERBOSE" = "YES" ]] ; then - echo $(date) EXECUTING $0 $* >&2 - set -x -fi -# Command line arguments. -APRUNC=${APRUNC:-""} -SIGINP=${1:-${SIGINP:-NULL}} -SFCINP=${2:-${SFCINP:-NULL}} -NSTINP=${3:-${NSTINP:-NULL}} -CASE=${4:-${CASE:?}} -LEVS=${5:-${LEVS:?}} -# Directories. -gfs_ver=${gfs_ver:-v15.0.0} -BASEDIR=${BASEDIR:-${NWROOT:-/nwprod2}} -HOMEgfs=${HOMEgfs:-$BASEDIR/gfs.${gfs_ver}} -EXECgfs=${EXECgfs:-$HOMEgfs/exec} -FIXfv3=${FIXfv3:-$HOMEgfs/fix/fix_fv3_gmted2010} -FIXam=${FIXam:-$HOMEgfs/fix/fix_am} - -DATA=${DATA:-$(pwd)} -# Filenames. -CHGRESEXEC=${CHGRESEXEC:-${EXECgfs}/global_chgres$XC} -# - -CRES=$(echo $CASE | cut -c2-) -JCAP_CASE=$((CRES*2-2)) -LATB_CASE=$((CRES*2)) -LONB_CASE=$((CRES*4)) - -JCAP=${JCAP:-$JCAP_CASE} -LONB=${LONB:-$LONB_CASE} -LATB=${LATB:-$LATB_CASE} - -SIGLEVEL=${SIGLEVEL:-${FIXam}/global_hyblev.l${LEVS}.txt} -if [ $LEVS = 128 ]; then - SIGLEVEL=${SIGLEVEL:-${FIXam}/global_hyblev.l${LEVS}B.txt} -fi -FNGLAC=${FNGLAC:-${FIXam}/global_glacier.2x2.grb} -FNMXIC=${FNMXIC:-${FIXam}/global_maxice.2x2.grb} -FNTSFC=${FNTSFC:-${FIXam}/cfs_oi2sst1x1monclim19822001.grb} -FNSNOC=${FNSNOC:-${FIXam}/global_snoclim.1.875.grb} -FNZORC=${FNZORC:-sib} -FNALBC=${FNALBC:-${FIXam}/global_albedo4.1x1.grb} -FNALBC2=${FNALBC2:-${FIXam}/global_albedo4.1x1.grb} -FNAISC=${FNAISC:-${FIXam}/cfs_ice1x1monclim19822001.grb} -FNTG3C=${FNTG3C:-${FIXam}/global_tg3clim.2.6x1.5.grb} -FNVEGC=${FNVEGC:-${FIXam}/global_vegfrac.0.144.decpercent.grb} -FNVETC=${FNVETC:-${FIXam}/global_vegtype.1x1.grb} -FNSOTC=${FNSOTC:-${FIXam}/global_soiltype.1x1.grb} -FNSMCC=${FNSMCC:-${FIXam}/global_soilmgldas.statsgo.t${JCAP}.${LONB}.${LATB}.grb} -FNVMNC=${FNVMNC:-${FIXam}/global_shdmin.0.144x0.144.grb} -FNVMXC=${FNVMXC:-${FIXam}/global_shdmax.0.144x0.144.grb} -FNSLPC=${FNSLPC:-${FIXam}/global_slope.1x1.grb} -FNABSC=${FNABSC:-${FIXam}/global_snoalb.1x1.grb} -FNMSKH=${FNMSKH:-${FIXam}/global_slmask.t1534.3072.1536.grb} -LANDICE_OPT=${LANDICE_OPT:-2} -CLIMO_FIELDS_OPT=${CLIMO_FIELDS_OPT:-3} -SOILTYPE_INP=${SOILTYPE_INP:-"zobler"} -SOILTYPE_OUT=${SOILTYPE_OUT:-"zobler"} -VEGTYPE_INP=${VEGTYPE_INP:-"sib"} -VEGTYPE_OUT=${VEGTYPE_OUT:-"sib"} -LONSPERLAT=${LONSPERLAT:-NULL} -export INISCRIPT=${INISCRIPT} -export ERRSCRIPT=${ERRSCRIPT:-'eval [[ $err = 0 ]]'} -export LOGSCRIPT=${LOGSCRIPT} -export ENDSCRIPT=${ENDSCRIPT} -# Other variables. -TILE_NUM=${TILE_NUM:-1} -IDRT=${IDRT:-4} -OUTTYP=${OUTTYP:-999} -NTRAC=${NTRAC:-3} -REGIONAL=${REGIONAL:-0} -HALO=${HALO:-0} -gtype=${gtype:-uniform} -IALB=${IALB:-0} -IDVC=${IDVC:-2} -IDVT=${IDVT:-21} -IDVM=${IDVM:-0} -IDSL=${IDSL:-1} -LSOIL=${LSOIL:-0} -IVSSFC=${IVSSFC:-0} -use_ufo=${use_ufo:-.true.} -rdgrid=${rdgrid:-.false.} -NTHREADS=${NTHREADS:-1} -NTHSTACK=${NTHSTACK:-1024000000} -XLSMPOPTS=${XLSMPOPTS:-"parthds=$NTHREADS:stack=$NTHSTACK"} -export KMP_STACKSIZE=${KMP_STACKSIZE:-$NTHSTACK} -export PGMOUT=${PGMOUT:-${pgmout:-'&1'}} -export PGMERR=${PGMERR:-${pgmerr:-'&2'}} -export REDOUT=${REDOUT:-'1>'} -export REDERR=${REDERR:-'2>'} -CHGRESVARS=${CHGRESVARS} -################################################################################ -# Preprocessing -$INISCRIPT -pwd=$(pwd) -if [[ -d $DATA ]] -then - mkdata=NO -else - mkdir -p $DATA - mkdata=YES -fi -cd $DATA||exit 99 -################################################################################ -# Change resolution -#export XLSMPOPTS="parthds=$NTHREADS:stack=$NTHSTACK" -export PGM=$CHGRESEXEC -export pgm=$PGM -$LOGSCRIPT -rm -f NULL -ln -sf $SIGINP chgres.inp.sig -ln -sf $SIGLEVEL chgres.inp.siglevel -ln -sf $SFCINP chgres.inp.sfc -ln -sf $NSTINP chgres.inp.nst -ln -sf $LONSPERLAT chgres.inp.lpl3 - -if [ $gtype = regional ]; then - tile=7 - ln -sf ${FIXfv3}/${CASE}/${CASE}_grid.tile${tile}.halo${HALO}.nc chgres.fv3.grd.t${tile} - ln -sf ${FIXfv3}/${CASE}/${CASE}_oro_data.tile${tile}.halo${HALO}.nc chgres.fv3.orog.t${tile} -else - tile=1 - while [ $tile -le $ntiles ]; do - ln -sf ${FIXfv3}/C${CRES}/C${CRES}_grid.tile${tile}.nc chgres.fv3.grd.t${tile} - ln -sf ${FIXfv3}/C${CRES}/C${CRES}_oro_data.tile${tile}.nc chgres.fv3.orog.t${tile} - tile=`expr $tile + 1 ` - done -fi - -if [[ $LANDICE_OPT = 3 || $LANDICE_OPT = 4 ]] -then - LANDICE=.false. -else - LANDICE=.true. -fi - -if [[ $VEGTYPE_OUT = "sib" ]]; then - IVEGSRC=2 -elif [[ $VEGTYPE_OUT = "igbp" ]]; then - IVEGSRC=1 -fi - -if [[ $SOILTYPE_OUT = "zobler" ]]; then - ISOT=0 -elif [[ $SOILTYPE_OUT = "statsgo" ]]; then - ISOT=1 -fi - -# If the appropriate resolution fix file is not present, use the highest resolution available (T1534) -[[ ! -f $FNSMCC ]] && FNSMCC="$FIXam/global_soilmgldas.statsgo.t1534.3072.1536.grb" - -cat << EOF > fort.35 - &NAMSFC - FNGLAC='${FNGLAC}' - FNMXIC='${FNMXIC}' - FNTSFC='${FNTSFC}' - FNSNOC='${FNSNOC}' - FNZORC='${FNZORC}' - FNALBC='${FNALBC}' - FNALBC2='${FNALBC2}' - FNAISC='${FNAISC}' - FNTG3C='${FNTG3C}' - FNVEGC='${FNVEGC}' - FNVETC='${FNVETC}' - FNSOTC='${FNSOTC}' - FNSMCC='${FNSMCC}' - FNVMNC='${FNVMNC}' - FNVMXC='${FNVMXC}' - FNSLPC='${FNSLPC}' - FNABSC='${FNABSC}' - FNMSKH='${FNMSKH}' - FNTSFA='' - FNACNA='' - FNSNOA='' - LDEBUG=.false. - LANDICE=$LANDICE -/ -EOF - -if [[ $SOILTYPE_INP = "zobler" ]]; then -cat << EOF > fort.81 - &soil_parameters - soil_src_input = "zobler" - smclow_input = 0.5 - smchigh_input = 6.0 - smcmax_input= 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, - 0.404, 0.439, 0.421 - beta_input = 4.26, 8.72, 11.55, 4.74, 10.73, 8.17, - 6.77, 5.25, 4.26 - psis_input = 0.040, 0.620, 0.470, 0.140, 0.100, 0.260, - 0.140, 0.360, 0.040 - satdk_input = 1.41e-5, 0.20e-5, 0.10e-5, 0.52e-5, 0.72e-5, - 0.25e-5, 0.45e-5, 0.34e-5, 1.41e-5 -EOF -elif [[ $SOILTYPE_INP = "statsgo" ]]; then -cat << EOF > fort.81 - &soil_parameters - soil_src_input = "statsgo" - smclow_input = 0.5 - smchigh_input = 6.0 - smcmax_input= 0.395, 0.421, 0.434, 0.476, 0.476, 0.439, - 0.404, 0.464, 0.465, 0.406, 0.468, 0.457, - 0.464, -9.99, 0.200, 0.421 - beta_input = 4.05, 4.26, 4.74, 5.33, 5.33, 5.25, - 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, - 5.25, -9.99, 4.05, 4.26 - psis_input = 0.0350, 0.0363, 0.1413, 0.7586, 0.7586, 0.3548, - 0.1349, 0.6166, 0.2630, 0.0977, 0.3236, 0.4677, - 0.3548, -9.99, 0.0350, 0.0363 - satdk_input = 1.7600e-4, 1.4078e-5, 5.2304e-6, 2.8089e-6, 2.8089e-6, - 3.3770e-6, 4.4518e-6, 2.0348e-6, 2.4464e-6, 7.2199e-6, - 1.3444e-6, 9.7384e-7, 3.3770e-6, -9.99, 1.4078e-5, - 1.4078e-5 -EOF -fi - -if [[ $SOILTYPE_OUT = "zobler" ]]; then -cat << EOF >> fort.81 - soil_src_output = "zobler" - smclow_output = 0.5 - smchigh_output = 6.0 - smcmax_output= 0.421, 0.464, 0.468, 0.434, 0.406, 0.465, - 0.404, 0.439, 0.421 - beta_output = 4.26, 8.72, 11.55, 4.74, 10.73, 8.17, - 6.77, 5.25, 4.26 - psis_output = 0.040, 0.620, 0.470, 0.140, 0.100, 0.260, - 0.140, 0.360, 0.040 - satdk_output = 1.41e-5, 0.20e-5, 0.10e-5, 0.52e-5, 0.72e-5, - 0.25e-5, 0.45e-5, 0.34e-5, 1.41e-5 -/ -EOF -elif [[ $SOILTYPE_OUT = "statsgo" ]]; then -cat << EOF >> fort.81 - soil_src_output = "statsgo" - smclow_output = 0.5 - smchigh_output = 6.0 - smcmax_output= 0.395, 0.421, 0.434, 0.476, 0.476, 0.439, - 0.404, 0.464, 0.465, 0.406, 0.468, 0.457, - 0.464, -9.99, 0.200, 0.421 - beta_output = 4.05, 4.26, 4.74, 5.33, 5.33, 5.25, - 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, - 5.25, -9.99, 4.05, 4.26 - psis_output = 0.0350, 0.0363, 0.1413, 0.7586, 0.7586, 0.3548, - 0.1349, 0.6166, 0.2630, 0.0977, 0.3236, 0.4677, - 0.3548, -9.99, 0.0350, 0.0363 - satdk_output = 1.7600e-4, 1.4078e-5, 5.2304e-6, 2.8089e-6, 2.8089e-6, - 3.3770e-6, 4.4518e-6, 2.0348e-6, 2.4464e-6, 7.2199e-6, - 1.3444e-6, 9.7384e-7, 3.3770e-6, -9.99, 1.4078e-5, - 1.4078e-5 -/ -EOF -fi - -cat << EOF >> fort.81 - &veg_parameters - veg_src_input = "${VEGTYPE_INP}" - veg_src_output = "${VEGTYPE_OUT}" - salp_output= -999. - snup_output= -999. -/ - &options - CLIMO_FIELDS_OPT=${CLIMO_FIELDS_OPT} - LANDICE_OPT=${LANDICE_OPT} - / -EOF - -export OMP_NUM_THREADS=${OMP_NUM_THREADS_CH:-${CHGRESTHREAD:-1}} - - eval $APRUNC $CHGRESEXEC <&2 -fi -exit $err diff --git a/ush/global_chgres_driver.sh b/ush/global_chgres_driver.sh deleted file mode 100755 index e81997c08..000000000 --- a/ush/global_chgres_driver.sh +++ /dev/null @@ -1,297 +0,0 @@ -#!/bin/ksh -set -ax -#------------------------------------------------------------------------------------------------- -# Makes ICs on fv3 globally uniform cubed-sphere grid using operational GFS initial conditions. -# Fanglin Yang, 09/30/2016 -# This script is created based on the C-shell scripts fv3_gfs_preproc/IC_scripts/DRIVER_CHGRES.csh -# and submit_chgres.csh provided by GFDL. APRUN and environment variables are added to run on -# WCOSS CRAY. Directory and file names are standaridized to follow NCEP global model convention. -# This script calls fv3gfs_chgres.sh. -# Fanglin Yang and George Gayno, 02/08/2017 -# Modified to use the new CHGRES George Gayno developed. -# Fanglin Yang 03/08/2017 -# Generalized and streamlined the script and enabled to run on multiple platforms. -# Fanglin Yang 03/20/2017 -# Added option to process NEMS GFS initial condition which contains new land datasets. -# Switch to use ush/global_chgres.sh. -#------------------------------------------------------------------------------------------------- - -export OMP_NUM_THREADS_CH=${OMP_NUM_THREADS_CH:-24} -export APRUNC=${APRUNC:-"time"} - -export CASE=${CASE:-C96} # resolution of tile: 48, 96, 192, 384, 768, 1152, 3072 -export CRES=`echo $CASE | cut -c 2-` -export CDATE=${CDATE:-${cdate:-2017031900}} # format yyyymmddhh yyyymmddhh ... -export CDUMP=${CDUMP:-gfs} # gfs or gdas -export LEVS=${LEVS:-65} -export LSOIL=${LSOIL:-4} -export REGIONAL=${REGIONAL:-0} # default is to assume uniform grid, which is REGIONAL=0 - # REGIONAL=1 - generate data and boundary (for regional case) - # REGIONAL=2 - generate boundaries only (for regional case) - -export VERBOSE=YES -pwd=$(pwd) -export NWPROD=${NWPROD:-$pwd} -export HOMEgfs=${HOMEgfs:-$NWPROD/gfs.v15.0.0} -export FIXfv3=${FIXfv3:-$HOMEgfs/fix/fix_fv3_gmted2010} -export FIXam=${FIXam:-$HOMEgfs/fix/fix_am} -export CHGRESEXEC=$HOMEgfs/exec/global_chgres -export CHGRESSH=$HOMEgfs/ush/global_chgres.sh - -# Location of initial conditions for GFS (before chgres) and FV3 (after chgres) -export INIDIR=${INIDIR:-$pwd} -export OUTDIR=${OUTDIR:-$pwd/INPUT} -mkdir -p $OUTDIR - -export gtype=${gtype:-uniform} # grid type = uniform, stretch, nest or stand alone regional - -if [ $gtype = uniform ]; then - echo "creating uniform ICs" - export ntiles=6 -elif [ $gtype = stretch ]; then - echo "creating stretched ICs" - export ntiles=6 -elif [ $gtype = nest ]; then - echo "creating nested ICs" - export ntiles=7 -elif [ $gtype = regional ]; then - echo "creating standalone regional ICs" - export ntiles=1 - export TILE_NUM=7 -else - echo "Error: please specify grid type with 'gtype' as uniform, stretch, nest, or regional" - exit 9 -fi - -#--------------------------------------------------------------- - -# Temporary rundirectory -export DATA=${DATA:-${RUNDIR:-$pwd/rundir$$}} -if [ ! -s $DATA ]; then mkdir -p $DATA; fi -cd $DATA || exit 8 - -export ymd=`echo $CDATE | cut -c 1-8` -export cyc=`echo $CDATE | cut -c 9-10` - -# Determine if input data is: -# (1) FV3GFS - DATA IS NEMSIO. SFC AND NSST FIELDS IN ONE FILE ('fv3gfs') -# (2) GFS NEMSIO FORMAT. SFC AND NSST FIELDS IN SEPARATE FILES ('opsgfs') -# (3) GFS SIGIO/SFCIO FORMAT ('oldgfs') - -if [ ${ATMANL:-"NULL"} = "NULL" ]; then - if [ -s ${INIDIR}/nsnanl.${CDUMP}.$CDATE -o -s ${INIDIR}/${CDUMP}.t${cyc}z.nstanl.nemsio ]; then - ictype='opsgfs' - elif [ -s ${INIDIR}/sfnanl.${CDUMP}.$CDATE -o -s ${INIDIR}/${CDUMP}.t${cyc}z.sfcanl.nemsio ]; then - ictype='fv3gfs' - else - ictype='oldgfs' - fi -else - if [ ${NSTANL:-"NULL"} = "NULL" ]; then - ictype='oldgfs' - else - ictype='opsgfs' - fi -fi - -if [ $ictype = oldgfs ]; then # input data is old spectral sigio format. - - if [ ${ATMANL:-"NULL"} = "NULL" ]; then - if [ -s ${INIDIR}/siganl.${CDUMP}.$CDATE ]; then - export ATMANL=$INIDIR/siganl.${CDUMP}.$CDATE - export SFCANL=$INIDIR/sfcanl.${CDUMP}.$CDATE - else - export ATMANL=$INIDIR/${CDUMP}.t${cyc}z.sanl - export SFCANL=$INIDIR/${CDUMP}.t${cyc}z.sfcanl - fi - fi - - export NSTANL="NULL" - export SOILTYPE_INP=zobler - export VEGTYPE_INP=sib - export nopdpvv=.false. - - #--sigio to user defined lat-lon gaussian grid - JCAP_CASE=$((CRES*2-2)) - LONB_ATM=$((CRES*4)) - LATB_ATM=$((CRES*2)) - LONB_SFC=$((CRES*4)) - LATB_SFC=$((CRES*2)) - if [ $CRES -gt 768 -o $gtype = stretch -o $gtype = nest ]; then - JCAP_CASE=1534 - LONB_ATM=3072 - LATB_ATM=1536 - LONB_SFC=3072 - LATB_SFC=1536 - fi - -elif [ $ictype = opsgfs ] || [ $ictype = fv3gfs ]; then # input data is nemsio format. - - if [ ${ATMANL:-"NULL"} = "NULL" ]; then - if [ -s ${INIDIR}/gfnanl.${CDUMP}.$CDATE ]; then - export ATMANL=$INIDIR/gfnanl.${CDUMP}.$CDATE - export SFCANL=$INIDIR/sfnanl.${CDUMP}.$CDATE - if [ $ictype = opsgfs ] ; then - export NSTANL=$INIDIR/nsnanl.${CDUMP}.$CDATE - else - export NSTANL=NULL - fi - else - export ATMANL=$INIDIR/${CDUMP}.t${cyc}z.atmanl.nemsio - export SFCANL=$INIDIR/${CDUMP}.t${cyc}z.sfcanl.nemsio - if [ $ictype = opsgfs ] ; then - export NSTANL=$INIDIR/${CDUMP}.t${cyc}z.nstanl.nemsio - else - export NSTANL=NULL - fi - fi - fi - - export SOILTYPE_INP=statsgo - export VEGTYPE_INP=igbp - - if [ $ictype = opsgfs ]; then - export nopdpvv=.true. - else - export nopdpvv=.false. - export NTRAC=7 - fi - - LONB_ATM=0 # not used for - LATB_ATM=0 # ops files - JCAP_CASE=$((CRES*2-2)) - LONB_SFC=$((CRES*4)) - LATB_SFC=$((CRES*2)) - if [ $CRES -gt 768 -o $gtype = stretch -o $gtype = nest ]; then - JCAP_CASE=1534 - LONB_SFC=3072 - LATB_SFC=1536 - fi -fi # is input data old or new format? - - -# to use new albedo, soil/veg type -export CLIMO_FIELDS_OPT=3 -export LANDICE_OPT=${LANDICE_OPT:-2} -export IALB=1 -export SOILTYPE_OUT=statsgo -export VEGTYPE_OUT=igbp -export FNZORC=igbp - -export SIGLEVEL=${FIXam}/global_hyblev.l${LEVS}.txt -if [ $LEVS = 128 ]; then export SIGLEVEL=${FIXam}/global_hyblev.l${LEVS}B.txt; fi -export FNGLAC=${FIXam}/global_glacier.2x2.grb -export FNMXIC=${FIXam}/global_maxice.2x2.grb -export FNTSFC=${FIXam}/cfs_oi2sst1x1monclim19822001.grb -export FNSNOC=${FIXam}/global_snoclim.1.875.grb -export FNALBC2=${FIXam}/global_albedo4.1x1.grb -export FNAISC=${FIXam}/cfs_ice1x1monclim19822001.grb -export FNTG3C=${FIXam}/global_tg3clim.2.6x1.5.grb -export FNVEGC=${FIXam}/global_vegfrac.0.144.decpercent.grb -export FNVMNC=${FIXam}/global_shdmin.0.144x0.144.grb -export FNVMXC=${FIXam}/global_shdmax.0.144x0.144.grb -export FNSLPC=${FIXam}/global_slope.1x1.grb -export FNMSKH=${FIXam}/global_slmask.t1534.3072.1536.grb -export FNSMCC=$FIXam/global_soilmgldas.statsgo.t${JCAP_CASE}.${LONB_SFC}.${LATB_SFC}.grb -export FNSOTC=$FIXam/global_soiltype.statsgo.t${JCAP_CASE}.${LONB_SFC}.${LATB_SFC}.rg.grb -export FNVETC=$FIXam/global_vegtype.igbp.t${JCAP_CASE}.${LONB_SFC}.${LATB_SFC}.rg.grb -export FNABSC=$FIXam/global_mxsnoalb.uariz.t${JCAP_CASE}.${LONB_SFC}.${LATB_SFC}.rg.grb -export FNALBC=$FIXam/global_snowfree_albedo.bosu.t${JCAP_CASE}.${LONB_SFC}.${LATB_SFC}.rg.grb - -# -# For a regional run, if REGIONAL=2 (generate boundary data only) this script is called multiple times -# so that each boundary time other than hour 0 will be done individually. This allows multiple instances -# of chgres to execute simultaneously -# - -if [ $REGIONAL -ne 2 ]; then # REGIONAL -ne 2 is for uniform and regional hour 0 - -#------------------------------------------------ -# Convert atmospheric file. -#------------------------------------------------ - - export CHGRESVARS="use_ufo=.false.,idvc=2,nvcoord=2,idvt=21,idsl=1,IDVM=0,nopdpvv=$nopdpvv" - export SIGINP=$ATMANL - export SFCINP=NULL - export NSTINP=NULL - export JCAP=$JCAP_CASE - export LATB=$LATB_ATM - export LONB=$LONB_ATM - $CHGRESSH - rc=$? - if [[ $rc -ne 0 ]] ; then - echo "***ERROR*** rc= $rc" - exit $rc - fi - - mv ${DATA}/gfs_data.tile*.nc $OUTDIR/. - mv ${DATA}/gfs_ctrl.nc $OUTDIR/. - if [ $gtype = regional ]; then - mv ${DATA}/gfs_bndy.tile7.nc $OUTDIR/gfs_bndy.tile7.000.nc - fi - -#--------------------------------------------------- -# Convert surface and nst files one tile at a time. -#--------------------------------------------------- - - export CHGRESVARS="use_ufo=.true.,idvc=2,nvcoord=2,idvt=21,idsl=1,IDVM=0,nopdpvv=$nopdpvv" - export SIGINP=NULL - export SFCINP=$SFCANL - export NSTINP=$NSTANL - export JCAP=$JCAP_CASE - export LATB=$LATB_SFC - export LONB=$LONB_SFC - - if [ $gtype = regional ]; then - $CHGRESSH - mv ${DATA}/out.sfc.tile${TILE_NUM}.nc $OUTDIR/sfc_data.tile${TILE_NUM}.nc - rc=$? - if [[ $rc -ne 0 ]] ; then - echo "***ERROR*** rc= $rc" - exit $rc - fi - else - tile=1 - while [ $tile -le $ntiles ]; do - export TILE_NUM=$tile - $CHGRESSH - rc=$? - if [[ $rc -ne 0 ]] ; then - echo "***ERROR*** rc= $rc" - exit $rc - fi - mv ${DATA}/out.sfc.tile${tile}.nc $OUTDIR/sfc_data.tile${tile}.nc - tile=`expr $tile + 1 ` - done - fi - -else # REGIONAL = 2, just generate boundary data - - export CHGRESVARS="use_ufo=.false.,nst_anl=$nst_anl,idvc=2,idvt=21,idsl=1,IDVM=0,nopdpvv=$nopdpvv" - if [ $ictype = oldgfs ]; then - export ATMANL=$INIDIR/${CDUMP}.t${cyc}z.sf${bchour} - else - export ATMANL=$INIDIR/${CDUMP}.t${cyc}z.atmf${bchour}.nemsio - fi - export SIGINP=$ATMANL - export SFCINP=NULL - export NSTINP=NULL - export LATB=$LATB_ATM - export LONB=$LONB_ATM - -# -# run chgres and check rc to make sure it was successful -# - - $CHGRESSH - rc=$? - if [[ $rc -ne 0 ]] ; then - echo "***ERROR*** rc= $rc" - exit $rc - fi - - mv ${DATA}/gfs_bndy.tile7.nc $OUTDIR/gfs_bndy.tile7.${bchour}.nc - -fi - -exit 0 From 5b27654f0db3b3194e11f0740892b7cc1b053610 Mon Sep 17 00:00:00 2001 From: Edward Hartnett <38856240+edwardhartnett@users.noreply.github.com> Date: Wed, 24 Feb 2021 08:03:51 -0700 Subject: [PATCH 47/47] now pass filename to read_setup_namelist() (#347) --- sorc/chgres_cube.fd/program_setup.f90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/sorc/chgres_cube.fd/program_setup.f90 b/sorc/chgres_cube.fd/program_setup.f90 index ef260e516..4ec07d3e9 100644 --- a/sorc/chgres_cube.fd/program_setup.f90 +++ b/sorc/chgres_cube.fd/program_setup.f90 @@ -144,11 +144,13 @@ module program_setup !> Reads program configuration namelist. !! +!! @param filename the name of the configuration file (defaults to ./fort.41). !! @author George Gayno NCEP/EMC - subroutine read_setup_namelist - + subroutine read_setup_namelist(filename) implicit none - + + character(len=*), intent(in), optional :: filename + character(:), allocatable :: filename_to_use integer :: is, ie, ierr @@ -191,7 +193,13 @@ subroutine read_setup_namelist print*,"- READ SETUP NAMELIST" - open(41, file="./fort.41", iostat=ierr) + if (present(filename)) then + filename_to_use = filename + else + filename_to_use = "./fort.41" + endif + + open(41, file=filename_to_use, iostat=ierr) if (ierr /= 0) call error_handler("OPENING SETUP NAMELIST.", ierr) read(41, nml=config, iostat=ierr) if (ierr /= 0) call error_handler("READING SETUP NAMELIST.", ierr)